excel - 删除通过 Excel VBA 生成的 Outlook 2010 邮件中的签名

Question

我有一个 Excel 文件，当用户按下按钮时:

1. 选择一个范围并将其复制到剪贴板

2. 基于模板创建 Outlook 邮件

3. 电子邮件将“代表”而不是用户的姓名/帐户发送

用户在电子邮件中添加日期并将复制的范围粘贴到模板中。

这一切正常，但 Outlook 添加了用户的签名，这是不需要的。

Sub SelectArea()
    Application.ScreenUpdating = False
    
    lastCol = ActiveSheet.Range("a1").End(xlToRight).Column - 2
    lastRow = ActiveSheet.Cells(500, lastCol).End(xlUp).Row
    ActiveSheet.Range("a1", ActiveSheet.Cells(lastRow, lastCol)).Copy
    
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItemFromTemplate("\\network\path\to\the\MailTemplate.oft")
    
    With OutMail
        .SentOnBehalfOfName = """DepartmentX"" <<a href="https://stackoverflow.com/cdn-cgi/l/email-protection" class="__cf_email__" data-cfemail="82c6e7f2e3f0f6efe7ecf6dac2e1edeff2e3ecfbace1edef" rel="noreferrer noopener nofollow">[email protected]</a>>"
        .Display
    End With
    
    Application.ScreenUpdating = True
End Sub

目前没有 DeleteSig 子项。它曾经位于 With OutMail 内。我从 Microsoft 站点 1:1 测试了该示例，但无法使其工作。

来自微软的代码:

Sub TestDeleteSig()
    Dim objOL As Outlook.Application
    Dim objMsg As Outlook.MailItem
    Set objOL = CreateObject("Outlook.Application")
    Set objMsg = objOL.CreateItem(olMailItem)
    objMsg.Display
    Call DeleteSig(objMsg)
    Set objMsg = Nothing
End Sub

Sub DeleteSig(msg As Outlook.MailItem)
    Dim objDoc As Word.Document
    Dim objBkm As Word.Bookmark
    On Error Resume Next
    Set objDoc = msg.GetInspector.WordEditor
    Set objBkm = objDoc.Bookmarks("_MailAutoSig")
    If Not objBkm Is Nothing Then
        objBkm.Select
        objDoc.Windows(1).Selection.Delete
    End If
    Set objDoc = Nothing
    Set objBkm = Nothing
End Sub

它打开一封带有签名的新电子邮件并给出编译错误。

"User-defined type not defined".

它将 Sub DeleteSig(msg As Outlook.MailItem) 标记为黄色，并以蓝色突出显示 objDoc As Word.Document。

Answer 1

这将从电子邮件模板中删除签名

最后一个 Sub 会将 Excel 中选定的范围放入模板正文中

Option Explicit

Public Sub TestDeleteSig()
    Dim olApp As Object, olMsg As Object

    Set olApp = CreateObject("Outlook.Application")
    Set olMsg = olApp.CreateItem(0)
    olMsg.Display

    DeleteSig olMsg
    InsertRng olMsg

    Set olMsg = Nothing
End Sub

Private Sub DeleteSig(msg As Object)
    Dim wrdDoc As Object, wrdBkm As Object
    On Error Resume Next
    Set wrdDoc = msg.GetInspector.WordEditor
    Set wrdBkm = wrdDoc.Bookmarks("_MailAutoSig")
    If Not wrdBkm Is Nothing Then wrdBkm.Range.Delete
    Set wrdDoc = Nothing
    Set wrdBkm = Nothing
End Sub

Private Sub InsertRng(msg As Object)
    Dim rng As Range
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    If Not rng Is Nothing Then
        If rng.Rows.Count = 1 And rng.Columns.Count = 1 Then
            If Len(rng) = 0 Then Set rng = ActiveSheet.UsedRange.Cells(1)
        End If
        rng.Copy
        msg.GetInspector.WordEditor.Content.PasteSpecial xlPasteAll
        Application.CutCopyMode = False
    End If
End Sub

如果仅选择一个单元格并且为空，它将粘贴第一个单元格以及 ActiveSheet 中的数据