Deleting Signature In Outlook 2010 message generated via Excel VBA

Question

I have an Excel file where when the user presses a button:

1. A range is selected and copied to the clipboard

2. An Outlook message is created based on a template

3. E-mail will be sent "on behalf of" instead of the user's name/account

The user adds a date in the e-mail and pastes the copied range into the template.

This is all working but Outlook adds the user's signature and that is unwanted.

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

Currently there is no DeleteSig sub. It used to be inside With OutMail. I tested the example from the Microsoft site 1:1 but could not get it to work.

The code from Microsoft:

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

It opens a new e-mail message with signature and gives a compile error.

"User-defined type not defined".

It marks Sub DeleteSig(msg As Outlook.MailItem) in yellow and highlights objDoc As Word.Document in blue.

Answer 1

Hers is the complete working code which removes signature from the mail template.

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

Answer 2

So, this is the VBA code that is currently running. It selects the range, copies it to a blank e-mail, pastes it there and deletes the users' signature.

The "problem" is that it should open a new e-mail based on an existing template (.oft) and paste it where it reads "<insert table/overview>". The oft has an image header and some (html/formatted) text in it.

I'm startin to wonder if what I'm trying to accomplish is even possible.

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

This will remove the signature from an email template

The last Sub will place a selected range from Excel into the body of the template

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

If only one cell is selected and is empty, it will paste the first cell with data from ActiveSheet