I made the codes below using this link as reference:
Dim chartPath As String
Dim messageA As String
Dim hyperlink As String
'Set chart path
chartPath = Environ("userprofile") & _
"\Documents\Chart " & Format(Now, "mm-dd-yyyy") & ".png"
'Set hyperlink
hyperlink = www.google.com
'Set message A
messageA = "<p style= 'font-family:arial;font-size:12'>" & "<b>" & Range("E17").Value & "</b>" & "<br>" & "<br>" & Range("E18").Value & "<br>" & "<br>" & Range("E19").Value & "<br>" & "<br>" & Range("E20").Value & " " & **"<b>" & "<u>" & "" & Range("E21").Value & "" & "</u>" & "</b>"** & " " & Range("E22").Value & "<br>" & "<br>" & "<b>" & "<u>" & Range("E23").Value & "</u>" & "</b>" & "<br>" & "<br>" & "</p>"
With OutlookMailItem
.HTMLBody = messageA & "<img src ='" & chartPath & "'>"
End With
However, the text which contains hyperlink does not direct me to the website once click and I think, using string for this part is the problem. What could be the possible remedy for this
I was not able to run your code but I found that these 2 lines should have some changes:
'Set hyperlink
hyperlink = "www.google.com" 'Added ""
'Also you can set the value from a cell.
hyperlink = Cells(1,1).Value 'Get value from cell A1.
'Set message A - Removed **
messageA = "<p style= 'font-family:arial;font-size:12'>" & "<b>" & Range("E17").Value & "</b>" & "<br>" & "<br>" & Range("E18").Value & "<br>" & "<br>" & Range("E19").Value & "<br>" & "<br>" & Range("E20").Value & " " & "<b>" & "<u>" & "" & Range("E21").Value & "" & "</u>" & "</b>" & " " & Range("E22").Value & "<br>" & "<br>" & "<b>" & "<u>" & Range("E23").Value & "</u>" & "</b>" & "<br>" & "<br>" & "</p>"
Please test your code again.
change this line hyperlink = www.google.com to this: hyperlink = "http://www.google.com"
If your URL has spaces in it, those need to be replaced with %20 - This code will convert it for you:
hyperlink = Replace(hyperlink, " ", "%20")
Related
My current working Macro is:
Sub emailGenerator()
'Disable Screen Updating
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Email").Activate
Worksheets("Email").Visible = False
'ThisWorkbook.Sheets("P6").Activate
ActiveWorkbook.Save
Worksheets("Email").Visible = True
ThisWorkbook.Sheets("Email").Activate
Dim TempFilePath As String
Dim nameOfProject As String
Dim firstName As String
nameOfProject = Cells(3, 7)
firstName = Cells(4, 7)
'Create a new Microsoft Outlook session
Set appOutlook = CreateObject("outlook.application")
'create a new message
Set Message = appOutlook.CreateItem(olMailItem)
With Message
.Subject = nameOfProject & " Programme Analytical Tool"
.HTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hi " & firstName & ",<br ><br >Please find attached the analytical tool for " & nameOfProject & ". Commentary below:" _
& "<br><br>" & " - " & Cells(7, 2) _
& "<br>" & " - " & Cells(9, 2) _
& "<br>" & " - " & Cells(11, 2) _
& "<br>" & " - " & Cells(13, 2) _
& "<br>" & " - " & Cells(15, 2) _
& "<br>" & " - " & Cells(17, 2) _
& "<br>" & " - " & Cells(19, 2) _
& "<br>" & " - " & Cells(21, 2) _
& "<br>" & " - " & Cells(23, 2) _
& "<br>" & " - " & Cells(25, 2) _
& "<br>" & " - " & Cells(27, 2) _
& "<br>" & " - " & Cells(29, 2) _
& "<br>" & " - " & Cells(31, 2) _
& "<br><br><BR>"
'first we create the image as a JPG file
'Call createJpg("GRAPHS", "B2:AA90", "OFGraph")
'we attached the embedded image with a Position at 0 (makes the attachment hidden)
TempFilePath = Environ$("temp") & "\"
'.attachments.Add TempFilePath & "OFGraph.jpg", olByValue, 0
.attachments.Add ActiveWorkbook.FullName
'.attachments.Add "\\MSQFDC02\DFSRoot$\NW\NW08Groups\LNW North ASM Team\Incident Management Specialist\OUTSTANDING FAULT SUMMARIES\UNVERIFIED & OUTSTANDING FAULT SUMMARYs\DELIVERY UNITs\Closing of Faults Form.docx"
'Then we add an html <img src=''> link to this image
'Note than you can customize width and height - not mandatory
'.HTMLBody = .HTMLBody _
'& "<img src='cid:OFGraph.jpg'" & "width='1100' height='1120'><br>"
' & "<img src='cid:OFGraph.jpg'" & "width='1400' height='1420'><br>"
.To = firstName
.CC = ""
.Display
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I want to make those lines that are under the .HTMLBody more dynamic so I can add in more lines in the Excel sheet without having to re-visit the macro and tell it to read this specific line.
" & "" & " - " & Cells(x, 2) _"
Here's my attempt to make it dynamic and adding a loop, but not sure where it went wrong and it's highlighted as red.
This is how the sheet looks like:
CurrentRegion is extracted but not shown in email body
Sub Draft()
Dim myDataRng As Range
Set myDataRng = Range("c2:c2")
Dim data As String
data = Range("B11").CurrentRegion.Select
For Each Cell In myDataRng
If Cell.Value > 0 Then
Dim objOutlook As Object
Set objOutlook = CreateObject("outlook.application")
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
Range("K2").Select
With objEmail
.SentOnBehalfOfName = "accounting#test.co.uk"
.to = ActiveCell.Offset(0, 1).Value
.Subject = ActiveCell.Offset(7, 0).Value
.htmlbody = "Supplier Code " & " " & Cell.Offset(0, 0).Value & "<br>" & "Supplier Name: " & " " & Cell.Offset(1, 0).Value & "<br>" & "Currency " & " " & Cell.Offset(2, 0).Value & "<br>" & "<br>" & "Dear Supplier," & "<br>" & "<br>" & "A payment has been issued to you, as detailed below. " & "<br>" & data & "<br>" & "<br>" & "Kind Regards,<br>Johnny Grif <br>Accounts Assistant/Accounts Department" & "<br>" & "T:+44(0)1234 567 890" & "<br>" & "E:accounting#test.co.uk"
.Save
End With
Set objOutlook = Nothing
End If
Next Cell
Set myDataRng = Nothing
Set objEmail = Nothing: Set objOutlook = Nothing
MsgBox "Please check pyament advice in your draft folder!"
End Sub
The final outcome is like this.
Dear Supplier,
A payment has been issued to you, as detailed below.
True
Kind Regards,
Johnny Grif
Accounts Assistant/Accounts Department
T:+44(0)1234 567 890
E:accounting#test.co.uk
Below is the output:
The following code is the cause of the problem:
.htmlbody = "Supplier Code " & " " & Cell.Offset(0, 0).Value & "<br>" & "Supplier Name: " & " " & Cell.Offset(1, 0).Value & "<br>" & "Currency " & " " & Cell.Offset(2, 0).Value & "<br>" & "<br>" & "Dear Supplier," & "<br>" & "<br>" &
"A payment has been issued to you, as detailed below. " & "<br>" & data & "<br>" & "<br>" & "Kind Regards,<br>Johnny Grif <br>Accounts Assistant/Accounts Department" & "<br>" & "T:+44(0)1234 567 890" & "<br>" & "E:accounting#test.co.uk"
First of all, the message body markup should be represented by a well formed HTML document/string.
Second, if you need to break the line in the code you need to use the underscore _ character in the code to get the lines assembled correctly.
Third, I'd suggest breaking the code and trying to assemble the final from multiple pieces, so you could find out why the code doesn't work correctly.
I have the following listed in my Sheet 1 code, moving cell values to the body of an Outlook email.
I'm trying to STOP inserting text for the given line if the cell in Column A is empty.
Private Sub CommandButton1_Click()
'Create email with attachment, subject, and list of email addresses
ThisWorkbook.Save
Dim outlookApp As Object
Dim myMail As Object
Dim Source_File, to_emails, cc_emails As String
Dim file_to_send As String
Dim body_code As String
Dim i As Integer
Set outlookApp = CreateObject("Outlook.Application")
Set myMail = outlookApp.CreateItem(olMailItem)
For i = 2 To 22
to_emails = to_emails & Cells(i, 13) & ";"
'for CC: change the 13 to whatever column count from the left where your CC list is
'cc_emails = cc_emails & Cells(i, 13) & ";"
Next i
Source_File = ThisWorkbook.FullName
myMail.Attachments.Add Source_File
'myMail.CC = cc_emails
myMail.To = to_emails
myMail.Subject = Range("Q2").Value & " 10-8 Form " & Format(Date, "mm/dd/yy")
myMail.Body = Range("B2") & " Shift" & " - " & Format(Date, "mmmm dd, yyyy") _
& vbNewLine & vbNewLine & "Sergeant: " & Range("A6") & ", " & Range("B6") & vbNewLine & " Status: " & Range("C6") _
& vbNewLine & vbNewLine & "Corporal: " & Range("A8") & ", " & Range("B8") & vbNewLine & " Status: " & Range("C8") _
& vbNewLine & vbNewLine & "Assigned Deputies" & vbNewLine & vbNewLine & _
Range("A10") & ", " & Range("B10") & vbNewLine & " Assignment/Zone: " & Range("C10") & vbNewLine & _
Range("A11") & ", " & Range("B11") & vbNewLine & " Assignment/Zone: " & Range("C11") & vbNewLine & _
Range("A12") & ", " & Range("B12") & vbNewLine & " Assignment/Zone: " & Range("C12") & vbNewLine & _
Range("A13") & ", " & Range("B13") & vbNewLine & " Assignment/Zone: " & Range("C13") & vbNewLine & _
Range("A14") & ", " & Range("B14") & vbNewLine & " Assignment/Zone: " & Range("C14") & vbNewLine & _
Range("A15") & ", " & Range("B15") & vbNewLine & " Assignment/Zone: " & Range("C15") & vbNewLine & _
Range("A16") & ", " & Range("B16") & vbNewLine & " Assignment/Zone: " & Range("C16") & vbNewLine & _
Range("A17") & ", " & Range("B17") & vbNewLine & " Assignment/Zone: " & Range("C17") & vbNewLine & _
Range("A18") & ", " & Range("B18") & vbNewLine & " Assignment/Zone: " & Range("C18")
myMail.Display
ThisWorkbook.Save
End Sub
I would definitely break up that huge wall of text you have. This can be done with a loop.
Let's use a For loop here.
Dim concatString as String
For i = 10 To 18
If Not Cells(i, "A").Text = vbNullString Then
'Add to growing string
concatString = concatString + Cells(i, "A").Text & ", " & Cells(i, "B").Text & vbCr
concatString = concatString + "Assignment/Zone: " & Cells(i, "C").Text & vbCr
End If
Next i
If column A contains an empty string, we skip over it and move to the next row.
I posted this before you added more code, but I think you get the idea. Break up the huge chunk of code, and put only one cycle through columns A, B, and C in the loop. Adjust your loop constraints as necessary.
Here's what it would look like in your code:
'...
'your code here
'...
Dim concatString as String
For i = 10 To 18
If Not Cells(i, "A").Text = vbNullString Then
'Add to growing string
concatString = concatString + Cells(i, "A").Text & ", " & Cells(i, "B").Text & vbCr
concatString = concatString + "Assignment/Zone: " & Cells(i, "C").Text & vbCr
End If
Next i
myMail.Body = Range("B2") & " Shift" & " - " & Format(Date, "mmmm dd, yyyy") _
& vbNewLine & vbNewLine & "Sergeant: " & Range("A6") & ", " & Range("B6") & vbNewLine & " Status: " & Range("C6") _
& vbNewLine & vbNewLine & "Corporal: " & Range("A8") & ", " & Range("B8") & vbNewLine & " Status: " & Range("C8") _
& vbNewLine & vbNewLine & "Assigned Deputies" & vbNewLine & vbNewLine & concatString
I removed all those extra spaces, not sure if you actually need them in there or if it's a vestige of copying/pasting from VBE.
Here is the final code, the one that finally did it. Thank you to jclasley
`Private Sub CommandButton1_Click()
'Create email with attachment, subject, and list of email addresses
ThisWorkbook.Save
Dim outlookApp As Object
Dim myMail As Object
Dim Source_File, to_emails, cc_emails As String
Dim file_to_send As String
Dim i As Integer
Dim concatString As String
Set outlookApp = CreateObject("Outlook.Application")
Set myMail = outlookApp.CreateItem(olMailItem)
For i = 2 To 22
to_emails = to_emails & Cells(i, "M") & ";"
'for CC: change the 13 to whatever column count from the left where your CC list is
'cc_emails = cc_emails & Cells(i, 13) & ";"
Next i
Source_File = ThisWorkbook.FullName
myMail.Attachments.Add Source_File
'myMail.CC = cc_emails
myMail.To = to_emails
myMail.Subject = Range("Q2").Value & " 10-8 Form " & Format(Date, "mm/dd/yy")
For i = 10 To 18
If Not Cells(i, "A").Text = vbNullString Then
'Add to growing string
concatString = concatString + Cells(i, "A").Text & ", " & Cells(i, "B").Text & vbCr
concatString = concatString + "Assignment/Zone: " & Cells(i, "C").Text & vbNewLine & vbCr
End If
Next i
myMail.Body = Range("B2") & " Shift" & " - " & Format(Date, "mmmm dd, yyyy") _
& vbNewLine & vbNewLine & "Sergeant: " & Range("A6") & ", " & Range("B6") & vbNewLine & " Status: " & Range("C6") _
& vbNewLine & vbNewLine & "Corporal: " & Range("A8") & ", " & Range("B8") & vbNewLine & " Status: " & Range("C8") _
& vbNewLine & vbNewLine & "Assigned Deputies" & vbNewLine & vbNewLine & concatString
myMail.Display
ThisWorkbook.Save
End Sub
enter code here
I am trying to change the text so certain values from cells are either bold, underlined, red, or otherwise stand out from the surrounding text in the body of the email.
How can I do that?
For i = 10 To 18
If Not Cells(i, "A").Text = vbNullString Then
'Add to growing string
concatString = concatString + Cells(i, "A").Text & ", " & _
Cells(i, "B").Text & vbCr
concatString = concatString + "Assignment/Zone: " & _
Cells(i, "C").Text & vbNewLine & vbCr
End If
Next i
myMail.Body = Range("B2") & " Shift" & " - " & Format(Date, "mmmm dd, yyyy") _
& vbNewLine & vbNewLine & "Sergeant: " & Range("A6") & ", " & Range("B6") & _
vbNewLine & " Status: " & Range("C6") _
& vbNewLine & vbNewLine & "Corporal: " & Range("A8") & ", " & Range("B8") & _
vbNewLine & " Status: " & Range("C8") _
& vbNewLine & vbNewLine & "Assigned Deputies" & vbNewLine & vbNewLine & concatString
You need to look into using HTML-formatted content to apply the colors etc you want:
Dim oApp As Object, oMail As Object
Set oApp = CreateObject("outlook.application")
Set oMail = oApp.createitem(0)
oMail.Display
oMail.htmlBody = "<h1>This is a heading</h1>" & _
"<p style='color:#F00'>Some red text</p>" & _
"<p><u>Underlined</u></p>" & _
"<p><b>Bold</b></p>" & _
"<p><i>Italic</i></p>"
I needed to use <br> to put the resultant answer in the email body. <p> creates a new PARAGRAPH, while <br> just puts it on the next line.
& "<br><b><u>Status:</u></b>"
gives:
& "Status:" &
Instead of:
& "<p><b><u>Status:</u></b>"
Which gives:
& "Status:"
Thank you for your help!
I am trying to add in an if statement half way through a HTML body of text I am using in VBA to send an e-mail.
I need to work out how to get the code to add extra hyperlinks if a cell in on one of the tabs has a value, there could be up to five that may need to be added.
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = Accounts
.Subject = "Consolidated Account Statement " & myPolicynumber & " - " & mypolicyname
If myhyperlink2 = "" Then
.HTMLBody = "<HTML><BODY>" & "<FONT-size=""11.0pt"">" & "Hi Accounts" & "<br><br>" & _
" The Account Statement" & _
" for " & myPolicynumber & " (" & mypolicyname & ") is ready to be created. " & "<br><br>" & "<br><br>" & _
" The following Medical Extra Premium also need booking " & "<br><br>"
If Worksheets("FOR PA").Cells(13, 39).Value = "Medicals" Then
" Medical Extra Premium 1" & "<br><br>" & _
" Medical Extra Premium 2" & "<br><br>" & _
" Medical Extra Premium 3" & "<br><br>" & _
" Medical Extra Premium 4" & "<br><br>" & _
" Medical Extra Premium 5" & "<br><br>" & _
" Kind Regards," &.HTMLBody
.Send
Else
.HTMLBody = "<HTML><BODY>" & "<FONT-size=""11.0pt"">" & "Hi Accounts" & "<br><br>" & _
" The Initial" & " and the " & "Final & are ready to be put on the Account Statement " & _
" for " & myPolicynumber & " (" & mypolicyname & ") is ready to be created. " & "<br><br>" & _
" Kind Regards," & .HTMLBody
.Send
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
You're doing the right thing, but you're missing a .HTMLBody = before one of the options:
If Worksheets("FOR PA").Cells(13, 39).Value = "Medicals" Then
.HTMLBody = " Medical Extra Premium 1" & "<br><br>" & _
" Medical Extra Premium 2" & "<br><br>" & _