Email signature disappears when clipboard contents are added

[jmcconnell]

Hi all, I'm new to the world of VBA so forgive me if this is the wrong place to post.

I've got a button within an Excel sheet that basically generates an email with some text in the body and the contents of the clipboard (this is always from using the snipping tool). I just can't seem to get the picture to display below the first couple of lines of text within the email and also, my signature always disappears:

Private Sub Alta1_Click()


Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object


    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
    On Error Resume Next
    
    Set OutMail = OutApp.CreateItem(0)
      
    With OutMail
        .BodyFormat = 2
        .Display
        .To = ""
        .CC = ""
        .Subject = "Altahullion 1 fault"
    If Time < TimeValue("12:00:00") Then
            .Body = "Good Morning," & vbNewLine & vbNewLine & _
                        "Please see the fault below:"
    ElseIf Time > TimeValue("12:00:00") And Time < TimeValue("17:00:00") Then
            .Body = "Good Afternoon," & vbNewLine & vbNewLine & _
                        "Please see the fault below:"
    Else
            .Body = "Good Evening," & vbNewLine & vbNewLine & _
                        "Please see the fault below:"


    End If
            
                  On Error Resume Next
        
        
        
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        
        oRng.collapse 0
        oRng.Paste
        
    End With

Any help would be much appreciated.
Thanks,
James

 

[ZVI]

Hi, try this modification of your code:

Private Sub Alta1_Click()
 
  Dim OutApp As Object
  Dim sBody As String, sSignature As String
 
  On Error Resume Next
  Set OutApp = GetObject(, "Outlook.Application")
  If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
  On Error GoTo 0
 
  With OutApp.CreateItem(0)
    .BodyFormat = 2
    .Display
    sSignature = .HtmlBody
    .To = ""
    .CC = ""
    .Subject = "Altahullion 1 fault"
    If Time < TimeValue("12:00:00") Then
      sBody = "Good Morning,"
    ElseIf Time > TimeValue("12:00:00") And Time < TimeValue("17:00:00") Then
      sBody = "Good Afternoon,"
    Else
      sBody = "Good Evening,"
    End If
    sBody = sBody & vbLf & vbLf & "Please see the fault below:"
    .HtmlBody = Replace(sBody, vbLf, "<" & "br" & ">")
   
    'On Error Resume Next
    With .GetInspector.WordEditor.Range.Paragraphs.Add.Range
      .Collapse 0
      .Paste
    End With
   
    .HtmlBody = .HtmlBody & sSignature
   
  End With
 
End Sub

Regards