sspatriots
Well-known Member
- Joined
- Nov 22, 2011
- Messages
- 585
- Office Version
- 365
- Platform
- Windows
This puts screenshot of userform and some text in an Outlook e-mail. How do I get the screenshot to appear below the body text? I've been messing with this for a couple hours and cannot get the screenshot to follow the HTMLBody text. Any suggestions greatly appreciated. Thank you, SS
VBA Code:
Sub EmailWithPicture()
Dim doc As Word.Document
Dim shp As Word.InlineShape
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strName As String
Dim strFile As String
Dim strPathFile As String
Dim EmailSubject As String, sign As String
Dim Email_To As String, Email_CC As String, Email_BCC As String, Email_Body As String
Dim result As Integer
Dim i As Integer
Dim OutApp As Object
Dim OutMail As Object
Dim Strbody As String
Dim myFldr As String
Dim myFile As String
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Worksheets("Quick Search Job Status").Activate
Sheets("Quick Search Job Status").Range("B13").Value = Sheets("Quick Search Job Status").Range("B3").Value 'ADDED, SPS, 07/05/22
'create default name for .pdf file
myFldr = "G:\PROJECTS\Job List\"
myFile = Dir(myFldr & strFile)
strName = "Job Status For - " & wsA.Range("B13").Value '_
strFile = strName & ".pdf"
strPathFile = myFldr & strFile
' *****************************************************
' ***** You Can Change These Variables *********
EmailSubject = "Job Status For - " & wsA.Range("B13").Value 'Change this to change the subject of the email. The current month is added to end of subj line"
OpenPDFAfterCreating = False 'Change this if you want to open the PDF after creating it : TRUE or FALSE
AlwaysOverwritePDF = False 'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE
DisplayEmail = True 'Change this if you don't want to display the email before sending. Note, you must have a TO email address specified for this to work
Email_To = "" 'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
Email_CC = ""
Email_BCC = ""
'Email_Body = "Please process the attached order and send the following to my attention:<BR/><BR/><li>Order acknowledgement</li><BR/><li>Any approval drawings</li><BR/><li>Estimated completion date and/or lead time after receipt of all approval data</li><BR/><li>Any questions or correspondence regarding this order</li><BR/><li>Shipping information</li><BR/><li>Tracking information<BR/><BR/>Thank you!" & sign
' ******************************************************
OutMail.Display
sign = OutMail.HTMLBody
'Display email and specify To, Subject, etc
With OutMail
.Display
.To = Email_To
.CC = Email_CC
.BCC = Email_BCC
.Subject = EmailSubject '& CurrentMonth
.Body = Email_Body
'.HTMLBody = Email_Body
.HTMLBody = "<BODY style='font-family:Calibri;font-size:15'>" & "Hello," & _
"<BR/><BR/>The current status for the subject job is attached hereto. Please let me know if you have any questions." & _
"<BR/><BR/><BR/><BR/><BR/>" & "Thank you!" & "</BODY>" & sign
If DisplayEmail = False Then
.Send
End If
Set doc = OutMail.GetInspector.WordEditor
Set shp = doc.Range(0, 0).InlineShapes.AddPicture("G:\PROJECTS\Job List\\Test.jpg")
shp.LockAspectRatio = msoTrue
shp.Width = 600
shp.Glow.Color.RGB = RGB(255, 0, 0)
shp.Glow.Radius = 10
shp.Glow.Transparency = 0.5
'shp.Reflection.Type = msoReflectionType3
shp.Borders.OutsideLineStyle = wdLineStyleDashDot
shp.Borders.OutsideLineWidth = wdLineWidth225pt
Kill "G:\PROJECTS\Job List\Test.jpg"
End With
Sheets("Quick Search Job Status").Range("B13").Value = ""
End Sub
