Consulting

Results 1 to 6 of 6

Thread: Can you explain to me why my signature dissapears ?

  1. #1

    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

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,600
    Location
    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


    '   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
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  4. #4
    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.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    Quote Originally Posted by gmayor View Post
    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.

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

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •