如何通过VBA引用单元格图片路径并将图片嵌入邮件？

原代码存在的问题 #

• HTML标签语法错误，缺少尖括号，变量与字符串的拼接方式不符合VBA规则
• 未初始化Outlook邮件对象，EmailItem未定义创建
• 直接引用本地路径可能导致收件方无法加载图片（需收件端能访问该文件路径）

方法1：直接引用本地图片路径（限收件方可访问该路径场景） #

以下是修复后的完整代码：

Sub SendSubTo_email()
    Dim we As Worksheet
    Dim PhotoFilePath As String
    Dim olApp As Object
    Dim EmailItem As Object
    
    ' 指定工作表
    Set we = ThisWorkbook.Sheets("Master_Tab")
    ' 获取单元格中的图片路径
    PhotoFilePath = we.Range("J5").Value
    
    ' 校验路径有效性
    If PhotoFilePath = "" Then
        MsgBox "单元格J5未填写图片路径！", vbExclamation
        Exit Sub
    End If
    If Dir(PhotoFilePath) = "" Then
        MsgBox "指定图片不存在：" & PhotoFilePath, vbCritical
        Exit Sub
    End If
    
    ' 初始化Outlook应用
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    
    ' 创建邮件项
    Set EmailItem = olApp.CreateItem(0) ' 0代表olMailItem
    
    ' 构建HTML内容，转换路径为HTML可识别的file:///格式
    EmailItem.HTMLBody = "<html><body>" & _
                         "<img src='file:///" & Replace(PhotoFilePath, "\", "/") & "' width='90%' height='90%'>" & _
                         "</body></html>"
    
    ' 配置邮件基础信息
    EmailItem.Subject = "嵌入图片测试"
    EmailItem.To = "收件人邮箱@domain.com"
    
    ' 显示邮件（如需直接发送，替换为EmailItem.Send）
    EmailItem.Display
    
    ' 释放对象
    Set EmailItem = Nothing
    Set olApp = Nothing
    Set we = Nothing
End Sub

方法2：将图片作为嵌入附件（推荐，无需收件方访问原路径） #

通过CID（内容ID）关联图片，将图片作为邮件隐藏附件嵌入，兼容性更强：

Sub SendEmailWithEmbeddedImage()
    Dim we As Worksheet
    Dim PhotoFilePath As String
    Dim olApp As Object
    Dim EmailItem As Object
    Dim attach As Object
    Dim cid As String
    
    Set we = ThisWorkbook.Sheets("Master_Tab")
    PhotoFilePath = we.Range("J5").Value
    
    ' 校验路径有效性
    If PhotoFilePath = "" Or Dir(PhotoFilePath) = "" Then
        MsgBox "图片路径无效！", vbCritical
        Exit Sub
    End If
    
    ' 初始化Outlook应用
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    
    ' 创建邮件项并添加图片附件
    Set EmailItem = olApp.CreateItem(0)
    Set attach = EmailItem.Attachments.Add(PhotoFilePath)
    cid = "embedded_img_001" ' 自定义唯一ID，避免冲突
    
    ' 设置附件为嵌入类型
    attach.PropertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x3712001F", cid
    
    ' 构建HTML内容，通过CID引用嵌入图片
    EmailItem.HTMLBody = "<html><body>" & _
                         "<img src='cid:" & cid & "' width='90%' height='90%'>" & _
                         "</body></html>"
    
    ' 配置邮件基础信息
    EmailItem.Subject = "嵌入图片测试（CID方式）"
    EmailItem.To = "收件人邮箱@domain.com"
    
    ' 显示邮件（如需直接发送，替换为EmailItem.Send）
    EmailItem.Display
    
    ' 释放对象
    Set attach = Nothing
    Set EmailItem = Nothing
    Set olApp = Nothing
    Set we = Nothing
End Sub

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