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

Question

我一直在尝试和阅读，但我找不到解决这个问题的方法。我有一个 excel 文件，当用户按下按钮时：

A) 选择一个范围并复制到剪贴板

B) 根据模板打开新的 Outlook 消息

C) 将发送电子邮件 "on behalf" 而不是用户 name/acount

然后用户必须在电子邮件中添加日期并将复制的范围粘贴到模板的特定部分。这一切都很好并且可以工作但是！ 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"" <DepartmentX@company.com>"
    .Display
End With

Application.ScreenUpdating = True
End Sub

目前没有 deletesignature sub，因为我无法让它工作。它曾经在 "with OutMail" 内，但 sub 本身不起作用。我什至测试了 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.Documen"。 ......这就是它失去我的地方:(

这里有人可以解释一下吗？将不胜感激。

亲切的问候。

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 中的数据粘贴第一个单元格

Answer 2

因此，这是当前运行的 VBA 代码。它选择范围，将其复制到空白 e-mail，将其粘贴到那里并删除用户的签名。

"problem" 是它应该根据 现有模板 (.oft) 打开一个新的 e-mail 并将其粘贴到它显示为“<插入 table/overview>”。通常有一张图片 header 和一些 (html/formatted) 文本。

我开始怀疑我正在尝试完成的事情是否有可能实现。

Sub DeleteSig()
   Dim olApp As Object, olMsg As Object
   Set olApp = CreateObject("Outlook.Application")
   Set olMsg = olApp.CreateItemFromTemplate("\myserver\my_template.oft")
   olMsg.Display
   DeleteSig_action olMsg
   InsertRng olMsg
   Set olMsg = Nothing
End Sub

Sub DeleteSig_action(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

Sub InsertRng(msg As Object)
   Dim rng As Range 
   lastCol = ActiveSheet.Range("a1").End(xlToRight).Column - 2
   lastRow = ActiveSheet.Cells(500, lastCol).End(xlUp).Row
   Set rng = ActiveSheet.Range("a1", ActiveSheet.Cells(lastRow, lastCol))
   rng.Copy        
   msg.GetInspector.WordEditor.Content.PasteSpecial xlPasteAll
   Application.CutCopyMode = False
End Sub

Answer 3

她的是从邮件模板中删除签名的完整工作代码。

Option Explicit

Sub openEmail()

Dim cfgFromEmail As String
Dim cfgNotice As String
Dim cfgTemplate As String
Dim appOutlook As Outlook.Application
Dim newEmail As Outlook.MailItem

Dim rownum As Integer
Dim colnum As Integer

rownum = 6

cfgFromEmail = Sheets("Email").Range("O5").Value
cfgNotice = Sheets("Email").Cells(rownum, 10) '10 = column J
cfgTemplate = Sheets("Email").Cells(rownum, 11) '11 = column K

Set appOutlook = CreateObject("Outlook.Application")
Set newEmail = appOutlook.CreateItemFromTemplate(ThisWorkbook.Path & "\" & cfgTemplate & ".oft")
'Set template = mailApp.CreateItem(olMailItem) 'Creates a blank email

If cfgNotice <> "null" Then 'If is not blank
    MsgBox cfgNotice, vbInformation, "Before you send the email"
End If


    Dim objDoc As Word.Document
    Dim objBkm As Word.Bookmark
    On Error Resume Next
    Set objDoc = newEmail.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

With newEmail
    .SentOnBehalfOfName = cfgFromEmail
    .Display 'Show the email


End With

Set newEmail = Nothing
Set appOutlook = Nothing

End Sub

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

Deleting Signature In Outlook 2010 message generated via Excel VBA macro

excel

email

outlook

signature

vba