添加簽名使用Excel VBA

Question

我的代碼只是它其中的作品不與圖像添加簽名在Outlook中包括圖像。這裏的圖片是指公司徽標和社交網絡圖標。

此代碼是用Excel VBA編寫的，目標是將範圍作爲圖片複製粘貼到Outlook電子郵件中。

Dim Rng      As Range 
Dim outlookApp    As Object 
Dim outMail     As Object 

Dim wordDoc     As Word.Document 
Dim LastRow     As Long 
Dim CcAddress    As String 
Dim ToAddress    As String 
Dim i      As Long 
Dim EndRow     As String 

Dim Signature    As String 

'// Added Microsoft word reference 

Sub Excel_Image_Paste_Testing() 

    On Error GoTo Err_Desc 

    '\\ Define Endrow 
    EndRow = Range("A65000").End(xlUp).Row 

    '\\ Range for copy paste as image 
    Set Rng = Range("A22:G" & EndRow) 
    Rng.Copy 

    '\\ Open a new mail item 
    Set outlookApp = CreateObject("Outlook.Application") 
    Set outMail = outlookApp.CreateItem(0) 

    '\\ Display message to capture signature 
    outMail.Display 

    '\\ This doesnt store images because its defined as string 
    'Problem lies here 
    Signature = outMail.htmlBody 

    '\\ Get its Word editor 
    Set wordDoc = outMail.GetInspector.WordEditor 
    outMail.Display 

    '\\ To paste as picture 
    wordDoc.Range.PasteAndFormat wdChartPicture 

    '\\ TO and CC Address 
    CcAddress = "xyz@gmail.com" 
    ToAddress = "abc@gmail.com" 

    '\\ Format email 
    With outMail 
     .htmlBody = .htmlBody & Signature 
     .Display 
     .To = ToAddress 
     .CC = CcAddress 
     .BCC = "" 
     .Subject = "Email Subject here" 
     .readreceiptrequested = True 
    End With 

    '\\ Reset selections 
    Application.CutCopyMode = False 
    Range("B1").Select 

    Exit Sub 
Err_Desc: 
    MsgBox Err.Description 

End Sub 

請注意，這個文件將被分配給許多人，使他們有自己的默認簽名。所以我不知道默認的.htm簽名名稱。

（「應用程序數據\漫遊\微軟\簽名」）

的人也可能有許多簽名，但我的目標是奪取其默認簽名。

Error signature picture after running the code

我的簽名應該是如下圖所示VS錯誤一個在上面的鏈接。

Answer 1

在這段代碼中，我們將讓用戶選擇從AppData\Roaming\Microsoft\Signatures

的問題.Htm文件是我們不能直接使用此文件的HTML體，因爲圖像存儲在不同的文件夾命名爲filename_files，如下所示。

另外在htmlbody提到的路徑是不完整的。請參閱下面的圖片

這裏是我寫的，這將固定在html體

'~~> Function to fix image paths in Signature .htm Files 
Function FixHtmlBody(r As Variant) As String 
    Dim FullPath As String, filename As String 
    Dim FilenameWithoutExtn As String 
    Dim foldername As String 
    Dim MyData As String 

    '~~> Read the html file as text file in a string variable 
    Open r For Binary As #1 
    MyData = Space$(LOF(1)) 
    Get #1, , MyData 
    Close #1 

    '~~> Get File Name from path 
    filename = GetFilenameFromPath(r) 
    '~~> Get File Name without extension 
    FilenameWithoutExtn = Left(filename, (InStrRev(filename, ".", -1, vbTextCompare) - 1)) 
    '~~> Get the foldername where the images are stored 
    foldername = FilenameWithoutExtn & "_files" 
    '~~> Full Path of Folder 
    FullPath = Left(r, InStrRev(r, "\")) & foldername 

    '~~> Replace incomplete path with full Path 
    FixHtmlBody = Replace(MyData, foldername, FullPath) 
End Function 

下面是完整的程序路徑的快速功能。我已經評論了代碼。如果您仍然有任何問題，請告訴我。

Sub Sample() 
    Dim oOutApp As Object, oOutMail As Object 
    Dim strbody As String, FixedHtmlBody As String 
    Dim Ret 

    '~~> Ask user to select the htm file 
    Ret = Application.GetOpenFilename("Html Files (*.htm), *.htm") 

    If Ret = False Then Exit Sub 

    '~~> Use the function to fix image paths in the htm file 
    FixedHtmlBody = FixHtmlBody(Ret) 

    Set oOutApp = CreateObject("Outlook.Application") 
    Set oOutMail = oOutApp.CreateItem(0) 

    strbody = "<H3><B>Dear Blah Blah</B></H3>" & _ 
       "More Blah Blah<br>" & _ 
       "<br><br><B>Thank you</B>" & FixedHtmlBody 

    On Error Resume Next 
    With oOutMail 
     .To = "Email@email.com" '<~~ Change as applicable 
     .CC = "" 
     .BCC = "" 
     .Subject = "Example on how to insert image in signature" 
     .HTMLBody = .HTMLBody & "<br>" & strbody 
     .Display 
    End With 
    On Error GoTo 0 

    Set oOutMail = Nothing 
    Set oOutApp = Nothing 
End Sub 

'~~> Function to fix image paths in Signature .htm Files 
Function FixHtmlBody(r As Variant) As String 
    Dim FullPath As String, filename As String 
    Dim FilenameWithoutExtn As String 
    Dim foldername As String 
    Dim MyData As String 

    '~~> Read the html file as text file in a string variable 
    Open r For Binary As #1 
    MyData = Space$(LOF(1)) 
    Get #1, , MyData 
    Close #1 

    '~~> Get File Name from path 
    filename = GetFilenameFromPath(r) 
    '~~> Get File Name without extension 
    FilenameWithoutExtn = Left(filename, (InStrRev(filename, ".", -1, vbTextCompare) - 1)) 
    '~~> Get the foldername where the images are stored 
    foldername = FilenameWithoutExtn & "_files" 

    '~~> Full Path of Folder 
    FullPath = Left(r, InStrRev(r, "\")) & foldername 

    '~~> To cater for spaces in signature file name 
    FullPath = Replace(FullPath, " ", "%20") 

    '~~> Replace incomplete path with full Path 
    FixHtmlBody = Replace(MyData, foldername, FullPath) 
End Function 

'~~> Gets File Name from path 
Public Function GetFilenameFromPath(ByVal strPath As String) As String 
    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then _ 
    GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1) 
End Function 

在行動