如何用Excel VBA在含HTMLBody的Outlook会议邀请中插入带图片签名

问题核心：当前代码直接读取签名的HTML文本内容，但签名中的图片使用相对路径存储，会议邀请无法解析这些路径，导致图片仅显示为空占位符。

问题原因 #

Outlook签名的HTML文件中，图片引用的是相对路径（例如./[签名名]_files/xxx.png），直接把HTML内容拼接到会议邀请的HTMLBody时，程序无法找到图片的实际位置，因此无法加载图片。

修正后的代码 #

以下代码会自动修正签名HTML中的图片路径为绝对路径，并正确插入到会议邀请中：

Option Explicit

Sub SendInviteToMultiple()
    Dim OutApp As Outlook.Application, Outmeet As Outlook.AppointmentItem
    Dim I As Long, setupsht As Worksheet, Mtext As Worksheet
    Dim sigHTML As String, sigPath As String, sigFolder As String
    Dim fso As Object, sigFile As String
    Dim regex As Object
    Dim imgMatch As Object
    
    ' 获取签名文件夹路径
    sigFolder = Environ("appdata") & "\Microsoft\Signatures\"
    If Dir(sigFolder, vbDirectory) = vbNullString Then
        MsgBox "未找到签名文件夹", vbExclamation
        Exit Sub
    End If
    
    ' 获取第一个HTML签名文件
    sigFile = Dir(sigFolder & "*.htm")
    If sigFile = "" Then
        MsgBox "未找到HTML格式的签名", vbExclamation
        Exit Sub
    End If
    sigPath = sigFolder & sigFile
    
    ' 读取签名HTML内容
    Set fso = CreateObject("Scripting.FileSystemObject")
    sigHTML = fso.OpenTextFile(sigPath, 1, -2).ReadAll
    
    ' 修正图片路径为绝对路径
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "src=""([^""]+)"""
    regex.Global = True
    For Each imgMatch In regex.Execute(sigHTML)
        ' 替换相对路径为绝对路径
        sigHTML = Replace(sigHTML, imgMatch.SubMatches(0), sigFolder & imgMatch.SubMatches(0))
    Next imgMatch
    
    Set setupsht = Worksheets("Outlook")
    Set Mtext = Worksheets("Legend")
    
    ' 初始化Outlook应用（只初始化一次，避免循环内重复创建）
    Set OutApp = New Outlook.Application
    
    For I = 2 To setupsht.Range("A" & Rows.Count).End(xlUp).Row
        Set Outmeet = OutApp.CreateItem(olAppointmentItem)
        
        With Outmeet
            .Subject = Mtext.Range("I1")
            .RequiredAttendees = setupsht.Range("W" & I).Value
            .OptionalAttendees = setupsht.Range("J" & I).Value
            .Start = setupsht.Range("P" & I).Value
            .Duration = 30
            .Importance = olImportanceHigh
            .Location = setupsht.Range("D" & I).Value
            .MeetingStatus = olMeeting
            .ReminderMinutesBeforeStart = 15
            
            ' 构建完整的HTML内容并设置给会议邀请
            .BodyFormat = olFormatHTML
            .HTMLBody = "Bonjour " & setupsht.Range("H" & I).Value & ",<BR><BR>" & _
            "Dans le cadre de votre " & setupsht.Range("E" & I).Value & ", vous " & Mtext.Range("I4") & " convoqué(e) <b>le " & setupsht.Range("Q" & I).Value & " la médecine du travail qui se trouve:<BR><BR>" & _
            "<b>" & setupsht.Range("C" & I).Value & " - " & setupsht.Range("D" & I).Value & "</b><BR><BR>" & _
            setupsht.Range("AF" & I).Value & "<BR><BR>" & _
            Mtext.Range("I5").Value & "<BR><BR>" & _
            Mtext.Range("I6").Value & "<span style=""color:#ff0000""><b> merci de nous faire parvenir votre <u>fiche d’aptitude.</u></b></span><BR><BR>" & _
            Mtext.Range("I7").Value & "<BR><BR>" & _
            "Cordialment," & sigHTML
            
            .Display
            '.Send
        End With
        
    Next I
    
    ' 释放对象
    Set Outmeet = Nothing
    Set OutApp = Nothing
    Set fso = Nothing
    Set regex = Nothing
End Sub

关键改进点 #

• 修正图片路径：使用正则表达式将签名HTML中的相对图片路径替换为绝对路径，确保会议邀请能找到图片文件。
• 优化Outlook初始化：将Outlook应用的初始化移到循环外，避免重复创建对象，提升效率。
• 直接设置会议邀请的HTMLBody：无需通过MailItem中转复制粘贴，直接构建完整HTML内容，减少不必要的对象操作。

内容的提问来源于stack exchange，提问作者Walentyne