How to insert default Signature in Code

**bdouglas1011** · 08-14-2014, 03:39 PM

I have the macro changing excel to image then showing in body & attaching files to outlook. How would I insert the default Signature into this automatically.

'-----------------------------------------------------
'Looks to see if Outlook is open and If not open it
'--------------------------------------------------------

#Const LateBind = True

Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6

#If LateBind Then

Public Function OutlookApp( _
    Optional WindowState As Long = olMinimized, _
    Optional ReleaseIt As Boolean = False _
    ) As Object
    Static o As Object
#Else
Public Function OutlookApp( _
    Optional WindowState As Outlook.OlWindowState = olMinimized, _
    Optional ReleaseIt As Boolean _
) As Outlook.Application
    Static o As Outlook.Application
#End If
On Error GoTo ErrHandler
 
    Select Case True
        Case o Is Nothing, Len(o.Name) = 0
            Set o = GetObject(, "Outlook.Application")
            If o.Explorers.Count = 0 Then
InitOutlook:
                o.Session.GetDefaultFolder(olFolderInbox).Display
                o.ActiveExplorer.WindowState = WindowState
            End If
        Case ReleaseIt
            Set o = Nothing
    End Select
    Set OutlookApp = o
 
ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case -2147352567
            Set o = Nothing
        Case 429, 462
            Set o = GetOutlookApp()
            If o Is Nothing Then
                Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
            Else
                Resume InitOutlook
            End If
        Case Else
            MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
    End Select
    Resume ExitProc
    Resume
End Function

#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
On Error GoTo ErrHandler
    
    Set GetOutlookApp = CreateObject("Outlook.Application")
    
ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case Else
            Set GetOutlookApp = Nothing
    End Select
    Resume ExitProc
    Resume
End Function

