# VBA To Create (But Not To Send) E-mail Drafts Based On Table



## CyrusTheVirus (Feb 17, 2019)

Hi everyone,

Looking for a code that will populate e-mail drafts within outlook, *but not send them out*, based on information within a table. The table name is Email_Table, and the sheet is Sheet1.

Specifically, what I need to populate within the e-mail is:

1) The subject which is in cell B1.

2) The body, which is in cell B2, but I need the body to be two lines below "Hi (insert first name of supervisor (only one time) from column 1 of Email_Table),".

3) Headers from table (copy/pasted), with corresponding data per supervisor (copy/pasted), but ONLY for table columns 3, 4, 5, 8, 9, 10, 11, 12, 13, 14, 15, 17... to clarify I need one e-mail to be drafted for each supervisor listing out all of their items, the below example shows some supervisors with 1 item, 2 items, and 4 items. Below is an example of what Sheet1 looks like, and below that is an example of the 4 e-mails that I would want populated (but not sent, so drafted) within outlook.

Can anyone please help with this?



Subject:Outstanding ItemsBody:The below item(s) are outstanding. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.Email_TableFirst NameSupervisor E-mail AddressSupervisor NameEmployee NameHourly/SalaryEmployee No.Employee InfoPinLocation No.Location NameDate InTime InDate OutTime OutRequested DateOptionsNotesAnneAApple@123.orgApple, AmandaSmith, JohnHourly1235Smith, John600009012Accounting2/6/201912:04:26Call In Missing or Not ApprovedKelliKBlacksmith@123.orgBlacksmith, KelliRogers, AndreaSalary5168Rogers, Andrea100002000HR2/12/201907:54:55Call Out Missing or Not ApprovedGeorgeGCurry@123.orgCurry, GeorgeSalem, TravisHourly54545Salem, Travis301002600Warehouse2/11/201913:21:38Call Out Missing or Not ApprovedGeorgeGCurry@123.orgCurry, GeorgeSalem, TravisHourly66464Salem, Travis102009102Warehouse2/12/201913:16:32Call Out Missing or Not ApprovedMichelleMMiller@123.orgMiller, MichelleRussell, CoreyHourly848Russell, Corey102009102Warehouse2/12/201912:33:04Call Out Missing or Not ApprovedMichelleMMiller@123.orgMiller, MichelleRussell, CoreySalary848Russell, Corey311002802House2/12/201910:15:01Call In Missing or Not ApprovedMichelleMMiller@123.orgMiller, MichelleSmith, SeanSalary545Smith, Sean311002802House2/12/201910:15:01Call In Missing or Not ApprovedMichelleMMiller@123.orgMiller, MichelleTompkins, BrianSalary949Tompkins, Brian2/12/20193Calendar Request Pending Approval

<tbody>

</tbody>




Hi Amanda,The below item(s) are outstanding. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.Supervisor NameEmployee NameHourly/SalaryPinLocation No.Location NameDate InTime InDate OutTime OutRequested DateNotesApple, AmandaSmith, JohnHourly600009012Accounting2/6/201912:04:26Call In Missing or Not ApprovedHi Kelli,The below item(s) are outstanding. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.Supervisor NameEmployee NameHourly/SalaryPinLocation No.Location NameDate InTime InDate OutTime OutRequested DateNotesBlacksmith, KelliRogers, AndreaSalary100002000HR2/12/201907:54:55Call Out Missing or Not ApprovedHi George,The below item(s) are outstanding. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.Supervisor NameEmployee NameHourly/SalaryPinLocation No.Location NameDate InTime InDate OutTime OutRequested DateNotesCurry, GeorgeSalem, TravisHourly301002600Warehouse2/11/201913:21:38Call Out Missing or Not ApprovedCurry, GeorgeSalem, TravisHourly102009102Warehouse2/12/201913:16:32Call Out Missing or Not ApprovedHi Michelle,The below item(s) are outstanding withim. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.Supervisor NameEmployee NameHourly/SalaryPinLocation No.Location NameDate InTime InDate OutTime OutRequested DateNotesMiller, MichelleRussell, CoreyHourly102009102Warehouse2/12/201912:33:04Call Out Missing or Not ApprovedMiller, MichelleRussell, CoreySalary311002802House2/12/201910:15:01Call In Missing or Not ApprovedMiller, MichelleSmith, SeanSalary311002802House2/12/201910:15:01Call In Missing or Not ApprovedMiller, MichelleTompkins, BrianSalary2/12/2019Calendar Request Pending Approval

<tbody>

</tbody>


----------



## Fazza (Feb 17, 2019)

Please have a look at Ron de Bruin's first-class information, https://www.rondebruin.nl/win/s1/outlook/mail.htm

Maybe use .Display instead of .Send to not send the message. I'm sure Ron will cover it somewhere, been a while since I've done that sort of thing.

As good as Ron's site is, if you need further help Google will find all you need. all the best Fazza


----------



## CyrusTheVirus (Feb 17, 2019)

Fazza said:


> Please have a look at Ron de Bruin's first-class information, https://www.rondebruin.nl/win/s1/outlook/mail.htm
> 
> Maybe use .Display instead of .Send to not send the message. I'm sure Ron will cover it somewhere, been a while since I've done that sort of thing.
> 
> As good as Ron's site is, if you need further help Google will find all you need. all the best Fazza



Thanks Fazza, I'll give it a read. Though, VBA just isn't my thing, I rarely use it.... spent my time studying formulas/features instead. Perhaps I'll give it a whirl if no one provides a code.


----------



## Fazza (Feb 18, 2019)

hi,
I had some time to look at this. Built it around Ron's code. Assumes your data worksheet is active & like you posted. Please modify as required.
regards


```
Sub Maybe()


    Const lCOLUMN_WITH_ID As Long = 2 'Column B of input worksheet has email addresses
    
    Dim i As Long, j As Long, k As Long
    Dim lCountOfRows As Long
    Dim sThisAddress As String
    Dim aFieldsToKeep As Variant
    Dim wksData As Excel.Worksheet
    Dim wksTemp As Excel.Worksheet
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    'Zero based array, first field is the unique ID (email address)
    aFieldsToKeep = Array(2, 3, 4, 5, 8, 9, 10, 11, 12, 13, 14, 15, 17)
    
    'Assume worksheet with data is active when code starts; and sorted on email addresses
    Set wksData = ActiveSheet
    
    'Setup temporary sheet with data table columns to include in email body;
    'and also field 2 the field with unique ID (email address)
    Set wksTemp = Worksheets.Add
    For i = LBound(aFieldsToKeep) To UBound(aFieldsToKeep)
        j = j + 1
        Range("Email_Table").Columns(aFieldsToKeep(i)).Copy wksTemp.Cells(1, j)
    Next i
    wksTemp.Columns.AutoFit
    
    sThisAddress = wksTemp.Range("A2").Value
    k = 1
    'Loop through for each different name in field "A" and email data
    Do While Len(sThisAddress) > 0
        lCountOfRows = Application.WorksheetFunction.CountIf(wksTemp.Columns(1), sThisAddress)
        k = k + lCountOfRows
        
        Call SendRows(TheTable:=wksTemp.Range("A1").CurrentRegion.Offset(, 1).Resize(lCountOfRows + 1, UBound(aFieldsToKeep)), _
            SendTo:=sThisAddress, MsgSubject:=wksData.Range("B1").Value2, _
            MsgIntro:="hi, " & Range("Email_Table").Cells(k, 1) & "<br><br>" & wksData.Range("B2").Value2 & "<br><br>")
            
        wksTemp.Rows(2).Resize(lCountOfRows).Delete
        sThisAddress = wksTemp.Range("A2").Value
    Loop
    
    Application.DisplayAlerts = False
    wksTemp.Delete
    Application.DisplayAlerts = True
    Set wksTemp = Nothing
    Set wksData = Nothing
    Application.EnableEvents = True
    
End Sub


Sub SendRows(ByRef TheTable As Excel.Range, ByVal SendTo As String, ByVal MsgSubject As String, ByVal MsgIntro As String)
    
    Dim OutApp As Object
    Dim OutMail As Object
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)


    On Error Resume Next
    With OutMail
        .To = SendTo
        .CC = vbNullString
        .BCC = vbNullString
        .Subject = MsgSubject
        .HTMLBody = MsgIntro & RangetoHTML(TheTable)
        .Save
        .Close 0
    End With
    On Error GoTo 0


cleanup:
    Set OutMail = Nothing
    Set OutApp = 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
```


----------



## CyrusTheVirus (Feb 18, 2019)

Wow, I can't thank you enough for taking your time to put this together. I seriously need to start studying VBA again.

Though, I am seeing just two parts that seem to be missing/off. Do you think it would be much trouble to tweak for the below?

1) The below is what is drafted for George, but you can see this includes Amanda's line as well. This happened for the other e-mail addresses, one more mentioned below.

2) The headers are not copied into the e-mail address. It actually looks like this and No. 1 are related, looks like Amanda's line is acting as the header.



hi, George

The below item(s) are outstanding within MITC. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.


Apple, Amanda
Smith, John
Hourly
600
009012
Accounting
2/6/2019
12:04:26
Call In Missing or Not Approved
Curry, George
Salem, Travis
Hourly
301
002600
Warehouse
2/11/2019
13:21:38
Call Out Missing or Not Approved
Curry, George
Salem, Travis
Hourly
102
009102
Warehouse
2/12/2019
13:16:32
Call Out Missing or Not Approved



