[英]Adding default signature, that consists of images, in Outlook using Excel VBA
I want to add signatures with images. 我想添加带图像的签名。 Images here refer to company logo and social networking icons.
这里的图像是指公司徽标和社交网络图标。
This code is written in Excel VBA and the goal is to copy paste the range as a picture in Outlook email. 此代码是用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
This file is to be distributed to many people. 该文件将分发给许多人。 I wouldn't know the default .htm signature name.
我不知道默认的.htm签名名称。
(“AppData\\Roaming\\Microsoft\\Signatures”) (“应用程序数据\\漫游\\微软\\签名”)
People may also have many signatures but my goal is to capture their default signature. 人们可能也有很多签名,但我的目标是捕获他们的默认签名。
In this code we will let the user select the .Htm
file from AppData\\Roaming\\Microsoft\\Signatures
在此代码中,我们将让用户从
AppData\\Roaming\\Microsoft\\Signatures
选择.Htm
文件
The problem is that we cannot directly use the html body of this file because the images are stored in a different folder named as filename_files
as shown below. 问题是我们无法直接使用此文件的html主体,因为图像存储在名为
filename_files
的不同文件夹中,如下所示。
Also the paths mentioned in the htmlbody are incomplete. html体中提到的路径也是不完整的。 See the below images
见下图
Here is a quick function that I wrote which will fix the paths in the html body 这是我写的一个快速函数,它将修复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
Here is the complete procedure. 这是完整的程序。 I have commented the code.
我评论了代码。 Let me know if you still have any issues.
如果您还有任何问题,请告诉我。
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
In Action 在行动中
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.