如何在Outlook默认邮件签名上方粘贴内容？

原代码会将Excel单元格内容粘贴到Outlook新邮件的默认签名下方，以下是修改后的代码，可将内容粘贴至签名上方的正文起始位置：

Private Sub CommandButton1_Click()

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 rCol As Collection, r As Range, i As Integer
Dim targetRange As Object 'Word.Range

' 尝试获取已运行的Outlook实例，不存在则新建
Set ol = GetObject(Class:="Outlook.Application")
If ol Is Nothing Then
    Set ol = CreateObject(Class:="Outlook.Application")
End If

Set olEmail = ol.CreateItem(0) 'olMailItem

Set rCol = New Collection 
With rCol 
    .Add Sheet1.Range("B6:C23") ' 按顺序添加需要复制的单元格区域
End With

With olEmail 
    .To = "email@domain.com" 
    .CC = "anotheremail@domain.com" 
    .Subject = "Useful subject" 
    ' 先显示邮件，确保默认签名加载完成
    .Display
    Set olInsp = .GetInspector 
    If olInsp.EditorType = 4 Then ' 确认使用Word作为邮件编辑器
        Set wd = olInsp.WordEditor 
        ' 定位到文档起始位置，作为内容插入的目标区域
        Set targetRange = wd.Range(Start:=0, End:=0)
        For i = 1 To rCol.Count ' 遍历所有需要复制的区域
            Set r = rCol.Item(i)
            r.Copy 
            ' 在目标位置粘贴并保留原格式
            targetRange.PasteAndFormat 16 ' 16对应wdFormatOriginalFormatting
            ' 将目标区域移至刚粘贴内容的末尾，方便追加后续内容
            Set targetRange = wd.Range(Start:=targetRange.End, End:=targetRange.End)
            ' 插入段落分隔，优化排版
            targetRange.InsertParagraphAfter
            Set targetRange = wd.Range(Start:=targetRange.End, End:=targetRange.End)
        Next 
    End If 
End With

End Sub

关键修改说明： #

• 提前加载签名：先调用.Display显示邮件，确保Outlook自动插入默认签名到正文末尾，后续操作的Word文档包含完整的邮件结构。
• 定位起始位置：使用wd.Range(Start:=0, End:=0)定位到文档最开头，保证内容插入在签名上方。
• 动态更新目标范围：每次粘贴后更新targetRange到当前内容末尾，确保多个区域按顺序粘贴且排版清晰。
• 健壮性优化：增加了Outlook实例不存在时的创建逻辑，避免因Outlook未运行导致代码报错。

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