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 Items

Body:

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_Table

First Name

Supervisor E-mail Address

Supervisor Name

Employee Name

Hourly/Salary

Employee No.

Employee Info

Location No.

Location Name

Date In

Time In

Date Out

Time Out

Requested Date

Options

Notes

Anne

AApple@123.org

Apple, Amanda

Smith, John

Hourly

1235

Smith, John

600

009012

Accounting

2/6/2019

12:04:26

Call In Missing or Not Approved

Kelli

KBlacksmith@123.org

Blacksmith, Kelli

Rogers, Andrea

Salary

5168

Rogers, Andrea

100

002000

HR

2/12/2019

07:54:55

Call Out Missing or Not Approved

George

GCurry@123.org

Curry, George

Salem, Travis

Hourly

54545

Salem, Travis

301

002600

Warehouse

2/11/2019

13:21:38

Call Out Missing or Not Approved

George

GCurry@123.org

Curry, George

Salem, Travis

Hourly

66464

Salem, Travis

102

009102

Warehouse

2/12/2019

13:16:32

Call Out Missing or Not Approved

Michelle

MMiller@123.org

Miller, Michelle

Russell, Corey

Hourly

848

Russell, Corey

102

009102

Warehouse

2/12/2019

12:33:04

Call Out Missing or Not Approved

Michelle

MMiller@123.org

Miller, Michelle

Russell, Corey

Salary

848

Russell, Corey

311

002802

House

2/12/2019

10:15:01

Call In Missing or Not Approved

Michelle

MMiller@123.org

Miller, Michelle

Smith, Sean

Salary

545

Smith, Sean

311

002802

House

2/12/2019

10:15:01

Call In Missing or Not Approved

Michelle

MMiller@123.org

Miller, Michelle

Tompkins, Brian

Salary

949

Tompkins, Brian

2/12/2019

3

Calendar Request Pending Approval

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 Name	Employee Name	Hourly/Salary	Pin	Location No.	Location Name	Date In	Time In	Date Out	Time Out	Requested Date	Notes
Apple, Amanda	Smith, John	Hourly	600	009012	Accounting			2/6/2019	12:04:26		Call In Missing or Not Approved




Hi 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 Name	Employee Name	Hourly/Salary	Pin	Location No.	Location Name	Date In	Time In	Date Out	Time Out	Requested Date	Notes
Blacksmith, Kelli	Rogers, Andrea	Salary	100	002000	HR	2/12/2019	07:54:55				Call Out Missing or Not Approved




Hi 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 Name	Employee Name	Hourly/Salary	Pin	Location No.	Location Name	Date In	Time In	Date Out	Time Out	Requested Date	Notes
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 withim. If these are already resolved, then please ignore this e-mail. Also, please let me know if you need assistance with this.

Supervisor Name	Employee Name	Hourly/Salary	Pin	Location No.	Location Name	Date In	Time In	Date Out	Time Out	Requested Date	Notes
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

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

Code:

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

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

CyrusTheVirus

Well-known Member

Excel Facts

Fazza

MrExcel MVP

CyrusTheVirus

Well-known Member

Fazza

MrExcel MVP

CyrusTheVirus

Well-known Member

CyrusTheVirus

Well-known Member

Fazza

MrExcel MVP

CyrusTheVirus

Well-known Member

Fazza

MrExcel MVP

CyrusTheVirus

Well-known Member

Forum statistics

Share this page

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

Well-known Member

Excel Facts

MrExcel MVP

Well-known Member

MrExcel MVP

Well-known Member

Well-known Member

MrExcel MVP

Well-known Member

MrExcel MVP

Well-known Member

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock