Deleting Signature In Outlook 2010 message generat

Question

I've been trying and reading around but I can't find the solution for this problem. I have an excel file where when the user presses a button:

A) a range is selected and copied to the clipboard

B) A new outlook messages opens based on a template

C) E-mail will be sent "on behalf" off instead of the users' name/acount

The user then has to add a date in the e-mail and paste the copied range into a certain part of the template. This is all ok and working BUT!!! outlook automatically adds the users' signature to the end of the e-mail and that is unwanted.

This is the code I'm currently using:

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"" <[e-mail]>"
    .Display
End With

Application.ScreenUpdating = True
End Sub

Currently there is no deletesignature sub, because I couldn't get it to work. It used to be inside "with OutMail" but the sub itself did not work. I even tested the example from the Microsoft site 1:1 but still could not get it to work.

The code from Microsoft is as follows:

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-mailmessage (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.Documen" in blue. ... and that's where it loses me :(

Can someone here perhaps shed some light on this? It would be much appreciated.

Kind regards.

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