On Error GoTo Error_GenerateOutlookEmailMessage
' Declare Local Constants.
Const strcProcedureName As String = "GenerateOutlookEmailMessage()"
Const strcErrNoHdr As String = "Error Number: "
Const strcErrDescHdr As String = "Error Description: "
Const intcErrMsgStyle As Integer = 48 ' vbOkOnly(0) + vbExclamation(48)
Const strcQuerySQL As String = "SELECT DISTINCTROW tbl_Project_Team_Depts.Business_Unit_Name, tbl_Project_Team_SME.[SME Name], tbl_Project_Team_SME.[SME Number], tbl_Project_Team_SME.[SME Email], tbl_Regions.Region_Abbrev" _
& " FROM tbl_Regions INNER JOIN (((tbl_Project_Team_Depts INNER JOIN tbl_Dept_Assignments ON tbl_Project_Team_Depts.[Dept ID] = tbl_Dept_Assignments.Dept_ID)" _
& " INNER JOIN tbl_Project_Team_SME ON tbl_Dept_Assignments.SME_ID = tbl_Project_Team_SME.ID) INNER JOIN tbl_Region_Assignments ON tbl_Project_Team_SME.ID = tbl_Region_Assignments.SME_ID)" _
& " ON tbl_Regions.[Region ID] = tbl_Region_Assignments.Region_ID WHERE (((tbl_Regions.Region_Abbrev)='"
Const strcQuerySQLClose As String = "'))"
Const strcInputPrompt As String = "Please Enter The Region."
Const strcInputTitle As String = "Region Entry"
Const strcErrInputPrompt As String = "A Region Is Required To Generate Your Data."
Const strcErrInputTitle As String = "Region Input Error"
Const strcEmailSubject As String = "Project Team Roster"
Const strcNoRecsMsgPrompt As String = "No Records Were Found For The Region You Entered."
Const strcNoRecsMsgTitle As String = "No Matching Records"
Const intcNoRecsMsgStyle As Integer = 64 ' vbOkOnly(0) + vbInformation(64)
Const strcAttachMsgPrompt As String = "Would You Like To Attach Results To Your Email Message?"
Const strcAttachMsgTitle As String = "Attach Results"
Const intcAttachMsgStyle As Integer = 36 ' vbYesNo(4) + vbQuestion(32)
Const strcAttachFileName As String = "Project Team Roster.xls"
' Declare Local Variables.
Dim dbCurrent As DAO.Database
Dim qdfTemp As DAO.QueryDef
Dim rstSME As DAO.Recordset
Dim olkApp As Outlook.Application
Dim olkEmail As Outlook.MailItem
Dim olkRecipient As Outlook.Recipient
Dim olkAttachment As Outlook.Attachment
Dim varResult As VbMsgBoxResult
Dim strRegion As String
Dim strSQL As String
Dim strTempFolderPath As String
Dim strFilePathAndName As String
Dim strRecipient As String
Dim strTempQDefName As String
' Prompt User To Enter The Region Required By The Query.
strRegion = InputBox(strcInputPrompt, strcInputTitle)
' Check The Length Of The User Input Region To Verify A Value Was Entered.
If Len(strRegion) > 0 Then
' Concatenate The SQL Code To Include The User Input Region Value.
strSQL = strcQuerySQL & strRegion & strcQuerySQLClose
' Set Our Database Object Varaible To An Instance Of The Current Database.
Set dbCurrent = CurrentDb()
' Verify We Successfully Created An Instance Of The Database Object.
If Not dbCurrent Is Nothing Then
' Call "GenerateTempName()" Function To Return A Randomly Generated Temporary File Name.
' We Are Using This Methodology To Avoid Errors Associated With Using A Static QueryDef Name
' In A Multi-User Environment Where The Temporary QueryDef May Have Already Been Generated By Another User.
strTempQDefName = GenerateTempName
' Check The Length Of The Value Stored In Our Local Temp Query Def Name String Variable
' To Verify The "GenerateTempName()" Function Successfully Returned A Temp File Name.
If Len(strTempQDefName) > 0 Then
' The "GenerateTempName()" Function Returns A Temporary File Name With An ".tmp" File Extension.
' To Use This As A Temporary QueryDef Name, We Will Need To Strip Out The File Extension.
If InStr(1, strTempQDefName, Chr$(46), vbBinaryCompare) Then
' Strip Out The Temporary File Extension From The Randomly Generated Temporary File Name.
strTempQDefName = Left$(strTempQDefName, InStr(1, strTempQDefName, Chr$(46), vbBinaryCompare) - 1)
End If
' Set Our QueryDef Object To An Instance Of Our Dynamically Generated SQL Query.
Set qdfTemp = dbCurrent.CreateQueryDef(strTempQDefName, strSQL)
' Verify We Successfully Created An Instance Of The QueryDef Object.
If Not qdfTemp Is Nothing Then
' Set Our Recordset To An Instance Of The Recordset Returned From Our Temporary QueryDef Object.
Set rstSME = dbCurrent.OpenRecordset(qdfTemp.Name)
' Verify We Successfully Created An Instance Of The Recordset Returned From Our QueryDef Object.
If Not rstSME Is Nothing Then
With rstSME
' If Our Recordset Contains At Least One Record,
If Not .BOF And Not .EOF Then
' Set Our Outlook Object Variable To A New Instance Of The Outlook Application Object.
Set olkApp = New Outlook.Application
' Verify We Successfully Created An Instance Of The Outlook Application Object.
If Not olkApp Is Nothing Then
' Set Our Outlook Mail Item Object Variable To A New Instance Of The Mail Item Object.
Set olkEmail = olkApp.CreateItem(olMailItem)
' Verify We Successfully Created A New Instance Of The New Mail Item Object.
If Not olkEmail Is Nothing Then
' Display Message Box To User Asking The User Whether To Attach A File Containing The
' Recordset Returned From Our Temporary Query Def Object To This Email.
varResult = MsgBox(strcAttachMsgPrompt, intcAttachMsgStyle, strcAttachMsgTitle)
' If User Elected To Attach The Results, As A File, To This Email,
If varResult = vbYes Then
' Add A Default Subject Line To The Email Message.
olkEmail.Subject = strcEmailSubject
' Call The "GetTempFolderPath()" To Return The Path To The Current User's Temp Folder.
' Assign This Value To Our Local String Variable.
strTempFolderPath = GetTempFolderPath
' Check The Length Of The Value Stored In Our Lcoal String Variable To Verify
' The "GetTempFolderPath()" Function Successfully Returned The Path To The User's Temp Folder.
If Len(strTempFolderPath) > 0 Then
' Concatenate The Current User's Temp Folder Path To The Attachment's File Name & Extension.
strFilePathAndName = strTempFolderPath & Chr$(92) & strcAttachFileName
' Call The "FileExists()" Function To Determine Whether The Temporary Attachment File
' Already Exists In The User's Temp Folder.
If FileExists(strFilePathAndName) Then
' The Temporary Spreadsheet File Already Exists From An Earlier Run.
' Call The "DeleteFile()" Function To Delete The Existing Spreadsheet File.
DeleteFile strFilePathAndName, True
End If
' Call The "FileExists()" Function To Verify Any Existing Spreadsheet File Was Successfully Deleted.
If Not FileExists(strFilePathAndName) Then
' Execute The "TransferSpreadsheet()" Method To Save The Recordset Returned From Our Temporary
' Query Def Object To An Excel Spreadsheet In The Current User's Temp Folder.
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, rstSME.Name, strFilePathAndName, True
' Call The "FileExists()" Function To Verify Our Temporary Excel Spreadsheet File Was
' Successfully Created In The User's Temp Folder.
If FileExists(strFilePathAndName) Then
' The Excel Spreadsheet File Was Successfully Created In The User's Temp File.
' Set Our Outlook Attachment Object Variable To An Instance Of The Newly Created Excel File.
' This Attaches The Excel File To Our Email Message.
Set olkAttachment = olkEmail.Attachments.Add(strFilePathAndName)
' Now That The Excel File Has Already Been Attached To The Email Message, We No
' Longer Need To Keep The Temporary Excel File. Clean Up By Deleting The Excel File
' From The Current User's Temp Folder.
DeleteFile strFilePathAndName, True
End If
End If
End If
End If
' We Are Going To Step Through Each Record In The Recordset Returned From Our Temporary Query Def Object.
' Move To The First Record In The Resulting Recordset Object.
.MoveFirst
' While We Have Records To Process...
While Not .EOF
' Assign The Value Of The Current Record's "SME Email" Field, Containing An Email Address, To Our Local String Variable.
strRecipient = rstSME![SME Email]
' Check The Length Of The Value To Ensure We Have A Value, Email Address, To Process.
If Len(strRecipient) > 0 Then
' We Have An Email Address To Add To The Email Message.
' Set Our Outlook Recipient Object To An Instance Of The Current Email Address Returned From Our Recordset.
Set olkRecipient = olkEmail.Recipients.Add(strRecipient)
' Verify We Successfully Created An Instance Of The Recipient Object.
If Not olkRecipient Is Nothing Then
' Set The Recipient Object's "Type" Property As Type "To".
olkRecipient.Type = olTo
End If
' Clear The Current Email Address From Our Local String Variable To Prepare For The Next Record In The Recordset.
strRecipient = vbNullString
End If
' Move To The Next Record In The Recordset.
.MoveNext
Wend
' We Have Finished Processing All Records In The Recordset.
' Delete The Temporary QueryDef Object From The QueryDefs Collection.
dbCurrent.QueryDefs.Delete qdfTemp.Name
' Refresh The QueryDef Collection To Reflect The Deletion Of The Temporary QueryDef Object.
dbCurrent.QueryDefs.Refresh
' Step Through Each Recipient Object In The Recipients Collection.
For Each olkRecipient In olkEmail.Recipients
' Resolve Each Email Address In Our Email Message.
olkRecipient.Resolve
Next olkRecipient
' Display The Newly Generated Email Message On The User's Screen.
olkEmail.Display
' Save The Newly Generated Email.
olkEmail.Save
'olkemail.Send ' **** Uncomment This Line If You Want The Email Sent Automatically Without User Interaction.
End If ' **** Otherwise The User Will Still Need To Click On The Send Button.
End If
Else
' No Matching Records. Display Message To User & Exit.
MsgBox strcNoRecsMsgPrompt, intcNoRecsMsgStyle, strcNoRecsMsgTitle
End If
End With
End If
End If
End If
End If
Else
' User Did Not Enter A Region. Display Message To User & Exit Function.
MsgBox strcErrInputPrompt, intcErrMsgStyle, strcErrInputTitle
End If
' Procedure Exit Point.
Exit_GenerateOutlookEmailMessage:
' Destroy Local Object Variables To Reclaim The Memory Used To Create Them.
If Not qdfTemp Is Nothing Then
Set qdfTemp = Nothing
End If
If Not rstSME Is Nothing Then
Set rstSME = Nothing
End If
If Not dbCurrent Is Nothing Then
Set dbCurrent = Nothing
End If
If Not olkAttachment Is Nothing Then
Set olkAttachment = Nothing
End If
If Not olkRecipient Is Nothing Then
Set olkRecipient = Nothing
End If
If Not olkEmail Is Nothing Then
Set olkEmail = Nothing
End If
If Not olkApp Is Nothing Then
Set olkApp = Nothing
End If
' Exit Procedure.
Exit Sub
' Procedure Error Handling.
Error_GenerateOutlookEmailMessage:
If Err.Number <> 0 Then
' Display Error Message To User.
MsgBox strcErrNoHdr & CStr(Err.Number) & vbCrLf & strcErrDescHdr & Err.Description, intcErrMsgStyle, strcProcedureName
' Clear Err Object Properties.
Err.Clear
' Resume Execution To Procedure's Exit Point.
Resume Exit_GenerateOutlookEmailMessage
Else
' Error Number Zero Is Not A Valid Error.
' Resume Execution To Next Line Of Code.
Resume Next
End If
End Sub
