I am trying to add an image from an Excel sheet to an Outlook email.
I tried using a link to an image stored in a network location and on the Internet. However, not all users will have access to these locations.
Is it possible to store the image in another worksheet and then copy it into the email body?
I know the below won't work because you can't export shapes but can I do something like this?
ActiveUser = Environ$("UserName")
TempFilePath = "C:\Users\" & ActiveUser & "\Desktop\"
Sheets("Images").Shapes("PanelComparison").Export TempFilePath & "\PanelComparison.png"
panelimage = "<img src = ""TempFilePath\PanelComparison.png"" width=1000 height=720 border=0>"
The CreateEmail Sub calls the SaveToImage Sub. The SaveToImage sub grabs a range, creates a chart on a new page and then saves the picture(objChart) to a specified directory.
The LMpic string variable calls the image just saved and inputs it into the HTML body.
Public Sub CreateEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim FN, LN, EmBody, EmBody1, EmBody2, EmBody3 As String
Dim wb As Workbook
Dim ws As Worksheet
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set wb = ActiveWorkbook
Set ws = Worksheets("Sheet1")
Call SaveToImage
ws.Activate
LMpic = wb.Path & "\ClarityEmailPic.jpg'"
On Error GoTo cleanup
For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
FN = Cells(cell.Row, "B").Value
LN = Cells(cell.Row, "A").Value
EmBody = Range("Email_Body").Value
EmBody1 = Range("Email_Body1").Value
EmBody2 = Range("Email_Body2").Value
'EmBody3 = Range("Email_Body3").Value
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Volt Clarity Reminder "
.Importance = olImportanceHigh
.HTMLBody = "<html><br><br><br>" & _
"<table border width=300 align=center>" & _
"<tr bgcolor=#FFFFFF>" & _
"<td align=right>" & _
"<img src='" & objRange & "'>" & _
"</td>" & _
"</tr>" & _
"<tr border=0.5 height=7 bgcolor=#102561><td colspan=2></td></tr>" & _
"<tr>" & _
"<td colspan=2 bgcolor=#E6E6E6>" & _
"<body style=font-family:Arial style=backgroung-color:#FFFFFF align=center>" & _
"<p> Dear " & FN & " " & LN & "," & "</p>" & _
"<p>" & EmBody & "</p>" & _
"<p>" & EmBody2 & "<i><font color=red>" & EmBody1 & "</i></font>" & "</p>" & _
"</body></td></tr></table></html>"
.Display 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Public Sub SaveToImage()
'
' SaveToImage Macro
'
Dim DataObj As Shape
Dim objChart As Chart
Dim folderpath As String
Dim picname As String
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = Worksheets("Sheet2")
folderpath = Application.ActiveWorkbook.Path & Application.PathSeparator 'locating & assigning current folder path
picname = "ClarityEmailPic.jpg" 'image file name
Application.ScreenUpdating = False
Call ws.Range("Picture").CopyPicture(xlScreen, xlPicture) 'copying the range as an image
Worksheets.Add(after:=Worksheets(1)).Name = "Sheet4" 'creating a new sheet to insert the chart
ActiveSheet.Shapes.AddChart.Select
Set objChart = ActiveChart
ActiveSheet.Shapes.Item(1).Width = ws.Range("Picture").Width 'making chart size match image range size
ActiveSheet.Shapes.Item(1).Height = ws.Range("Picture").Height
objChart.Paste 'pasting the range to the chart
objChart.Export (folderpath & picname) 'creating an image file with the activechart
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete 'deleting sheet4
Application.DisplayAlerts = True
End Sub
In general email images are stored on a web server, with the SRC pointing to that server (http://...). They're not embedded in the email itself.
Related
Thank you for taking the time to try and help me with this project.
I have some vba that sends an email to each recipient on my spreadsheet and includes in the body of the text information from the spreadsheet. This piece of the code works great. Here's the part where I am stuck...
The workbook contains a couple tables that I would like to filter and copy/paste into each email BUT the data from each table needs to be filtered to the data that applies to each recipient.
For example:
The email is being sent to a Regional leader and includes scores for their Region overall.
I have 1 table that includes manager scores which can be filtered by Region and
on a second tab, I have a table for each Region that drills down the scores by type of service.
So for the SouthWest Regional leader, I would like to Filter table 1 to only show managers in the SouthWest Region, copy/paste that table directly into the email and then go to the Service Type tables and copy the SouthWest table and paste into the email.
The final piece I would like to accomplish is to copy the employee level details which reside on a separate tab, to a workbook and attach it to the email. This too would need to be specific to employees within each region.
I don't know if this is possible within my code or if there is a smart way to accomplish it. I appreciate any help or insight you are willing to give! I have attached an example file and below is the email code I am currently using. I also have some code that filters the data based on the region that may or may not be helpful.
Sub SendMailtoRFE()
Dim outapp As New Outlook.Application
Dim outmail As Outlook.Mailitem
Dim wks As Worksheet
Dim i As Integer
Dim sFile1 As String
Dim TempFilePath As String
Environ ("UserProfile")
Set outapp = CreateObject("outlook.application")
sFile1 = "Infographic"
TempFilePath = Environ$("temp") & "Roadside Assistance " 'FIND OUT HOW TO CLEAN UP THE NAME: "Temp" added to file name
ActiveWorkbook.Sheets(sFile1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFilePath & sFile1 & ".pdf"
On Error Resume Next
For i = 3 To wks.Range("A" & Rows.Count).End(xlUp).Row
Set outmail = outapp.CreateItem(olMailItem)
With outmail
.To = wks.Range("C" & i).Value
.Subject = wks.Range("A" & i).Value & " Region Roadside Assistance YTD Communication"
.HTMLBody = "Dear " & wks.Range("C" & i).Value & "," & "<br></br>" & _
"You've shared how important Roadside Assistance is for your personal auto clients. As one of the highest frequency types of losses, success or failure " & _
"here may be seen as a signal of the overall value of the program." & "<br></br><br></br>" & _
"Here are the results for clients in your area who completed a survey. Year to date, the NPS was " & FormatPercent(wks.Range("K" & i).Value, 0) & _
" based on " & wks.Range("H" & i).Value & " total responses." & _
" The overall score for all regions is " & FormatPercent(wks.Range("K12").Value, 0) & "." & "<br></br><br></br>" & _
"Below are a few additional details to help you understand your region's score. " & _
"Please follow up with any questions or concerns." & "<br></br><br></br>" & vbNewLine & _
"**Please note, the table containing MLGA scores shows only the MLGA's where 5 or more survey responses were received.**"
.Attachments.Add (TempFilePath & sFile1 & ".pdf")
.display
End With
On Error GoTo 0
Set outmail = Nothing
Next i
Set outapp = Nothing
End Sub
''Filter Region on the MLGA Tow NPS Score Tab
Sub FilterSouthWest()
Dim wks As Worksheet
Set wks = Sheets("MLGA TOW NPS Score")
With wks.Range("A2:C2")
.AutoFilter Field:=3, Criteria1:="9A"
End With
End Sub
Use .SpecialCells(xlCellTypeVisible) to set the range on the filtered table and copy/paste them into the email using WordEditor. To insert the html text create a temporary file and use .InsertFile, This converts the html formatting into word formatting. You may need to add a wait between the copy/paste action depending on the amount of data.
Option Explicit
Sub SendMailtoRFE()
'sheet names
Const PDF = "Infographic" ' attachment
Const WS_S = "MLGA TOW NPS Score" ' filtered score data
Const WS_R = "Regions" ' names and emails
Const WS_T = "Tables" ' Regions Tables
Dim ws As Worksheet, sPath As String, sPDFname As String
Dim lastrow As Long, i As Long, n As Long
' region code for filter
Dim dictRegions As Object, region
Set dictRegions = CreateObject("Scripting.Dictionary")
With dictRegions
.Add "NorthEast", "6A"
.Add "NorthWest", "7A"
.Add "SouthEast", "8A"
.Add "SouthWest", "9A"
End With
sPath = Environ$("temp") & "\"
sPDFname = sPath & "Roadside Assistance " & PDF & ".pdf"
Sheets(PDF).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPDFname
Dim outapp As Outlook.Application
Dim outmail As Outlook.Mailitem
Dim outInsp As Object, oWordDoc
Dim wsRegion As Worksheet
Dim sRegion As String, sEmailAddr As String, rngScore As Range
Dim Table1 As Range, Table2 As Range, tmpHTML As String
' scores
With Sheets(WS_S)
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rngScore = .Range("A2:G" & lastrow) ' 5 columns
End With
' open outlook
Set outapp = New Outlook.Application
' regions
Set wsRegion = Sheets(WS_R)
lastrow = wsRegion.Cells(wsRegion.Rows.Count, "A").End(xlUp).Row
For i = 3 To lastrow '
sRegion = wsRegion.Range("A" & i).Value
sEmailAddr = wsRegion.Range("C" & i).Value
tmpHTML = HTMLFile(wsRegion, i)
' region
With rngScore
.AutoFilter
.AutoFilter Field:=3, Criteria1:=dictRegions(sRegion) ' filter col C
Set Table1 = .SpecialCells(xlCellTypeVisible)
End With
' Service Type Table
Set Table2 = Sheets(WS_T).ListObjects(sRegion).Range ' Table named same as region
'Debug.Print dictRegions(sRegion), sRegion, Table1.Address, Table2.Address
Set outmail = outapp.CreateItem(olMailItem)
n = n + 1
With outmail
.To = sEmailAddr
.Subject = sRegion & " Region Roadside Assistance YTD Communication"
.Attachments.Add sPDFname
.display
End With
Set outInsp = outmail.GetInspector
Set oWordDoc = outInsp.WordEditor
'Wait 1
With oWordDoc
.Content.Delete
.Paragraphs.Add.Range.InsertFile tmpHTML, Link:=False, Attachment:=False
Table1.Copy
.Paragraphs.Add.Range.Paste
.Paragraphs.Add.Range.Text = vbCrLf ' blank line
'Wait 1
Table2.Copy
.Paragraphs.Add.Range.Paste
'Wait 1
End With
Application.CutCopyMode = False
Set oWordDoc = Nothing
Set outInsp = Nothing
Set outmail = Nothing
' delete temp html file
On Error Resume Next
Kill tmpHTML
On Error GoTo 0
'Wait 1
Next
' end
Sheets(WS_S).AutoFilterMode = False
Set outapp = Nothing
AppActivate Application.Caption ' back to excel
MsgBox n & " Emails created", vbInformation
End Sub
Function HTMLFile(ws As Worksheet, i As Long) As String
Const CSS = "p{font:14px Verdana};h1{font:14px Verdana Bold};"
' template
Dim s As String
s = "<html><style>" & CSS & "</style><h1>Dear #NAME#,</h1>" & _
"<p>You've shared how important Roadside Assistance is for your personal auto clients.<br/>" & vbLf & _
"As one of the highest frequency types of losses, success or failure " & vbLf & _
"here may be seen as a signal of the overall value of the program.</p>" & vbLf & _
"<p>Here are the results for clients in your area who completed a survey.</p> " & vbLf & _
"<li>Year to date, the NPS was <b>#NPS_YTD#</b> " & vbLf & _
"based on <b>#RESPONSES#</b> total responses.</li> " & vbLf & _
"<li>The overall score for all regions is <b>#NPS_ALL#</b>,</li>" & vbLf & _
"<p>Below are a few additional details to help you understand your region's score. " & vbLf & _
"Please follow up with any questions or concerns." & "</p>" & vbNewLine & vbLf & _
"<p><i>**Please note, the table containing MLGA scores shows only the MLGA's where 5 " & vbLf & _
"or more survey responses were received.**</i></p></html>"
s = Replace(s, "#NAME#", ws.Cells(i, "C"))
s = Replace(s, "#NPS_YTD#", FormatPercent(ws.Cells(i, "K"), 0))
s = Replace(s, "#RESPONSES#", ws.Cells(i, "H"))
s = Replace(s, "#NPS_ALL#", FormatPercent(ws.Cells(12, "K"), 0))
Dim ff: ff = FreeFile
HTMLFile = Environ$("temp") & "\" & Format(Now(), "~yyyymmddhhmmss") & ".htm"
Open HTMLFile For Output As #ff
Print #ff, s
Close #ff
End Function
Sub Wait(n As Long)
Dim t As Date
t = DateAdd("s", n, Now())
Do While Now() < t
DoEvents
Loop
End Sub
I'm trying to use a variable to insert an image in an e-mail.
With OutlookItm
.To = strTo
.CC = strCc
.Subject = strSubject
.HTMLBody = "Hello all, <p>In attach the <b>Filtered Trunk Report</b> and below the <b>Invoice Volume chart</b>:</p>" & _
"<center><img src = Filename:ChartFile1 ></center>" & "<p>.</p>" & _
"<center><img src = 'C:\Users\matuo\OneDrive\Desktop\Chart2.jpg'></center>" & Signature
.Display
End With
The code works for "Chart2.jpg", but I want to use a variable for the directory and file.
The picture using the variable doesn't work.
Let's image you have got a string object pathToImage which contains the image path, in that case the code may look like:
With OutlookItm
.To = strTo
.CC = strCc
.Subject = strSubject
.HTMLBody = "Hello all, <p>In attach the <b>Filtered Trunk Report</b> and below the <b>Invoice Volume chart</b>:</p>" & _
"<center><img src = " & pathToImage & " ></center>" & "<p>.</p>" & _
"<center><img src = 'C:\Users\matuo\OneDrive\Desktop\Chart2.jpg'></center>" & Signature
.Display
End With
However, a local path to image is not really a good idea. Such images will not be displayed on the recipient side because the image itself is stored on your machine. Most probably you'd need to embed an image to the email itself. To get that done you need to attach the image file and set several properties - they are actually optional, even the following code works fine:
.Attachments.Add "C:\Users\JoeSchmo\Pictures\imageName.jpg", olByValue, 0
.HTMLBody = "<BODY><IMG src=""cid:imageName.jpg"" width=200> </BODY>"
But ideally you'd need to set the PR_ATTACH_CONTENT_ID and PR_ATTACHMENT_HIDDEN properties. For example:
Function SendasAttachment(fName As String)
Dim olApp As Outlook.Application
Dim olMsg As Outlook.MailItem
Dim olAtt As Outlook.Attachments
Set olApp = Outlook.Application
Set olMsg = olApp.CreateItem(0) ' email
Set olAtt = olMsg.Attachments
Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
' attach file
olAtt.Add (fldName & fName)
Set l_Attach = olAtt.Add(fldName & fName)
Set oPA = l_Attach.PropertyAccessor
oPA.SetProperty PR_ATTACH_MIME_TAG, "image/jpeg"
oPA.SetProperty PR_ATTACH_CONTENT_ID, "myident"
oPA.SetProperty PR_ATTACHMENT_HIDDEN, True
olMsg.PropertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/id/{00062008-0000-0000-C000-000000000046}/8514000B", True
olMsg.To = "test#email.com"
msgHTMLBody = "<HTML>" & _
"<head>" & _
"</head>" & _
"<BODY>" & "Hi " & olMsg.To & ", <br /><br /> I have attached " & fName & " as you requested." & _
"<br /><img align=baseline border=1 hspace=0 src=cid:myident width='400'/>" & _
"</BODY></HTML>"
' send message
With olMsg
.Subject = "Here's that file you wanted"
.BodyFormat = olFormatHTML
.HTMLBody = msgHTMLBody
.Save
'.Display
.Send
End With
End Function
Read more about that in the Embed Images in New Messages using a Macro article.
I have an MS Access report that contains records of clients from one table (including the email address) and linked grouped records from other tables fetched by a Query.
I want to send the content of the report to each client separately in the body of the email (not as an attachment), I am able to get the text put in the body of the email but without the formatting and without the picture in the header.
I used the following code which runs behind a click of a button. I would appreciate if anyone can help with the formatting issue AND if there is a way I can automate sending the emails for my 200+ clients without clicking the button each time (like a loop or something):
Private Sub Command70_Click()
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim appOutlook As Outlook.Application
Dim MailOutlook As Outlook.MailItem
Dim RTFBody
Set appOutlook = CreateObject("Outlook.application")
Set MailOutlook = appOutlook.CreateItem(olMailItem)
DoCmd.OutputTo acOutputReport, "report1", acFormatHTML, "Report.htm", , , , acExportQualityScreen
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile("Report.htm", ForReading, False, TristateTrue)
RTFBody = f.ReadAll
f.Close
With MailOutlook
.To = Me.Email.Value
.CC = "anwarmirza.ridha#gmail.com"
.Subject = Me.CR_Number & " " & Me.English_Name & " Weekly Report"
.HTMLBody = "Dear Supplier" & Chr$(13) & Chr$(13) & _
RTFBody
.Send
End With
Set MailOutlook = Nothing
Set appOutlook = Nothing
End Sub
Since MS Access reports are specialized rich text formats, conversion to HTML is not easily available. You would need to rebuild your report with HTML markup. However, there is another approach.
Consider creating an Outlook email template (.oft) with all needed images, colors, fonts, and other formatting with placeholders such as %...% markers:
Dear %ClientName%:
Thank you for purchase of %product% for %totalsales% on %salesdate%. We appreciate your business of %years% years.
%salestable%
Best wishes,
MyCompany Management
Then, have MS Access loop through a recordset of email details and text for message body to fill in placeholders. Handle any date/current/percent formatting in SQL or VBA. Because you need a group level multi-record summary, run two loops at 1) client level and 2) sales level.
strSQL = "SELECT ClientID, ClientName, ...email details... FROM myClientsTable"
Set clientRST = CurrentDb.OpenRecordset(strSQL)
Do While Not clientRST.EOF
Set MailOutlook = appOutlook.CreateItemFromTemplate("C:\Path\To\ClientEmail.oft")
strSQL = "SELECT Col1, Col2, Col3 ...sales details..." _
& " FROM mySalesTable" _
& " WHERE ClientID = " & clientRST!ClientID
Set salesRST = CurrentDb.OpenRecordSet(strSQL)
' TABLE COLUMNS
strTable = "<table><th>"
For i = 1 to salesRST.Fields.Count
strTable = strTable & "<td>" & salesRST.Fields(i-0).Name & "</td>"
Next i
strTable = strTable & "</th>"
' TABLE ROWS
salesRST.MoveFirst
While Not salesRst.EOF
strTable = strTable & "<tr>"
For i = 1 to salesRST.Fields.Count
strTable = strTable & "<td>" & salesRST.Fields(i-0).Value & "</td>"
Next i
strTable = strTable & "</tr>"
salesRST.MoveNext
Wend
strTable = strTable & "</table>"
salesRST.Close
With MailOutlook
' DYNAMIC RECIPEINT
.To = clientRST!Email
.CC = "anwarmirza.ridha#gmail.com"
' DYNAMIC SUBJECT
.Subject = clientRST!CR_Number & " " & clientRST!English_Name & " Weekly Report"
' REPLACE PLACEHOLDERS
.HTMLBody = Replace(.HTMLBody, "%ClientName%", clientRST!ClientName)
.HTMLBody = Replace(.HTMLBody, "%product%", clientRST!product)
.HTMLBody = Replace(.HTMLBody, "%totalsales%", clientRST!totalsales)
.HTMLBody = Replace(.HTMLBody, "%salesdate%", clientRST!salesdate)
.HTMLBody = Replace(.HTMLBody, "%years%", clientRST!client_years)
' ADD SALES TABLE
.HTMLBody = Replace(.HTMLBody, "%salestable%", strTable)
.Send
End With
Set MailOutlook = Nothing
clientRST.MoveNext
Loop
clientRST.Close
I want to send a personalized email generated by Excel VBA.
The email contains personalized text followed by a html file that contains images.
I tried the following code but the images are not displayed.
Sub Mail_Outlook_With_Html_Doc()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim oFSO As Object
Dim oFS As Object
Dim sText As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFS = oFSO.OpenTextFile("C:\....\invite.htm")
Do Until oFS.AtEndOfStream
sText = oFS.ReadAll()
Loop
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'strbody = personalized email body generated here
On Error Resume Next
With OutMail
.display
.To = ToAdd
.CC =
.BCC = ""
.Subject = "Test Email"
.ReadReceiptRequested = True
' the html file is appended here to the personalized email body generated
.HTMLBody = strbody & sText
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
The invite.htm referred above contains images which are not visible when the email is sent. Neither in the email messages sent nor in the email messages received.
Here ia an example that works for me you need to adapt it according to your needs.
This will embed the image in the body of the email and will attach it from what I remember. Please note you need to display the email first and then send it that is the only way to show on different device, i learn that the hard way. It can be done via code as the below example if you want to display and review the email just comment out the .Send after you are happy you can press manually send.
Option Explicit
Dim titleName As String
Dim firstName As String
Dim lastName As String
Dim fullName As String
Dim clientEmail As String
Dim ccEmail As String
Dim bccEmail As String
Dim emailMessage As String
Sub GenerateInfo()
Dim WS As Worksheet
Dim lrow As Long
Dim cRow As Long
Set WS = ActiveSheet
With WS
lrow = .Range("E" & .Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For cRow = 2 To lrow
If Not .Range("L" & cRow).value = "" Then
titleName = .Range("D" & cRow).value
firstName = .Range("E" & cRow).value
lastName = .Range("F" & cRow).value
fullName = firstName & " " & lastName
clientEmail = .Range("L" & cRow).value
Call SendEmail
.Range("Y" & cRow).value = "Yes"
.Range("Y" & cRow).Font.Color = vbGreen
Else
.Range("Y" & cRow).value = "No"
.Range("Y" & cRow).Font.Color = vbRed
End If
Next cRow
End With
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
Sub SendEmail()
Dim outlookApp As Object
Dim outlookMail As Object
Dim sigString As String
Dim Signature As String
Dim insertPhoto As String
Dim photoSize As String
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Marius.htm"
If Dir(sigString) <> "" Then
Signature = GetBoiler(sigString)
Else
Signature = ""
End If
insertPhoto = "C:\Users\marius\Desktop\Presale.jpg" 'Picture path
photoSize = "<img src=""cid:Presale.jpg""height=400 width=400>" 'Change image name here
emailMessage = "<BODY style=font-size:11pt;font-family:Calibri>Dear " & titleName & " " & fullName & "," & _
"<p>I hope my email will find you very well." & _
"<p>Our <strong>sales preview</strong> starts on Thursday the 22nd until Sunday the 25th of November." & _
"<p>I look forward to welcoming you into the store to shop on preview.<p>" & _
"<p> It really is the perfect opportunity to get some fabulous pieces for the fast approaching festive season." & _
"<p>Please feel free to contact me and book an appointment." & _
"<p>I look forward to seeing you then." & _
"<p>" & photoSize & _
"<p>Kind Regards," & _
"<br>" & _
"<br><strong>Marius</strong>" & _
"<br>Assistant Store Manager" & _
"<p>"
With outlookMail
.To = clientEmail
.CC = ""
.BCC = ""
.Subject = "PRIVATE SALE"
.BodyFormat = 2
.Attachments.Add insertPhoto, 1, 0
.HTMLBody = emailMessage & Signature 'Including photo insert and signature
'.HTMLBody = emailMessage & Signature 'Only signature
.Importance = 2
.ReadReceiptRequested = True
.Display
.Send
End With
Set outlookApp = Nothing
Set outlookMail = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Is there a possibility to have the HTML Body:
.HTMLBody = strText & RangetoHTML(rng) & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
...when criteria > 1 is fulfilled and ...
.HTMLBody = strText2 & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
' in this case the range is missing and the text is different when criteria = 0 is fulfilled.
I thought of the "if" function into the HTML Body?
GetBoiler Function:
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object, ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Range function:
Function RangetoHTML(rng As Range)
Dim fso As Object, ts As Object, TempWB As Workbook
With Worksheets("Auswertung")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("$A$7:$D$" & loLetzte).AutoFilter Field:=3, Criteria1:=">0"
If .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
.AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count - 1). _
SpecialCells(xlCellTypeVisible).Copy
Else
'copy only the strText2
End If
.AutoFilterMode = False
End With
End Function
Main Sub function:
Sub Mail_Klicken()
Dim olApp As Object, datDatum As Date, StrBody As String, intZeile As Integer
Dim OutMail As Object, rng As Range, strMailverteilerTo As String
Dim strText As String, strFilename As String, loLetzte As Long
strMailverteilerTo = "sdfgsdf#gmx.de"
strText = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & _
"-serif"";color:black'>hello,<br><br>hello fellows.<br><br>"
strText2 = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & _
"-serif"";color:black'>dfgfg,<br><br>gfgfgfgfg.<br><br>"
Application.DisplayAlerts = True
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.to = strMailverteilerTo
.Subject = "check"
strFilename = "Standard"
If Application.UserName = "asd" Then strFilename = "asd"
.HTMLBody = strText & RangetoHTML(rng) & "<br><br>" & _
GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & _
strFilename & ".htm")
.Display
End With
Set olApp = Nothing
End Sub
You cant, AFAIK, put a statement like that since its expecting a string argument, here's one way you can do it is to call a function that builds the string,
Set olApp = CreateObject("Outlook.Application")
setStrText criteria, strText, rng
With olApp.CreateItem(0)
'rest of your code
.HTMLBody = strText
'rest of your code
function setStrText(crit as integer, strTe as string, tmpRng as range)
if crit >= 1 then
strTe = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & "-serif"";color:black'>hello,<br><br>hello fellows.<br><br>" & RangetoHTML(tmpRng) & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
else
strTe = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & "-serif"";color:black'>dfgfg,<br><br>gfgfgfgfg.<br><br>" & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
end if
end function