vba - 直接从 Excel 发送时，VBA Excel 代码不会在签名中嵌入图像

Question

我已经从之前的代码讨论中正确创建了 HTMLBody 和 Signature 清理代码。我有创建直接绑定到图像文件并使用.send 的宏，但是当我这样做时，接收器端没有显示任何内容。

虽然，当我使用 .display 然后使用显示器的发送时，正确地附加了图像。我使用的文件不在 /Signatures 路径中，因此 Outlook 无法访问该文件以正确“附加”。

原始代码有参考签名..那当然没有用。第二个实例我使用了通常是修复的 GetSignature 函数。然后，我在电子邮件结构中添加了对图像的直接引用作为附加行，以确保我没有做一些愚蠢的事情。我还从 GetSignature 中提取了返回 HTML，并从 VBA.Replace 中提取了更改后的 HTML .. 一切都指向工作站上的有效文件。

Dim OutApp, OutMail As Object
Dim ws, wsTemp, wsEmail As Worksheet
Dim tempLO As Range
Dim TagName, NameValue, LangValue, DocLoc, compFilename, NameLine As String
Dim emSalutation, emBody, emClose As String
Dim StrSignature, LangCert, LangSubject, LangSig, LangSheet, tempLoc, compLoc As String
Dim sPath As String
Dim signImageFolderName, signImageOutlookFolder As String
Dim completeFolderPath, completeTempPath, completeCompPath As String
Dim lastRow As Long
Dim mailSTR As String
Dim runDate, SkipValue, errorTxt As String
Dim answer, emailCnt, certCnt As Integer
Dim testin As Boolean

Dim sTxtFilePath As String
Dim txtFileNumber As Integer

Set ws = Sheets("Certificates")
Set wsTemp = Sheets("Templates")
Set tempLO = wsTemp.Range("Template_Table")

Set OutApp = CreateObject("Outlook.Application")

DocLoc = wsTemp.Range("B2").Value

'Get the row data from Certificates to work with, name and lang

NameValue = .Cells(i, 1).Value
LangValue = .Cells(i, 3).Value
SkipValue = .Cells(i, 4).Value

'Get the Certificate, Email Subject, Email Tab and Email Signature for the correct set language
LangCert = Application.WorksheetFunction.VLookup(LangValue, tempLO, 2, False)
LangSubject = Application.WorksheetFunction.VLookup(LangValue, tempLO, 3, False)
LangSig = Application.WorksheetFunction.VLookup(LangValue, tempLO, 4, False)
LangSheet = "Email_" & LangValue

Set wsEmail = Sheets("Email_" & LangValue)

sPath = DocLoc & LangSig & ".htm"
signImageFolderName = LangSig & "_files"
signImageOutlookFolder = signImageFolderName & "/"
completeFolderPath = DocLoc & signImageFolderName & "\"

errorTxt = OpenFile(DocLoc & LangSig & ".htm")
errorTxt = Folder_Exist_With_Dir(DocLoc & signImageFolderName, 3)

StrSignature = GetSignature(sPath)

StrSignature = VBA.Replace(StrSignature, signImageOutlookFolder, completeFolderPath)

Print #txtFileNumber, StrSignature

Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail

    If Not IsEmpty(wsTemp.Range("B7").Value) And (wsTemp.Range("B7").Value Like "?*@?*.?*") Then
        .SentOnBehalfOfName = wsTemp.Range("B7").Value
    End If

    .Subject = LangSubject

    emSalutation = "<font style=""font-family: Calibri; Color: #1F497D; font-size: 14pt;""/font>" & _
                   ws.Range("A" & i).Value & ";<br>"
    emBody = RangetoHTML(wsEmail.UsedRange)
    emClose = "<br>" & StrSignature _
            & "<br>" _
            & "<img src='C:\<directory path to OneDrive Folder>\BTSL_SecAware_files\image001.png'>"

    .HTMLBody = emSalutation & emBody & emClose

    If IsEmpty(ws.Range("B" & i).Value) Or Not (ws.Range("B" & i).Value Like "?*@?*.?*") Then
        .To = "Display Only"
        .Display                                 'or use
    Else
        .To = ws.Range("B" & i).Value
        .Send
        emailCnt = emailCnt + 1
    End If

End With
Set OutMail = Nothing

---

Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         fileName:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close SaveChanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Function GetSignature(ByVal fPath As String) As String
    Dim fso As Object
    Dim TSet As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set TSet = fso.GetFile(fPath).OpenAsTextStream(1, -2)
    GetSignature = TSet.ReadAll
    TSet.Close
End Function

代码基本上归结为从 .htm 的文本文件中读取的目录中提取签名文件，并使用不同的内容对其进行更新。在这种情况下，是一个合格的目录路径。

当它运行并且这个文件被添加到 Htmlbody 和 .sent 时，它不会嵌入图像，但是当它被 .displayed 然后发送它时嵌入。

<link rel=File-List href="C:\<directory path to OneDrive Folder>\BTSL_SecAware2_files\filelist.xml">
<link rel=Edit-Time-Data href="C:\<directory path to OneDrive Folder>\BTSL_SecAware2_files\editdata.mso">
<!--[if !mso]>
<style>
v\:* {behavior:url(#default#VML);}
o\:* {behavior:url(#default#VML);}
w\:* {behavior:url(#default#VML);}
.shape {behavior:url(#default#VML);}
</style>
<![endif]--><!--[if gte mso 9]><xml>
 <o:OfficeDocumentSettings>
  <o:AllowPNG/>
 </o:OfficeDocumentSettings>
</xml><![endif]-->
<link rel=themeData href="C:\<directory path to OneDrive Folder>\BTSL_SecAware2_files\themedata.thmx">
<link rel=colorSchemeMapping href="C:\<directory path to OneDrive Folder>\BTSL_SecAware2_files\colorschememapping.xml">
<!--[if gte mso 9]><xml>

标签： vbaimagesignature