使用excel VBA在Outlook中添加包含图像的签名

我有代码，除了不添加图像签名。 这里的图片是指公司的标志和社交networking图标。

此代码是用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 = "[e-mail]" ToAddress = "[e-mail]" '\\ 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签名名称。

（“应用程序数据\漫游\微软\签名”）

人们也可能有很多签名，但我的目标是捕获他们的默认签名。

运行代码后错误签名图片

我的签名应该如下所示vs上面链接的错误一。

Answer 1

在这段代码中，我们将让用户从AppData\Roaming\Microsoft\Signaturesselect.Htm文件

问题是我们不能直接使用这个文件的html正文，因为这些图像存储在一个名为filename_files的不同文件夹中，如下所示。

在htmlbody中提到的path也是不完整的。 看到下面的图片

这是我写的一个快速函数，它将修复html正文中的path

 '~~> 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 = "[e-mail]" '<~~ 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 

在行动