Excel VBA邮件宏无法添加工作簿路径超链接求助

需要实现的Outlook邮件要求：

• 收件人：取自「Info」工作表M2到最后非空行的邮箱地址
• 抄送：硬编码指定邮箱
• 主题：Overview - [今日日期]
• 正文包含：
  • 问候语「Dear all,」
  • 提示语「Please find below overview of today. Click this link to open the file」（其中「link」是当前工作簿路径的超链接）
  • 「Status」工作表B2:W62区域的截图
  • 用户邮箱签名
• 邮件仅显示供检查，不自动发送

现有代码无法实现超链接功能，以下是修正后的完整代码：

Sub Mail()
    If ActiveSheet.Name <> "Status" Then
        MsgBox "This macro can only be executed from the Status sheet!"
        Exit Sub
    End If

    Dim Ol As Object 'Outlook.Application
    Dim Olemail As Object 'Outlook.MailItem
    Dim Olinsp As Object 'Outlook.Inspector
    Dim Wd As Object 'Word.Document
    Dim Maillist As String
    
    Application.ScreenUpdating = False
    
    Dim LastMember As Long
    LastMember = Worksheets("Info").Cells(Rows.Count, 13).End(xlUp).Row
    
    ' 拼接收件人列表，避免开头多余分号
    For Each cell In ActiveWorkbook.Sheets("Info").Range("M2:M" & LastMember).Cells.SpecialCells(xlCellTypeVisible)
        If cell.Value <> "" Then
            If Maillist <> "" Then Maillist = Maillist & ";"
            Maillist = Maillist & cell.Value
        End If
    Next

    ' 确保Outlook实例存在
    On Error Resume Next
    Set Ol = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If Ol Is Nothing Then Set Ol = CreateObject("Outlook.Application")
    
    Set Olemail = Ol.CreateItem(0) 'olMailItem

    With Olemail
        .To = Maillist
        .CC = "your_hardcoded_email@example.com" ' 替换为实际抄送邮箱
        .Subject = "Overview - " & Format(Date, "yyyy-mm-dd") ' 格式化日期更规范
        
        ' 获取Word编辑器对象
        Set Olinsp = .GetInspector
        If Olinsp.EditorType = 4 Then 'olEditorWord
            Set Wd = Olinsp.WordEditor
        End If
        
        If Not Wd Is Nothing Then
            ' 插入问候语
            Wd.Paragraphs(1).Range.InsertBefore "Dear all," & Chr(10) & Chr(10)
            
            ' 添加提示语并设置超链接
            Dim linkTextRange As Object
            Set linkTextRange = Wd.Paragraphs.Add.Range
            linkTextRange.Text = "Please find below overview of today. Click this link to open the file" & Chr(10) & Chr(10)
            ' 定位"link"文本并插入超链接
            With linkTextRange.Find
                .Text = "link"
                .Execute
                If .Found Then
                    Wd.Hyperlinks.Add Anchor:=linkTextRange, Address:=ThisWorkbook.FullName, TextToDisplay:="link"
                End If
            End With
            
            ' 复制并粘贴Status区域截图
            Sheets("Status").Range("B2:W62").SpecialCells(xlCellTypeVisible).Copy
            Wd.Paragraphs.Add.Range.PasteAndFormat 13 'wdChartPicture
            
            ' 调整截图高度
            If Wd.InlineShapes.Count > 0 Then
                Wd.InlineShapes(1).Height = 800
            End If
        End If
        
        .Display ' 仅显示邮件，不发送
    End With

    Application.ScreenUpdating = True
End Sub

关键修改说明 #

• 超链接实现：通过Word对象模型的Hyperlinks.Add方法，先插入提示文本，再定位到"link"字样，将其设置为指向当前工作簿完整路径的超链接
• 收件人列表优化：调整了拼接逻辑，避免生成的收件人字符串开头出现多余的分号
• Outlook实例兼容：添加了On Error处理，确保如果Outlook未运行时能自动创建新实例
• 日期格式化：将主题中的日期改为yyyy-mm-dd格式，更清晰规范
• 抄送设置：补全了硬编码抄送邮箱的配置，替换注释中的邮箱即可使用
• 排版优化：调整了正文内容的插入顺序，确保问候语、超链接、截图依次排列，排版更合理

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