This VBA questionnaire and integrated email ensures that the plans and reports sent out are consistent and the information has been checked. It can easily be modified to suit any application. I hope you find it useful, and please leave a comment if you implement this in your work!
I’m sharing the Excel file (you will need to re-enable macros for it to work) and also further down you can copy the VBA code directly into your own macros for use and modification.
Download Zip file below for the Excel file:
The “Send Draft Email” macro is as follows:
Sub Draft_Email()
Dim Msg, Style, Title, Help, Ctxt, Response, MyString, dtToday As Date
Dim OutApp As Object
Dim Outmail As Object
Dim strbody As String
Dim MakeJPG As String
Dim Signature As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
dtToday = Date
'Series of questions to validate plan
'Question 1.
Msg = "Are there any upcoming weather events?" ' Define message.
Style = vbYesNoCancel ' Define buttons.
Title = "Grader Plan Check" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic context.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' User chose Yes.
MyString = "Yes" ' Perform some action.
ElseIf Response = vbNo Then ' User chose No.
MyString = "No" ' Perform some action.
ElseIf Response = vbCancel Then
Exit Sub
End If
'Question 2.
Msg = "Do the planned tonnes match the daily mining plan?" ' Define message.
Style = vbYesNoCancel ' Define buttons.
Title = "Grader Plan Check" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic context.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' User chose Yes.
MyString = "Yes" ' Perform some action.
ElseIf Response = vbNo Then ' User chose No.
MyString = "No" ' Perform some action.
ElseIf Response = vbCancel Then
Exit Sub
End If
'Question 3.
Msg = "Is Fleet NOH >= Planned Required NOH?" ' Define message.
Style = vbYesNoCancel ' Define buttons.
Title = "Grader Plan Check" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic context.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' User chose Yes.
MyString = "Yes" ' Perform some action.
ElseIf Response = vbNo Then ' User chose No.
MyString = "No" ' Perform some action.
ElseIf Response = vbCancel Then
Exit Sub
End If
'This section generates the email
Dim rngToPicture As Range
Dim outlookApp As Object
Dim strTempFilePath As String
Dim strTempFileName As String
Dim strTo As String
Dim strSubject As String
Const olMailItem = 0
Const olByValue = 1
'Name it anything, doesn't matter
strTempFileName = "RangeAsPNG"
'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
Set rngToPicture = Range("rngToPicture")
Set outlookApp = CreateObject("Outlook.Application")
Set Outmail = outlookApp.CreateItem(olMailItem)
'Create an email
strbody = "Hello Team," & "<br><br>" & _
"Please review daily grading plan below and provide feedback." & "<br>" & _
"If you need more information let me know." & "<br><br>" & _
"Regards Short Range Planning Team <br><br>"
With Outmail
.To = ""
.CC = ""
.Subject = "Grader Daily Plan " & dtToday
'Create the range as a PNG file and store it in temp folder
Call createPNG(rngToPicture, strTempFileName)
'Embed the image in Outlook
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
'.Attachments.Add strTempFilePath, 1, 0
'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
.HTMLBody = "<html><p>" & strbody & "<img src= '" & strTempFilePath & "' style='border:0'>"
'replace with .Send if you want to send email without viewing first.
.Display
End With
Set Outmail = Nothing
Set outlookApp = Nothing
Set rngToPicture = Nothing
End Sub
'This sub creates the image which is then embedded in the email
Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
Dim wksName As String
wksName = rngToPicture.Parent.Name
'Delete the existing PNG file of same name, if exists
On Error Resume Next
Kill Environ$("temp") & "\" & nameFile & ".png"
On Error GoTo 0
'Copy the range as picture
rngToPicture.CopyPicture
'Paste the picture in Chart area of same dimensions
With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
.Activate
.Chart.Paste
'Export the chart as PNG File to Temp folder
.Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
End With
Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete
End Sub
The “Draft Email VBA Code with random generator” macro is as follows:
Sub DraftRandomQuotes_Click()
Dim Msg, Style, Title, Help, Ctxt, Response, MyString, dtToday As Date
Dim OutApp As Object
Dim Outmail As Object
Dim strbody As String
Dim MakeJPG As String
Dim Signature As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'this assigns today's value for the date when sending out the email with a date field
dtToday = Date
'Series of questions to validate plan
'Question 1.
Msg = "Are there any upcoming weather events?" ' Define message.
Style = vbYesNoCancel ' Define buttons.
Title = "Grader Plan Check" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic context.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' User chose Yes.
MyString = "Yes" ' Perform some action.
ElseIf Response = vbNo Then ' User chose No.
MyString = "No" ' Perform some action.
ElseIf Response = vbCancel Then
Exit Sub
End If
'Question 2.
Msg = "Do the planned tonnes match the daily mining plan?" ' Define message.
Style = vbYesNoCancel ' Define buttons.
Title = "Grader Plan Check" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic context.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' User chose Yes.
MyString = "Yes" ' Perform some action.
ElseIf Response = vbNo Then ' User chose No.
MyString = "No" ' Perform some action.
ElseIf Response = vbCancel Then
Exit Sub
End If
'Question 3.
Msg = "Is Fleet NOH >= Planned Required NOH?" ' Define message.
Style = vbYesNoCancel ' Define buttons.
Title = "Grader Plan Check" ' Define title.
Help = "DEMO.HLP" ' Define Help file.
Ctxt = 1000 ' Define topic context.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' User chose Yes.
MyString = "Yes" ' Perform some action.
ElseIf Response = vbNo Then ' User chose No.
MyString = "No" ' Perform some action.
ElseIf Response = vbCancel Then
Exit Sub
End If
'You can keep copying the format above to add more questions
'Bonus section- random quote generator, makes you look forward to generating the plan!
Dim strQuotes(4) As String
Dim lngIndex As Long
strQuotes(0) = "Mines are what happens while you're making other plans" & vbNewLine & "-Andreas Steckenborn"
strQuotes(1) = "Never rest on your ores" & vbNewLine & "-Norman B. Keevil"
strQuotes(2) = "Plans are of little importance, but planning is essential" & vbNewLine & "-Eisenhower"
strQuotes(3) = "...Insert shameless plug for S-Teck Mining Consulting Ltd. here..."
strQuotes(4) = "Be not simply good- be good for something" & vbNewLine & " -Thoreau"
lngIndex = Int((4 - 0 + 1) * Rnd + 0)
MsgBox strQuotes(lngIndex)
'This section generates the email
Dim rngToPicture As Range
Dim outlookApp As Object
Dim strTempFilePath As String
Dim strTempFileName As String
Dim strTo As String
Dim strSubject As String
Const olMailItem = 0
Const olByValue = 1
'Name it anything, doesn't matter
strTempFileName = "RangeAsPNG"
'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
Set rngToPicture = Range("rngToPicture")
Set outlookApp = CreateObject("Outlook.Application")
Set Outmail = outlookApp.CreateItem(olMailItem)
'Create an email
strbody = "Hello Team," & "<br><br>" & _
"Please review daily grading plan below and provide feedback." & "<br>" & _
"If you need more information let me know." & "<br><br>" & _
"Regards Short Range Planning Team <br><br>"
With Outmail
.To = ""
.CC = ""
.Subject = "Grader Daily Plan " & dtToday
'Create the range as a PNG file and store it in temp folder
Call createPNG(rngToPicture, strTempFileName)
'Embed the image in Outlook
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
'.Attachments.Add strTempFilePath, 1, 0
'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
.HTMLBody = "<html><p>" & strbody & "<img src= '" & strTempFilePath & "' style='border:0'>"
.Display
End With
Set Outmail = Nothing
Set outlookApp = Nothing
Set rngToPicture = Nothing
End Sub
'This sub creates the image which is then embedded in the email
Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
Dim wksName As String
wksName = rngToPicture.Parent.Name
'Delete the existing PNG file of same name, if exists
On Error Resume Next
Kill Environ$("temp") & "\" & nameFile & ".png"
On Error GoTo 0
'Copy the range as picture
rngToPicture.CopyPicture
'Paste the picture in Chart area of same dimensions
With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
.Activate
.Chart.Paste
'Export the chart as PNG File to Temp folder
.Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
End With
Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete
End Sub