Can you explain to me why my signature dissapears ?

Hi all,

Would be great if you explain to me why my signature dissapears? And how can I get it back?

Sub send_email_with_attachments()

On Error Resume Next

Dim o As Outlook.Application
Set o = New Outlook.Application


Dim omail As Outlook.MailItem

Dim i As Long

For i = 2 To Range("a100").End(xlUp).Row

Set omail = o.CreateItem(olMailItem)

With omail

.Body = "Dear " & Cells(i, 1).Value & vbNewLine & vbNewLine _
& "Please update your file." & vbNewLine _
& "Please feel free to contact me if you need any clarification."
.To = Cells(i, 2).Value
.CC = Cells(i, 3).Value
.Subject = Cells(i, 4).Value
.Attachments.Add Cells(i, 5).Value

.Display

End With

Next

End Sub

It disappears because you have set the body of the message with your macro. The signature is part of the body.
Use instead the WordEditor inspector to edit the message body - see for example http://www.vbaexpress.com/forum/show...-on-cell-value

This is a macro I made awile ago to send Excel data via Outlook

It has signature code that you might find useful

It's most likely not perfect (:) )so if Graham has suggestions, I'll be glad to take them

Code:

---

'  ver 03  10/26/2018
'      added existance checks
'      made into function, True if successful
'  ver 02  10/25/2018
'      added sSignatures

Option Explicit
Option Private Module
Const olFormatHTML As Long = 2
Const olFormatPlain As Long = 1
Const olFormatRichText As Long = 3
Const olFormatUnspecified As Long = 0
Const olAppointmentItem As Long = 1
Const olContactItem As Long = 2
Const olDistributionListItem As Long = 7
Const olJournalItem As Long = 4
Const olMailItem As Long = 0
Const olNoteItem As Long = 5
Const olPostItem As Long = 6
Const olTaskItem As Long = 3
Const sDefaultSignature As String = "My Sig.htm"


Dim sSignatureFolder As String, sSignatureFile As String


'Signatures stored in  Environ("appdata") & "\Microsoft\Signatures\"
'If NO signature files, generate plain text email and plain text signature
'If 1 signature file, use the .HTM version as signature and generate HTML email
'if more than 1
'      use "My Sig.htm" if avaialble
'      otherwise generate plain text email and plain text signature
Function SendWithOutlook(emailRecipient As String, _
    emailMessage As String, _
        Optional emailSubject As String = vbNullString, _
            Optional emailAttachmentFile As String = vbNullString) As Boolean
   
    Dim oOutlook As Object
    Dim oMailItem As Object
    Dim sSignature As Variant
    Dim MailFormat As Long
    Dim sHtmlBody As String, sPlainBody As String
    On Error GoTo EmailError
    'see if attachment is there, raise error if not
    If Len(emailAttachmentFile) > 0 Then
        If Len(Dir(emailAttachmentFile)) = 0 Then Err.Raise vbObject + 1
    End If

    'see if Signature file is there, raise error if not
    sSignatureFolder = Environ("appdata") & "\Microsoft\Signatures\"
    If Len(Dir(sSignatureFolder)) = 0 Then Err.Raise vbObject + 2
    'get sSignature as text or the count number if not exactly 1
    sSignature = Sigs
   
    If IsNumeric(sSignature) Then
        If sSignature = 0 Then  '  no sSignatures
            MailFormat = olFormatPlain
           
        Else    'if more than one, does default exist (My Sig.htm)
            sSignatureFile = Dir(sSignatureFolder & sDefaultSignature)
            If Len(sSignatureFile) = 0 Then  '  if not, then plain text email
                MailFormat = olFormatPlain
                   
            Else
                MailFormat = olFormatHTML
            End If
        End If
       
    Else
        MailFormat = olFormatHTML
    End If
   
   
    'build signatures and format body as HTML or as Plain Text
    If MailFormat = olFormatHTML Then
        sSignature = CreateObject("Scripting.FileSystemObject").GetFile(sSignature).OpenAsTextStream(1, -2).readall
       
        sHtmlBody = emailMessage & "<hr>Sent " & FormatDateTime(Now, vbLongDate) & " at " & FormatDateTime(Now, vbLongTime) & "<hr><br>"
        sHtmlBody = Replace(sHtmlBody, "^", "<br>")
   
    Else
        sSignature = vbCrLf & vbCrLf & _
                    "--------------------------------------------------------------------------" & _
                    vbCrLf & vbCrLf & _
                    Application.UserName & _
                    vbCrLf & vbCrLf & _
                    "Sent " & FormatDateTime(Now, vbLongDate) & " at " & FormatDateTime(Now, vbLongTime)
        sPlainBody = Replace(emailMessage, "^", vbCrLf)
    End If

    'Set Outlook to current instance, opening if necessary
    Set oOutlook = GetObject(, "Outlook.Application")
   
    'create new mail item
    Set oMailItem = oOutlook.CreateItem(olMailItem)
    With oMailItem
        'Returns or sets a semicolon-delimited String list of display names for the To recipients for the Outlook item. Read/write.
        .To = emailRecipient
        .CC = vbNullString
        .BCC = vbNullString
        If Len(emailSubject) = 0 Then
            .Subject = ThisWorkbook.Name & " -- " & Format(Now, "General Date")
        Else
            .Subject = emailSubject
        End If
        If MailFormat = olFormatHTML Then
            .BodyFormat = MailFormat
            .HtmlBody = sHtmlBody & sSignature
       
        Else
            .BodyFormat = MailFormat
            .Body = sPlainBody & sSignature
        End If
        If Len(emailAttachmentFile) > 0 Then .Attachments.Add emailAttachmentFile
       
        .readreceiptrequested = False
        .Send
    End With
    On Error GoTo 0
    Set oMailItem = Nothing
    Set oOutlook = Nothing
   
    SendWithOutlook = True
    Exit Function
   
EmailError:
    If Err.Number = 429 Then
        Set oOutlook = CreateObject("Outlook.Application")
        Resume Next
    Else
        SendWithOutlook = False
        Set oMailItem = Nothing
        Set oOutlook = Nothing
    End If
 
 End Function

'if only one sSignature then return the path, if 0 or more than 1, return the count
 Function Sigs() As Variant
    Dim N As Long
    sSignatureFile = Dir(sSignatureFolder & "*.htm")
    Do While Len(sSignatureFile) > 0
        N = N + 1
        sSignatureFile = Dir
    Loop
    If N = 1 Then
        Sigs = sSignatureFolder & Dir(sSignatureFolder & "*.htm")
    Else
        Sigs = N
    End If
End Function

---

It's not a question of 'perfect' but whether it works, which is the aim of the game. Frankly it is easier to use the Outlook WordEditor Inspector and then treat the message as a Word document. The example I linked was an over complicated one, with different formatting requirements throughout but the principle is good and it starts by keeping the default signature without having to worry about adding it, or deleting it as with the OP's issue.

Quote:

---

Originally Posted by gmayor

It's not a question of 'perfect' but whether it works, which is the aim of the game. Frankly it is easier to use the Outlook WordEditor Inspector and then treat the message as a Word document. The example I linked was an over complicated one, with different formatting requirements throughout but the principle is good and it starts by keeping the default signature without having to worry about adding it, or deleting it as with the OP's issue.

---

Hi Graham,
What would you recommend since I am not native these WordEditor. I couldn't correct my code.

Based on your code, you would need something like the following - see the note at the top of the macro

Code:

---

Option Explicit

Sub SendWorkBook()
'Graham Mayor - https://www.gmayor.com - Last updated - 04 Jun 2019
'This macro requires the code from
'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to open Outlook

Dim oOutlookApp As Object
Dim oItem As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim i As Integer

Set oOutlookApp = OutlookApp()    'Use the function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
    'to open Outlook, or it will not work correctly
    For i = 2 To Range("a100").End(xlUp).Row
        'Create a new mailitem
        Set oItem = oOutlookApp.CreateItem(0)
        With oItem
            .Subject = Cells(i, 4).value
            .Attachments.Add Cells(i, 5).value
            .To = Cells(i, 2).value
            .CC = Cells(i, 3).value
            .BodyFormat = 2    'html
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor    'access the message body for editing
            Set oRng = wdDoc.Range
            oRng.Collapse 1    'set a range to the start of the message
            'enter the range text
            oRng.Text = "Dear " & Cells(i, 1).value & vbCr & vbCr _
                        & "Please update your file." & vbCr & vbCr _
                        & "Please feel free to contact me if you need any clarification."
            'display the message - this line is required even if you then add the command to send the message
            .Display
        End With
        DoEvents
    Next i
    'Clean up
    Set oItem = Nothing
    Set oOutlookApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
lbl_Exit:
    Exit Sub
End Sub

---