bdouglas1011
New Member
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.
Code:
'-----------------------------------------------------
'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 & "[URL="file://\\Morning"]\\Morning[/URL] 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 = "[EMAIL="brian.douglas@gyrodata.com"]brian.douglas@gyrodata.com[/EMAIL]"
.Cc = ""
TempFilePath = Environ$("temp") & "\"
.Attachments.Add TempFilePath & "MorningReport.jpg", olByValue, 0
.Attachments.Add ActiveWorkbook.FullName
.Attachments.Add MyPath & "[URL="file://\\Morning"]\\Morning[/URL] 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
