I am trying to create a loop within VBA to have multiple selections from userform1's listbox2 when I hit the command button to draft an email with each selection in the following format. However, I can't figure out how to get more than just one selection into the body of the email. I tried to separate it into a "midbody" and add the code again, but it just adds the same entry twice. How can I make this loop work?
Private Sub CommandButton3_Click()
Dim objOutlook As Object
Dim objMail As Object
Dim midBody As String
Dim wksheet As String
Dim i As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i) = True Then
wksheet = ListBox2.List(i)
Sheets(wksheet).Activate
End If
If wksheet = "" Then
MsgBox "Nothing is Selected"
objMail.To = "myemail#me.com"
'objMail.CC =
objMail.Subject = ""
Else
midBody = activesheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
activesheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & activesheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
"Phase ECD: " & activesheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Baseline Finish: " & activesheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Previous Finish: " & activesheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Current Finish: " & activesheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Weekly Schedule Variance: " & activesheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
"CUM VAR to Baseline: " & activesheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Slip Reason: " & vbNewLine & _
"Critical Path: " & vbNewLine & vbNewLine
objMail.body = midBody & Sheets.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
Sheets.Range("D" & Rows.Count).End(xlUp).Value & " through " & Sheets.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
"Phase ECD: " & Sheets.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Baseline Finish: " & Sheets.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Previous Finish: " & Sheets.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Current Finish: " & Sheets.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Weekly Schedule Variance: " & Sheets.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
"CUM VAR to Baseline: " & Sheets.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Slip Reason: " & vbNewLine & _
"Critical Path: " & vbNewLine & vbNewLine
End If
i = i + 1
Next i
objMail.Save
'Close the object
Set objMail = Nothing
MsgBox "Done", vbInformation
End Sub
I have made some changes in your code .Shifted Next of For towards later part of the code to include processing of loop. Removed redundant midBody.
Try This:
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Dim i As Integer
Dim Agent As String
Dim EmailID As String
Dim wksheet As String
Dim objOutlook As Object
Dim objMail As Object
With Me.ListBox2
For i = 0 To .ListCount - 1
If .Selected(i) Then
wksheet = .List(i)
Exit For
End If
End With
If wksheet = "" Then
MsgBox "Nothing is Selected", vbExclamation
Exit Sub
End If
'r = Application.Match(wksheet, mySheet.Columns(1), 0)'choose one as per your data structure
r = Application.Match(Agent, mySheet.Columns(1), 0) 'choose one as per your data structure
Set ws = ThisWorkbook.ActiveSheet
'EmailID = mySheet.Range("D" & r).Value 'Uncomment it if this is required
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = "myemail#me.com" ' Or EmailID
' .CC =
.subject = ""
.Body = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
ActiveSheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
"Phase ECD: " & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Baseline Finish: " & ActiveSheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Previous Finish: " & ActiveSheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Current Finish: " & ActiveSheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Weekly Schedule Variance: " & ActiveSheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
"CUM VAR to Baseline: " & ActiveSheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Slip Reason: " & vbNewLine & _
"Critical Path: " & vbNewLine & vbNewLine
'.Display
'.Send
.Save
End With
Next i
Set objMail = Nothing
Set objOutlook = Nothing
MsgBox "Done", vbInformation
End Sub
EDIT: Another version of code which works at my end. I have not created a listbox but simulated its working. This program loops correctly and send emails multiple times. Please remove k variable as per your listbox code . It is only for checking correct looping of the ptogram. Earlier version of program can be adjusted to your requirements if you provide sample data as what is the structure of listbox, from where it is picking emailid of the recipient, sample data of your worksheet etc.
Private Sub Command3_Click()
Dim subject As String, Body As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim ws As Worksheet
Dim k As Integer
On Error Resume Next
Set ws = ThisWorkbook.ActiveSheet
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Set OutApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
k = 4 ' remove it only for checking correct loop
For intCurrentRow = 0 To k - 1 'List2.ListCount change k to List2.ListCount
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
' List2.Selected(intCurrentRow) = True ' This is to be commented out after trials for looping
.To = "abc#gmail.com"
.subject = "Test 2nd time Email"
.Body = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
ActiveSheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
"Phase ECD: " & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Baseline Finish: " & ActiveSheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Previous Finish: " & ActiveSheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Current Finish: " & ActiveSheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Weekly Schedule Variance: " & ActiveSheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
"CUM VAR to Baseline: " & ActiveSheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Slip Reason: " & vbNewLine & _
"Critical Path: " & vbNewLine & vbNewLine
.Send
End With
Next intCurrentRow
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Outlook snapshot shows it is looping properly which was your main problem.
EDIT2: Earlier version of program simulated at my end on sample basis is running correctly and sending multiple mails. I do not have idea of your data setup so simulated for looping which was your main problem. Please try the program as it is , retain a copy and then make suitable adjustments for your data specific situation.
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Dim i As Integer
Dim Agent As String
Dim EmailID As String
Dim wksheet As String
Dim objOutlook As Object
Dim objMail As Object
' With Me.ListBox2
For i = 1 To 3
'For i = 0 To .ListCount - 1
' If .Selected(i) Then
' wksheet = .List(i)
' Exit For
' End If
'End With
If wksheet = "hello" Then
MsgBox "Nothing is Selected", vbExclamation
Exit Sub
End If
'r = Application.Match(wksheet, mySheet.Columns(1), 0)'choose one as per your data structure
' r = Application.Match(Agent, mySheet.Columns(1), 0) 'choose one as per your data structure
Set ws = ThisWorkbook.ActiveSheet
'EmailID = mySheet.Range("D" & r).Value 'Uncomment it if this is required
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = "abc#gmail.com" ' Or EmailID
' .CC =
.subject = "original test"
.Body = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Value & vbNewLine & _
ActiveSheet.Range("D" & Rows.Count).End(xlUp).Value & " through " & ActiveSheet.Range("E" & Rows.Count).End(xlUp).Value & " phase" & vbNewLine & _
"Phase ECD: " & ActiveSheet.Range("F" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Baseline Finish: " & ActiveSheet.Range("G" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Previous Finish: " & ActiveSheet.Range("H" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Current Finish: " & ActiveSheet.Range("I" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Weekly Schedule Variance: " & ActiveSheet.Range("J" & Rows.Count).End(xlUp).Value & vbNewLine & _
"CUM VAR to Baseline: " & ActiveSheet.Range("K" & Rows.Count).End(xlUp).Value & vbNewLine & _
"Slip Reason: " & vbNewLine & _
"Critical Path: " & vbNewLine & vbNewLine
'.Display
.Send
'.Save
End With
Next i
Set objMail = Nothing
Set objOutlook = Nothing
MsgBox "Done", vbInformation
End Sub
Related
I have a working VBA script that generates an Outlook email when cell value = 1. This runs on a hidden worksheet (cell is changed to 1 when criteria is met on visible summary worksheet).
Dim xRg As Range
'Update by Extendoffice 2019/8/2
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("AA1"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value = 1 Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hello " & Range("G2") & "," & vbNewLine & vbNewLine & _
"Please review the following list of loan documents that were produced through our online system from " & Range("A2") & ". Your total bill for this month's documents is " & FormatCurrency(Range("E2")) & " (" & Range("C2") & " x " & Range("D2") & "):" & vbNewLine & vbNewLine & _
Range("F2") & vbNewLine & _
Range("F3") & vbNewLine & _
Range("F4") & vbNewLine & _
Range("F5") & vbNewLine & _
Range("F6") & vbNewLine & _
Range("F7") & vbNewLine & _
Range("F8") & vbNewLine & _
Range("F9") & vbNewLine & _
Range("F10") & vbNewLine & _
Range("F11") & vbNewLine & _
Range("F12") & vbNewLine & _
Range("F13") & vbNewLine & _
Range("F14") & vbNewLine & _
Range("F15") & vbNewLine & _
Range("F16") & vbNewLine & _
Range("F17") & vbNewLine & _
Range("F18") & vbNewLine & _
Range("F19") & vbNewLine & _
Range("F19") & vbNewLine & _
Range("F20") & " " & Range("F21") & " " & Range("F22") & " " & Range("F23") & " " & Range("F24") & " " & Range("F25") & " " & Range("F26") & " " & Range("F27") & " " & Range("F28") & " " & Range("F29") & " " & Range("F30") & " " & Range("F31") & " " & Range("F32") & " " & Range("F33") & " " & Range("F34") & " " & Range("F35") & " " & Range("F36") & " " & Range("F37") & " " & Range("F38") & " " & Range("F39") & " " & Range("F40") & " " & Range("F41") & " " & Range("F42") & " " & Range("F43") & " " & Range("F44") & " " & Range("F45") & " " & Range("F46") & " " & Range("F47") & " " & Range("F48") & " " & Range("F49") & " " & Range("F50") & " " & Range("F51") & " " & Range("F52") & " " & Range("F53") & " " & Range("F54") & " " & vbNewLine & _
Range("F55") & " " & Range("F56") & " " & Range("F57") & " " & Range("F58") & " " & Range("F59") & " " & Range("F60") & " " & Range("F61") & " " & Range("F62") & " " & Range("F63") & " " & Range("F64") & " " & Range("F65") & " " & Range("F66") & " " & Range("F67") & " " & Range("F68") & " " & Range("F69") & " " & Range("F70") & " " & Range("F71") & " " & Range("F72") & " " & Range("F73") & " " & Range("F74") & " " & Range("F75") & " " & Range("F76") & " " & Range("F77") & " " & Range("F78") & " " & Range("F79") & " " & Range("F80") & " " & Range("F81") & " " & Range("F82") & " " & Range("F83") & " " & Range("F84") & " " & Range("F85") & " " & Range("F86") & " " & Range("F87") & " " & Range("F88") & " " & Range("F89") & " " & vbNewLine & vbNewLine & _
"Please let us know within two business days whether your records match ours. If we do not get a response within this time frame, we will invoice you shortly thereafter. If your credit card is on file and we have a pre-existing authorization, we will charge your card on file and provide you with a copy of your paid invoice." & vbNewLine & vbNewLine & _
"Thank you!" & vbNewLine
On Error Resume Next
With xOutMail
.To = Range("H2")
.CC = "billing#example.com"
.BCC = ""
.Subject = Range("B2") & " - (ID: " & Range("I2") & ") - " & Range("A2") & " Lightning Docs Usage & Billing"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Private Sub Worksheet_Calculate()
Dim xI As Integer
Dim xRg As Range
Set xRg = Range("AA1")
On Error GoTo Err01
xI = Int(xRg.Value)
If xI = 1 Then
Call Mail_small_Text_Outlook
End If
Err01:
End Sub
This is a bodge way of adding what should be a table into the email body.
I recently discovered Ron de Bruin's script for converting a table to HTML and adding it to an email body that way. I got the script running, but my problem comes when trying to trigger the macro from another worksheet. The user will be on the summary worksheet and make a change to cause cell AA1 on the VBA script worksheet to change to 1.
Without Private Sub Worksheet_Calculate(), it works when I am on the worksheet with the script.
When I add Private Sub Worksheet_Calculate(), it can be triggered from a different worksheet, but it gets stuck at the point where a temporary worksheet is created, and keeps creating temporary worksheets until I force quit Excel.
Dim xRg As Range
'Update by Extendoffice 2018/3/7
Public Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("AA1"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 0 Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
On Error Resume Next
With xOutMail
.To = Range("H2")
.CC = "billing#example.com"
.BCC = ""
.Subject = Range("C2") & " - (ID: " & Range("I2") & ") - " & Range("B2") & " Lightning Docs Usage & Billing"
.HTMLBody = "<font size=-0> Hello " & Range("G2") & ",<br/><br/>" &
"Please review the following list of loan documents that were produced through our online system from " & Range("B2") & ". <br/>Your total bill for this month's documents is " & FormatCurrency(Range("F2")) & " (" & Range("E2") & " x " & FormatCurrency(Range("D2")) & "):</font>" &
RangetoHTML(Range("Table3_2[Titles]")) &
"<br/><font size=-0>Please let us know within two business days whether your records match ours. If we do not get a response within this time frame, we will invoice you shortly thereafter. If your credit card is on file and we have a pre-existing authorization, we will charge your card on file and provide you with a copy of your paid invoice." &
"<br/><br/>Thank you!</font><br/>"
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Private Sub Worksheet_Calculate()
Dim xI As Integer
Dim xRg As Range
Set xRg = Range("AA1")
On Error GoTo Err01
xI = Int(xRg.Value)
If xI = 1 Then
Call Mail_small_Text_Outlook
End If
Err01:
End Sub
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 send schedules from Excel every week and I want to convert the data to a table where the week number is one merged cell at the top and the day and date are at the top of each column.
I don't know how to rewrite the mail body message as a table. The code probably has a lot of unnecessary strings but it works. I'd like to add that I am VERY new to VBA, or any coding at all for that matter, and still learning.
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = what_address
olMail.Subject = subject_line
olMail.Body = mail_body
olMail.Send
End Sub
Sub SendSchedules()
row_number = 2
Do
DoEvents
row_number = row_number + 1
Dim mail_body_message As String
Dim full_name As String
Dim replace_Monday As String
Dim replace_Tuesday As String
Dim replace_Wednesday As String
Dim replace_Thursday As String
Dim replace_Friday As String
Dim replace_Saturday As String
Dim replace_Sunday As String
mail_body_message = ActiveSheet.Range("J1") & vbNewLine & ActiveSheet.Range("C1") & " " & ActiveSheet.Range("C2") & vbNewLine & ActiveSheet.Range("D1") & " " & ActiveSheet.Range("D2") & vbNewLine & ActiveSheet.Range("E1") & " " & ActiveSheet.Range("E2") & vbNewLine & ActiveSheet.Range("F1") & " " & ActiveSheet.Range("F2") & vbNewLine & ActiveSheet.Range("G1") & " " & ActiveSheet.Range("G2") & vbNewLine & ActiveSheet.Range("H1") & " " & ActiveSheet.Range("H2") & vbNewLine & ActiveSheet.Range("I1") & " " & ActiveSheet.Range("I2")
full_name = ActiveSheet.Range("B" & row_number)
mon_day = ActiveSheet.Range("C" & row_number)
tues_day = ActiveSheet.Range("D" & row_number)
wednes_day = ActiveSheet.Range("E" & row_number)
thurs_day = ActiveSheet.Range("F" & row_number)
fri_day = ActiveSheet.Range("G" & row_number)
satur_day = ActiveSheet.Range("H" & row_number)
sun_day = ActiveSheet.Range("I" & row_number)
week_number = ActiveSheet.Range("K2")
mail_body_message = Replace(mail_body_message, "replace_name_here", full_name)
mail_body_message = Replace(mail_body_message, "replace_week_number", week_number)
mail_body_message = Replace(mail_body_message, "replace_Monday", mon_day)
mail_body_message = Replace(mail_body_message, "replace_Tuesday", tues_day)
mail_body_message = Replace(mail_body_message, "replace_Wednesday", wednes_day)
mail_body_message = Replace(mail_body_message, "replace_Thursday", thurs_day)
mail_body_message = Replace(mail_body_message, "replace_Friday", fri_day)
mail_body_message = Replace(mail_body_message, "replace_Saturday", satur_day)
mail_body_message = Replace(mail_body_message, "replace_Sunday", sun_day)
MsgBox mail_body_message
Call SendEmail(ActiveSheet.Range("A" & row_number), "Schedule Week 1", mail_body_message)
Loop Until row_number = 12
End Sub
Nothing wrong with this code, but now I want to take this information and create a table out of it. Although I'm worried I need to re-write the entire thing, I'm not sure how.
There are many ways to create tables in excel, but I can only think of two good methods for emailing them.
You could use VBA to setup a temporary excel spreedsheet that formats the table in the correct format. At this point, then you can simple copy and paste the entire thing into an HTML email using VBA.
Or, with VBA you could simply generate your entire body of text using HTML and then send the entire HTML string to your email body.
I have used the HTML route many times, and it can save a ton of time and it is much more useful.
Edit: Here is an example of using HTML, it's pretty rough and I wrote it in my early days. Please note that this was modified from a use-case I have with it. So you might have to tweak it a bit.
Sub Dealer_Email(Sheet As String, Name As Variant, Recipient As Variant, Subject As Variant, _
Mon as Variant, Tues as Variant, Wednesday as Variant, Thurs as Variant, _
Friday as Variant, Optional Copy As String, Optional Blind_Copy As String, _
Optional Attach As String)
' Sheet = the Sheet name in which you wish to pull data from (this was designed for multiple sheets with identical layouts.
'Name = the Name in which will be entered into the generated email
'Recipient = the email address
'Subject = the subject line
'Optional Copy = If you wish to 'cc' someone on the email
'Optional Blind_copy = adds someone to 'bcc' on the email
'Optional attachment = You can define a file to be attached to the email
' Parts of this function came from https://www.rondebruin.nl/
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim x, y As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(Sheet)
strbody = "<table>"
strbody = strbody & _
"<tr>" & _
"<td> | </td>" & _
"<td>" & Mon & "</td>" & _
"<td> | </td>" & _
"<td>" & Tues & "</td>" & _
"<td> | </td>" & _
"<td>" & Wednes & "</td>" & _
"<td> | </td>" & _
"<td>" & Thurs & "</td>" & _
"<td> | </td>" & _
"<td>" & Fri & "</td>" & _
"<td> | </td>" & _
"<td>" & Sat & "</td>" & _
"<td> | </td>" & _
"<td>" & Sun & "</td>" & _
"<td> | </td>" & "</tr></table>"
strbody = "<font>Good Day " & Name & ",<br><br>" & _
"Insert Message Here...<br>" & _
strbody & _
"<br>" & _
"If you have any questions, feel free to contact me.</font>"
2
On Error Resume Next
With OutMail
.Display
.To = Recipient
.CC = Copy
.BCC = Blind_Copy
.Subject = Subject
.htmlbody = strbody & .htmlbody
.Attachment = Attach
End With
OutMail.Display
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Note that this does require Microsoft Outlook to work. Part of this code did come from https://www.rondebruin.nl/.
You could easily add a loop, and have this repeat as needed for each line within the html chart.
EDIT (SECOND TIME AROUND):
Sub SendSchedules()
Dim row_number As Integer
row_number = 2
Do
DoEvents
row_number = row_number + 1
Dim mail_body_message As String
Dim full_name As String
Dim replace_Monday As String
Dim replace_Tuesday As String
Dim replace_Wednesday As String
Dim replace_Thursday As String
Dim replace_Friday As String
Dim replace_Saturday As String
Dim replace_Sunday As String
full_name = ActiveSheet.Range("B" & row_number).Value
mon_day = ActiveSheet.Range("C" & row_number).Value
tues_day = ActiveSheet.Range("D" & row_number).Value
wednes_day = ActiveSheet.Range("E" & row_number).Value
thurs_day = ActiveSheet.Range("F" & row_number).Value
fri_day = ActiveSheet.Range("G" & row_number).Value
satur_day = ActiveSheet.Range("H" & row_number).Value
sun_day = ActiveSheet.Range("I" & row_number).Value
week_number = ActiveSheet.Range("K2").Value
strbody = "<table>"
mail_body_message = strbody & _
"<tr>" & _
"<td> Full Name: </td>" & _
"<td>" & full_name & "</td></tr>" & _
"<tr><td>Week Number: </td>" & _
"<td>" & week_number & "</td></tr>" & _
"<tr><td>Monday: </td>" & _
"<td>" & mon_day & "</td></tr>" & _
"<tr><td>Tuesday: </td>" & _
"<td>" & tues_day & "</td></tr>" & _
"<tr><td>Wednesday: </td>" & _
"<td>" & wednes_day & "</td></tr>" & _
"<tr><td>Thursday: </td>" & _
"<td>" & thurs_day & "</td></tr>" & _
"<tr><td>Friday: </td>" & _
"<td>" & fri_day & "</td></tr>" & _
"<tr><td>Saturday: </td>" & _
"<td>" & satur_day & "</td></tr>" & _
"<tr><td>Sunday: </td>" & _
"<td>" & sun_day & "</td></tr>" & _
"</table>"
MsgBox mail_body_message
Loop Until row_number = 12
You will need to change another line of code from:
olMail.Body = mail_body
to the following.
olMail.htmlbody = mail_body & .htmlbody
I hope this helps out.
I have to create a VBA to send automatic e-mails (the body of the e-mail links the recipient to a specific project that he is responsible for). The problem that I encountered is the fact that a certain recipient (i.e. placed in "TO") can be responsible for more tasks. The VBA that I am using sends emails to each task (even if the person is responsible for more). What can I do to count through recipients, if it's greater than 1 to send the e-mail which includes all of the tasks. I really need your help.
<PRE>Sub SendEMail()
Dim OutApp As Object
Dim OutMail As Object
Dim lastRow As Long
Dim Ebody As String
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lastRow
Ebody = "<FONT SIZE = 4 name = Arial>" & "Dear " & Cells(i, "A").Value
& "<br>" _
& "<br>" _
& "Please note that the below mentioned projectd are in scope for reporting." & "<br>" _
& "<br>" _
& Cells(i, "C").Value & " - " & Cells(i, "E").Value & "<br>" _
& "xxxxx will investigate and action your notification according to priority and to ensure public safety." & "<br>" _
& "For further information, please phone xxxxx on 6111 and quote reference number:" & "<br>" _
& "Your original report can be seen below:" & "</Font>" & "<br>" _
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Cells(i, "B").Value
.Cc = Cells(i, "D").Value
.Subject = "Your Registration Code"
.HtmlBody = Ebody
.Attachments.Add "C:\Test\Document.docx"
.Attachments.Add "C:\Test\Document1.docx"
.SentOnBehalfOfName = "Financial#yahoo.com"
.Display
End With
Next
End Sub </pre>
Sub Emailer()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range, y, sbody
Dim eml As Worksheet, bd As Worksheet
Dim underlyingary, ISINarray, Accountarray, i
Set eml = Sheets("Emailer"): Set bd = Sheets("Body"): Set OutApp = CreateObject("Outlook.Application")
For Each y In eml.Range("A2:A" & eml.Range("A1000000").End(xlUp).Row)
If eml.Range("F" & y.Row) <> "" Then
underlyingary = Split(eml.Range("F" & y.Row), ",")
Accountarray = Split(eml.Range("G" & y.Row), ",")
ISINarray = Split(eml.Range("H" & y.Row), ",")
For i = 0 To UBound(underlyingary)
sbody = sbody & vbNewLine & "Underlying: " & WorksheetFunction.Proper(Trim(underlyingary(i))) & " Account Number: " & WorksheetFunction.Proper(Trim(Accountarray(i))) & " ISIN: " & WorksheetFunction.Proper(Trim(ISINarray(i))) & "<br>" & "<br>"
Next i
Else
sbody = sbody & vbNewLine & "Underlying: " & WorksheetFunction.Proper(Trim(eml.Range("C" & y.Row))) & " Account Number: " & WorksheetFunction.Proper(Trim(eml.Range("D" & y.Row))) & " ISIN: " & WorksheetFunction.Proper(Trim(eml.Range("E" & y.Row))) & "<br>"
End If
On Error GoTo cleanup
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = eml.Range("A" & y.Row)
.Subject = bd.Range("B2")
.cc = eml.Range("I" & y.Row)
.htmlBody = bd.Range("A2") _
& "<br>" & "<br>" & _
bd.Range("A3") & _
Trim(eml.Range("B" & y.Row)) & _
bd.Range("A4") _
& "<br>" & "<br>" & _
sbody _
& "<br>" & _
bd.Range("A5") _
& "<br>" & "<br>" & "<li>" & _
bd.Range("A6").Text & "</li>" & _
"<br>" & "<br>" & "<li>" & _
bd.Range("A7").Text & "</li>" & _
"<br>" & "<br>" & "<li>" & _
bd.Range("A8").Text & "</li>" & _
"<br>" & "<br>" & _
bd.Range("A9") _
& "<br>" & bd.Range("A10")
.display
End With
On Error GoTo 0
Set OutMail = Nothing
Next y
cleanup:
Set OutApp = Nothing
End Sub