Sub sendMail()
        
        '--------------------------------------------------
        'Save morning report document in job folder As PDF
        '--------------------------------------------------
        Dim MyPath As String
        MyPath = ActiveWorkbook.Path & "\Morning Reports\"
        ChDir MyPath
            Sheets("Morning Report").Range("A1:k46").ExportAsFixedFormat Type:=xlTypePDF, FileName:=MyPath & "\\Morning Report" & "_" & Format(Now(), "mm.dd.yy") & ".PDF", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
        
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
     
        Dim TempFilePath As String
         
        
        
         
        'Create a new Microsoft Outlook session
        Set appOutlook = CreateObject("outlook.application")
        'create a new message
        Set Message = appOutlook.CreateItem(olMailItem)
           
            
        '****************************************************************
        'Message to confirm ready to email
        '****************************************************************
        RetVal = MsgBox("ARE YOU SURE EVERYTHING IS CORRECT AND COMPLETED?", vbYesNoCancel, "Confirm")
        Select Case RetVal
        Case vbYes
        Case vbNo
        Exit Sub
        Case vbCancel
        Exit Sub
        End Select
        '**********************************************
           
       
         
         
        With Message
        
         
        
            .Subject = Range("c5") & " - " & Range("c6") & " - " & Range("c7") & " - " & Range("c8") & " County, " & Range("c9") & " - " & Range("c10") & " - " & " Morning Report "
     
            
            'first we create the image as a JPG file
            Call createJpg("Morning Report", "A1:k46", "MorningReport")
            
          
            
                
            'Then we add an html <img src=''> link to this image
            'Note than you can customize width and height - not mandatory
                
            .htmlbody = "<img src='cid:MorningReport.jpg'" & "width='700' height='1100'><br>"
             
            .To = "brian.douglas@gyrodata.com"
            .Cc = ""
            
            
            TempFilePath = Environ$("temp") & "\"
            .Attachments.Add TempFilePath & "MorningReport.jpg", olByValue, 0
            .Attachments.Add ActiveWorkbook.FullName
            .Attachments.Add MyPath & "\\Morning Report" & "_" & Format(Now(), "mm.dd.yy") & ".PDF"
            
            
            
             
            .Display
            
        End With
     
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
        
    End Sub
    
    
    Sub createJpg(MorningReport As String, nameRange As String, nameFile As String)
    
    ActiveSheet.Unprotect Password:="Financial3"
    
    ThisWorkbook.Activate
       Worksheets("Morning Report").Activate
    Dim plage As Range
    Set plage = ThisWorkbook.Worksheets("Morning Report").Range("A1:k46")
    plage.CopyPicture
    With ThisWorkbook.Worksheets("Morning Report").ChartObjects.Add(plage.Left, plage.Top, plage.Width, plage.Height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    Worksheets("Morning Report").ChartObjects(Worksheets("Morning Report").ChartObjects.Count).Delete
Set plage = Nothing



            
'----------------------------------------------------
'Protect Sheet when done
'---------------------------------------------------
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="Financial3"
End Sub

I changed the code but now it shows default signature but the image does not come through is says the file may have been moved, renamed or deleted.

'-----------------------------------------------------
'Looks to see if Outlook is open and If not open it
'--------------------------------------------------------

#Const LateBind = True

Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6

#If LateBind Then

Public Function OutlookApp( _
    Optional WindowState As Long = olMinimized, _
    Optional ReleaseIt As Boolean = False _
    ) As Object
    Static o As Object
#Else
Public Function OutlookApp( _
    Optional WindowState As Outlook.OlWindowState = olMinimized, _
    Optional ReleaseIt As Boolean _
) As Outlook.Application
    Static o As Outlook.Application
#End If
On Error GoTo ErrHandler
 
    Select Case True
        Case o Is Nothing, Len(o.Name) = 0
            Set o = GetObject(, "Outlook.Application")
            If o.Explorers.Count = 0 Then
InitOutlook:
                o.Session.GetDefaultFolder(olFolderInbox).Display
                o.ActiveExplorer.WindowState = WindowState
            End If
        Case ReleaseIt
            Set o = Nothing
    End Select
    Set OutlookApp = o
 
ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case -2147352567
            Set o = Nothing
        Case 429, 462
            Set o = GetOutlookApp()
            If o Is Nothing Then
                Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
            Else
                Resume InitOutlook
            End If
        Case Else
            MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
    End Select
    Resume ExitProc
    Resume
End Function

#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
On Error GoTo ErrHandler
    
    Set GetOutlookApp = CreateObject("Outlook.Application")
    
ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case Else
            Set GetOutlookApp = Nothing
    End Select
    Resume ExitProc
    Resume
End Function

Sub sendMail()
        
        '--------------------------------------------------
        'Save morning report document in job folder As PDF
        '--------------------------------------------------
        Dim MyPath As String
        MyPath = ActiveWorkbook.Path & "\Morning Reports\"
        ChDir MyPath
            Sheets("Morning Report").Range("A1:k46").ExportAsFixedFormat Type:=xlTypePDF, FileName:=MyPath & "\\Morning Report" & "_" & Format(Now(), "mm.dd.yy") & ".PDF", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
        
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
     
        Dim TempFilePath As String
         
        Dim appOutlook As Object, Message As Object, signature As String
        
         
        'Create a new Microsoft Outlook session
        Set appOutlook = CreateObject("outlook.application")
        'create a new message
        Set Message = appOutlook.CreateItem(olMailItem)
           
            
        '****************************************************************
        'Message to confirm ready to email
        '****************************************************************
        RetVal = MsgBox("ARE YOU SURE EVERYTHING IS CORRECT AND COMPLETED?", vbYesNoCancel, "Confirm")
        Select Case RetVal
        Case vbYes
        Case vbNo
        Exit Sub
        Case vbCancel
        Exit Sub
        End Select
        '*********************************************
         
        'Dim OApp As Object, OMail As Object, signature As String
        'Set OApp = CreateObject("Outlook.Application")
        'Set OMail = OApp.CreateItem(0)
        'With Message
        '.Display
        'End With
        'signature = Message.htmlbody
         
         
         
         
            'With Message
              
            '.Display
            'End With
            'signature = Message.htmlbody
              
            'first we create the image as a JPG file
            Call createJpg("Morning Report", "A1:k46", "MorningReport")
          
            'Then we add an html <img src=''> link to this image
            'Note than you can customize width and height - not mandatory
              
            
              
            With Message
            
            .To = "brian.douglas@gyrodata.com"
            .Cc = ""
            .Subject = Range("c5") & " - " & Range("c6") & " - " & Range("c7") & " - " & Range("c8") & " County, " & Range("c9") & " - " & Range("c10") & " - " & " Morning Report "
            
            With Message
              
            .Display
            End With
            signature = Message.htmlbody
                        
            .htmlbody = "<img src='cid:MorningReport.jpg'" & "width='700' height='1100'><br>" & vbNewLine & signature
            
            TempFilePath = Environ$("temp") & "\"
            .Attachments.Add TempFilePath & "MorningReport.jpg", olByValue, 0
            .Attachments.Add ActiveWorkbook.FullName
            .Attachments.Add MyPath & "\\Morning Report" & "_" & Format(Now(), "mm.dd.yy") & ".PDF"
            ThisWorkbook.Save
            .Display
         
        End With
        
        Set Message = Nothing
        Set appOutlook = Nothing
     
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
        
    End Sub
    
    
    Sub createJpg(MorningReport As String, nameRange As String, nameFile As String)
    
    ActiveSheet.Unprotect Password:="Financial3"
    
    ThisWorkbook.Activate
    Worksheets("Morning Report").Activate
    Dim plage As Range
    Set plage = ThisWorkbook.Worksheets("Morning Report").Range("A1:k46")
    plage.CopyPicture
    With ThisWorkbook.Worksheets("Morning Report").ChartObjects.Add(plage.Left, plage.Top, plage.Width, plage.Height)
    .Activate
    .Chart.Paste
    .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    Worksheets("Morning Report").ChartObjects(Worksheets("Morning Report").ChartObjects.Count).Delete
    Set plage = Nothing



            
'----------------------------------------------------
'Protect Sheet when done
'---------------------------------------------------
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="Financial3"
End Sub