hi, Michelle

The below item(s) are outstanding within MITC. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.


Apple, Amanda
Smith, John
Hourly
600
009012
Accounting
2/6/2019
12:04:26
Call In Missing or Not Approved
Miller, Michelle
Russell, Corey
Hourly
102
009102
Warehouse
2/12/2019
12:33:04
Call Out Missing or Not Approved
Miller, Michelle
Russell, Corey
Salary
311
002802
House
2/12/2019
10:15:01
Call In Missing or Not Approved
Miller, Michelle
Smith, Sean
Salary
311
002802
House
2/12/2019
10:15:01
Call In Missing or Not Approved
Miller, Michelle
Tompkins, Brian
Salary
 
 
 
 
 
 
 
2/12/2019
Calendar Request Pending Approval


----------



## CyrusTheVirus (Feb 18, 2019)

Verbiage Correction: Didn't meant to say e-mail 'addresses' below, only 'e-mails'.

1) The below is what is drafted for George, but you can see this includes Amanda's line as well. This happened for the other *e-mails*, one more mentioned below.

2) The headers are not copied into the *e-mails*. It actually looks like this and No. 1 are related, looks like Amanda's line is acting as the header.


----------



## Fazza (Feb 18, 2019)

Initial thought - unchecked but fits the description? - is the set up is not what I expected. Check that "Email_Table" range matches the table range - that is headers & data.


----------



## CyrusTheVirus (Feb 18, 2019)

Will do Fazza. Thanks again for your help, much appreciated. Looks like I need to start studying the good ol' VBA again, b/c it sure would help to have that knowledge when things like this come up. See ya around.


----------



## Fazza (Feb 19, 2019)

You're welcome. Thanks to you too, for setting out the requirements lucidly.


----------



## CyrusTheVirus (Feb 20, 2019)

Hey Fazza,

Been really doing my best to wrap my head around this. Was really hoping you could just kind of explain the below. Now, I get what it's doing, however my question is specifically about the Array portion... when i msgbox the array it shows 0, 1, 2, 3... but below you put 2, 3, 4, 5, etc... and it populates correctly... how is this so? If the msgbox shows 0, how is it pulling 2?

aFieldsToKeep = Array(2, 3, 4, 5, 8, 9, 10, 11, 12, 13, 14, 15, 17)

For i = LBound(aFieldsToKeep) To UBound(aFieldsToKeep)
    j = j + 1
        Range("Email_Table").Columns(aFieldsToKeep(i)).Copy wksTemp.Cells(1, j)
Next i


----------



## CyrusTheVirus (Feb 17, 2019)

Hi everyone,

Looking for a code that will populate e-mail drafts within outlook, *but not send them out*, based on information within a table. The table name is Email_Table, and the sheet is Sheet1.

Specifically, what I need to populate within the e-mail is:

1) The subject which is in cell B1.

2) The body, which is in cell B2, but I need the body to be two lines below "Hi (insert first name of supervisor (only one time) from column 1 of Email_Table),".

3) Headers from table (copy/pasted), with corresponding data per supervisor (copy/pasted), but ONLY for table columns 3, 4, 5, 8, 9, 10, 11, 12, 13, 14, 15, 17... to clarify I need one e-mail to be drafted for each supervisor listing out all of their items, the below example shows some supervisors with 1 item, 2 items, and 4 items. Below is an example of what Sheet1 looks like, and below that is an example of the 4 e-mails that I would want populated (but not sent, so drafted) within outlook.

Can anyone please help with this?



Subject:Outstanding ItemsBody:The below item(s) are outstanding. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.Email_TableFirst NameSupervisor E-mail AddressSupervisor NameEmployee NameHourly/SalaryEmployee No.Employee InfoPinLocation No.Location NameDate InTime InDate OutTime OutRequested DateOptionsNotesAnneAApple@123.orgApple, AmandaSmith, JohnHourly1235Smith, John600009012Accounting2/6/201912:04:26Call In Missing or Not ApprovedKelliKBlacksmith@123.orgBlacksmith, KelliRogers, AndreaSalary5168Rogers, Andrea100002000HR2/12/201907:54:55Call Out Missing or Not ApprovedGeorgeGCurry@123.orgCurry, GeorgeSalem, TravisHourly54545Salem, Travis301002600Warehouse2/11/201913:21:38Call Out Missing or Not ApprovedGeorgeGCurry@123.orgCurry, GeorgeSalem, TravisHourly66464Salem, Travis102009102Warehouse2/12/201913:16:32Call Out Missing or Not ApprovedMichelleMMiller@123.orgMiller, MichelleRussell, CoreyHourly848Russell, Corey102009102Warehouse2/12/201912:33:04Call Out Missing or Not ApprovedMichelleMMiller@123.orgMiller, MichelleRussell, CoreySalary848Russell, Corey311002802House2/12/201910:15:01Call In Missing or Not ApprovedMichelleMMiller@123.orgMiller, MichelleSmith, SeanSalary545Smith, Sean311002802House2/12/201910:15:01Call In Missing or Not ApprovedMichelleMMiller@123.orgMiller, MichelleTompkins, BrianSalary949Tompkins, Brian2/12/20193Calendar Request Pending Approval

