Option Compare Database
Option Explicit
Dim mstrNotSent As String
Dim mstrEmailInvalid As String
Const mcn_strMODULE = "frm_MergeToOutlook"
Private Sub cmdMerge_Click()
Const cn_strPROCEDURE = "cmdMerge_Click"
On Error GoTo ErrHandler
If Nz(Me.lstDataSource, "") = "" Or _
Me.lstDataSource = "<<<TABLES>>>" Or _
Me.lstDataSource = "<<<QUERIES>>>" Then
MsgBox "You must select the table or query " & vbCrLf & _
"to act as the data source for the mailmerge", vbInformation, _
"No Data Source"
Else
If Nz(Me.lstEmailField, "") = "" Then
MsgBox "You must select the name of field containing " & vbCrLf & _
"the email address", vbInformation, "No Field Selected"
Else
If Nz(Me.txtMergeDoc, "") = "" Then
MsgBox "You must select the Microsoft Word document " & vbCrLf & _
"you want to merge to", vbInformation, "No Merge Document"
Else
If Dir(Me.txtMergeDoc, vbNormal) = "" Then
MsgBox "The Microsoft Word document cannot" & vbCrLf & _
"be found in this location.", vbInformation, _
"File Note Found"
Else
If Nz(Me.txtEmailSubject, "") = "" Then
MsgBox "You must enter the Subject line of your email", _
vbInformation, "No Subject"
Else
If PerformMailMerge() = True Then
If mstrNotSent <> "" Then
MsgBox "Your mailmerge was NOT successful." & _
vbCrLf & "The following emails received an error:" & _
vbCrLf & vbCrLf & mstrNotSent, vbExclamation, _
"Error Sending Emails"
Else
If mstrEmailInvalid <> "" Then
MsgBox "Your mailmerge is completed and has been " & _
vbCrLf & "emailed, with the exception of the " & _
"following recipients:" & vbCrLf & vbCrLf & _
mstrEmailInvalid & vbCrLf & "Please check that " & _
"these email addresses are valid.", vbInformation, _
"Mailmerge Complete with Exceptions"
Else
MsgBox "Your mailmerge is completed and has been " & _
vbCrLf & "emailed to all recipients", vbInformation, _
"Mailmerge Complete"
End If
End If
Else
MsgBox "Your mailmerge was NOT successful." & _
vbCrLf & "Please check the Send Items in Outlook" & _
vbCrLf & "to check which emails have been sent.", _
vbExclamation, "Mailmerge NOT Completed"
End If
End If
End If
End If
End If
End If
ExitHere:
DoCmd.Hourglass False
Exit Sub
ErrHandler:
MsgBox Err.Number & ": " & Err.Description, vbCritical, _
"Unexpected Error in " & mcn_strMODULE & "." & cn_strPROCEDURE
Resume ExitHere
End Sub
Private Sub cmdOpenDoc_Click()
Me.txtMergeDoc = GetOpenFile(GetDefaultPath(), "Select Word document for mail merge")
End Sub
Private Sub Form_Load()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim qdf As DAO.QueryDef
Const cn_strPROCEDURE = "Form_Load"
On Error GoTo ErrHandler
Me.lstDataSource.RowSource = "<<<TABLES>>>;"
Set db = CurrentDb
For Each tdf In db.TableDefs
If LCase(Left(tdf.Name, 4)) <> "msys" Then
Me.lstDataSource.RowSource = Me.lstDataSource.RowSource & tdf.Name & ";"
End If
Next tdf
Me.lstDataSource.RowSource = Me.lstDataSource.RowSource & "<<<QUERIES>>>;"
For Each qdf In db.QueryDefs
If Left(qdf.Name, 1) <> "~" Then
Me.lstDataSource.RowSource = Me.lstDataSource.RowSource & qdf.Name & ";"
End If
Next qdf
ExitHere:
On Error Resume Next
qdf.Close
db.Close
Set tdf = Nothing
Set qdf = Nothing
Set db = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Number & ": " & Err.Description, vbCritical, _
"Unexpected Error in " & mcn_strMODULE & "." & cn_strPROCEDURE
Resume ExitHere
End Sub
Private Sub cmdClose_Click()
On Error GoTo Err_cmdClose_Click
DoCmd.Close
Exit_cmdClose_Click:
Exit Sub
Err_cmdClose_Click:
MsgBox Err.Description
Resume Exit_cmdClose_Click
End Sub
Private Sub lstDataSource_Click()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim qdf As DAO.QueryDef
Dim fld As DAO.Field
Const cn_strPROCEDURE = "lstDataSource_Click"
Me.lstEmailField.RowSource = ""
On Error GoTo ErrHandler
Select Case Nz(Me.lstDataSource, "")
Case "", "<<<TABLES>>>", "<<<QUERIES>>>"
Case Else
Set db = CurrentDb
On Error Resume Next
Set tdf = db.TableDefs(Me.lstDataSource)
If Err.Number = 0 Then
On Error GoTo ErrHandler
For Each fld In tdf.Fields
Me.lstEmailField.RowSource = Me.lstEmailField.RowSource & fld.Name & ";"
Next fld
Else
On Error GoTo ErrHandler
Set qdf = db.QueryDefs(Me.lstDataSource)
For Each fld In qdf.Fields
Me.lstEmailField.RowSource = Me.lstEmailField.RowSource & fld.Name & ";"
Next fld
End If
End Select
ExitHere:
On Error Resume Next
qdf.Close
db.Close
Set fld = Nothing
Set tdf = Nothing
Set qdf = Nothing
Set db = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Number & ": " & Err.Description, vbCritical, _
"Unexpected Error in " & mcn_strMODULE & "." & cn_strPROCEDURE
Resume ExitHere
End Sub
Function PerformMailMerge() As Boolean
Dim objWord As Word.Application
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strSQL As String
Dim strMergeDoc As String
Const cn_strPROCEDURE = "PerformMailMerge"
DoCmd.Hourglass True
On Error GoTo ErrHandler
strSQL = "SELECT * " & _
"FROM [" & Me.lstDataSource & "] " & _
"WHERE [" & Me.lstEmailField & "] Is Not Null"
Set db = CurrentDb
Set rec = db.OpenRecordset(strSQL, dbOpenSnapshot)
strMergeDoc = Me.txtMergeDoc
If Not rec.EOF Then
Set objWord = CreateObject("Word.Application")
With objWord
.Documents.Open strMergeDoc
With .ActiveDocument.MailMerge
.OpenDataSource Name:=db.Name, LinkToSource:=True, _
Connection:="TABLE " & Me.lstDataSource, SQLStatement:= _
strSQL
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
Do Until rec.EOF
With .DataSource
.QueryString = strSQL & " AND [" & Me.lstEmailField & "] =" & _
Chr(34) & rec(Me.lstEmailField) & Chr(34)
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=True
SendMergeEmail objWord, strMergeDoc, rec(Me.lstEmailField)
objWord.Windows(strMergeDoc).Activate
rec.MoveNext
Loop
End With
.Windows(strMergeDoc).Activate
.ActiveDocument.Close False
.Quit
End With
End If
PerformMailMerge = True
ExitHere:
On Error Resume Next
rec.Close
db.Close
Set rec = Nothing
Set db = Nothing
Set objWord = Nothing
Exit Function
ErrHandler:
MsgBox Err.Number & ": " & Err.Description, vbCritical, _
"Unexpected Error in " & mcn_strMODULE & "." & cn_strPROCEDURE
Resume ExitHere
End Function
Sub SendMergeEmail(objWord As Word.Application, strMergeDoc As String, _
strTo As String)
Dim objOL As Outlook.Application
Dim objML As Outlook.MailItem
Dim strPath As String
Const cn_strPROCEDURE = "SendMergeEmail"
On Error GoTo ErrHandler
strMergeDoc = Mid(strMergeDoc, InStrRev(strMergeDoc, "\") + 1)
With objWord
.DisplayAlerts = wdAlertsNone
.ActiveDocument.MailMerge.MainDocumentType = wdNotAMergeDocument
.ActiveDocument.SaveAs GetDefaultPath() & "t" & strMergeDoc
.DisplayAlerts = wdAlertsAll
.ActiveDocument.Close
End With
On Error Resume Next
Set objOL = GetObject("", "Outlook.Application")
If Err.Number <> 0 Then
Set objOL = CreateObject("Outlook.Application")
End If
On Error GoTo ErrHandler
Set objML = objOL.CreateItem(olMailItem)
With objML
.To = strTo
If .Recipients.ResolveAll = True Then
.Subject = Me.txtEmailSubject
.Attachments.Add GetDefaultPath() & "t" & strMergeDoc
.ReadReceiptRequested = Me.chkReadReceipt
.OriginatorDeliveryReportRequested = Me.chkDeliveryReceipt
Select Case Me.cboImportance
Case 1: .Importance = olImportanceHigh
Case 2: .Importance = olImportanceNormal
Case 3: .Importance = olImportanceLow
End Select
If Me.chkDisplay = True Then
.Display
Else
.Send
End If
Else
mstrEmailInvalid = mstrEmailInvalid & vbTab & strTo & vbCrLf
.Close (olDiscard)
End If
End With
On Error Resume Next
Kill GetDefaultPath() & "t" & strMergeDoc
ExitHere:
On Error Resume Next
Set objML = Nothing
Set objOL = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Number & ": " & Err.Description, vbCritical, _
"Unexpected Error in " & mcn_strMODULE & "." & cn_strPROCEDURE
mstrNotSent = mstrNotSent & vbTab & strTo & vbCrLf
Resume ExitHere
End Sub
Function GetDefaultPath() As String
GetDefaultPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\"))
End Function
|