gpt4 book ai didi

excel - 使用 Excel VBA 在 Outlook 中添加由图像组成的默认签名

转载 作者:行者123 更新时间:2023-12-02 10:24:29 24 4
gpt4 key购买 nike

我想添加带有图像的签名。此处的图片指的是公司 Logo 和社交网络图标。

此代码是用 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 签名名称。

(“AppData\Roaming\Microsoft\Signatures”)

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

运行代码后签名图片出错
enter image description here

我的签名应如下所示。
My signature should have been this

最佳答案

在此代码中,我们将让用户从 AppData\Roaming\Microsoft\Signatures 中选择 .Htm 文件

问题是我们无法直接使用该文件的 html 正文,因为图像存储在名为 filename_files 的不同文件夹中,如下所示。

enter image description here

此外,htmlbody 中提到的路径也不完整。请参阅下面的图片

enter image description here

这是我编写的一个快速函数,它将修复 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

实际行动

enter image description here

关于excel - 使用 Excel VBA 在 Outlook 中添加由图像组成的默认签名,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/39654861/

24 4 0
Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
广告合作:1813099741@qq.com 6ren.com