<tbody>

</tbody>




Hi Amanda,The below item(s) are outstanding. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.Supervisor NameEmployee NameHourly/SalaryPinLocation No.Location NameDate InTime InDate OutTime OutRequested DateNotesApple, AmandaSmith, JohnHourly600009012Accounting2/6/201912:04:26Call In Missing or Not ApprovedHi Kelli,The below item(s) are outstanding. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.Supervisor NameEmployee NameHourly/SalaryPinLocation No.Location NameDate InTime InDate OutTime OutRequested DateNotesBlacksmith, KelliRogers, AndreaSalary100002000HR2/12/201907:54:55Call Out Missing or Not ApprovedHi George,The below item(s) are outstanding. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.Supervisor NameEmployee NameHourly/SalaryPinLocation No.Location NameDate InTime InDate OutTime OutRequested DateNotesCurry, GeorgeSalem, TravisHourly301002600Warehouse2/11/201913:21:38Call Out Missing or Not ApprovedCurry, GeorgeSalem, TravisHourly102009102Warehouse2/12/201913:16:32Call Out Missing or Not ApprovedHi Michelle,The below item(s) are outstanding withim. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.Supervisor NameEmployee NameHourly/SalaryPinLocation No.Location NameDate InTime InDate OutTime OutRequested DateNotesMiller, MichelleRussell, CoreyHourly102009102Warehouse2/12/201912:33:04Call Out Missing or Not ApprovedMiller, MichelleRussell, CoreySalary311002802House2/12/201910:15:01Call In Missing or Not ApprovedMiller, MichelleSmith, SeanSalary311002802House2/12/201910:15:01Call In Missing or Not ApprovedMiller, MichelleTompkins, BrianSalary2/12/2019Calendar Request Pending Approval

<tbody>

</tbody>


----------



## Fazza (Feb 21, 2019)

What msgbox?? Need to see the code. 

You might have a look at the locals window, too.
Or google to understand arrays.

Or look at the codes posted.
Or germane to your post,
aFieldsToKeep = Array(2, 3, 4, 5, 8, 9, 10, 11, 12, 13, 14, 15, 17)

For i = LBound(aFieldsToKeep) To UBound(aFieldsToKeep)
debug.print i, Columns(aFieldsToKeep(i)
Next i


----------



## Fazza (Feb 21, 2019)

need to fix that last bit of code I posted,

aFieldsToKeep = Array(2, 3, 4, 5, 8, 9, 10, 11, 12, 13, 14, 15, 17)

For i = LBound(aFieldsToKeep) To UBound(aFieldsToKeep)
debug.print i, aFieldsToKeep(i)
Next i


----------



## CyrusTheVirus (Feb 21, 2019)

Hey Fazza,

What I'm asking is if we take the below example the MsgBox pulls 0, 1, 2 when the array is 3, 5, 7. Of Course it correctly takes columns 3, 5, 7 when referencing, but how does it know to pull 3, 5, 7 when it is being delivered 0, 1, 2 ?

Sub ArrayTest()


Dim i As Long
Dim MyArray As Variant


MyArray = Array(3, 5, 7)


For i = LBound(MyArray) To UBound(MyArray)


MsgBox i


Next i


----------



## Fazza (Feb 21, 2019)

MyArray = Array(3, 5, 7)

the elements are addressed,
MyArray(0) - which is 3
MyArray(1) - which is 5
MyArray(2) - which is 7

you can see this in the VBE's (Visual Basic Editor) local windows. if you don't know what this is, please google

Also google to understand arrays

I'll repeat my prior post,

[/code]

```
aFieldsToKeep = Array(2, 3, 4, 5, 8, 9, 10, 11, 12, 13, 14, 15, 17)

For i = LBound(aFieldsToKeep) To UBound(aFieldsToKeep)
debug.print i, aFieldsToKeep(i)
Next i
```


OK?


----------



## CyrusTheVirus (Feb 21, 2019)

Fazza said:


> MyArray = Array(3, 5, 7)
> 
> the elements are addressed,
> MyArray(0) - which is 3
> ...



All good. Thank you for your time Fazza.


----------



## Fazza (Feb 21, 2019)

you're welcome. keep learning!


----------

