Private Sub cmdEmail_Click()
On Error GoTo ErrHandler
Dim rsEmail As DAO.Recordset
Dim oItem As Outlook.MailItem
Dim Datarange As Recipients
Dim oOutlookApp As Outlook.Application
Dim oDoc As Word.Application
Dim objInsp As Outlook.Inspector
Dim strMessage
If IsNull(Me.fPath) Or IsNull(Me.selLetter) Then
MsgBox "Both documents are required for the E-mail mailing.", vbOKOnly, "Both Required"
Exit Sub
Else
DoCmd.SetWarnings False
Kill "c:\Export\MergeEmail.xls"
DoCmd.OpenQuery "qryDM-Export-Cases-Email", acViewNormal
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "LL-MergeEmail", "c:\Export\MergeEmail.xls"
End If
message = "Enter the subject to be used for each e-mail message."
Title = "Email Subject"
mysubject = InputBox(message, Title)
If mysubject = "" Then
MsgBox "You cancelled the process, or subject not completed.", vbInformation + vbOKOnly, "Information"
Exit Sub
End If
Set oOutlookApp = GetObject(, "Outlook.Application")
DoCmd.Hourglass True
Set oDoc = CreateObject("Word.Application")
oDoc.Documents.Open ("C:\Export\" & Me.selLetter.Value & ".doc")
Set rsEmail = CurrentDb.OpenRecordset("ll-mergeEmail")
Do While Not rsEmail.EOF
oDoc.ActiveDocument.MailMerge.Check
If IsNull(oDoc.ActiveDocument.MailMerge) Then
GoTo MergeError
End If
Set oItem = oOutlookApp.CreateItem(olMailItem)
strMessage = oDoc.ActiveDocument.Content
With oItem
.Subject = mysubject
.Body = strMessage
.To = rsEmail.Fields("[Email Addr]").Value
.Attachments.Add Me.fPath.Value, olByValue, 1, mysubject & "Attachment"
.Display
End With
rsEmail.MoveNext
oDoc.ActiveDocument.MailMerge.ViewMailMergeFieldCodes = False
oDoc.ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
Loop
oDoc.Documents.Close (False)
oDoc.Application.Quit (False)
Set rsEmail = Nothing
Set oLetter = Nothing
Set oDoc = Nothing
Set oItem = Nothing
DoCmd.Hourglass False
DoCmd.OpenForm "frmDM-Contact-History"
Exit Sub
ErrHandler:
DoCmd.Hourglass False
If Err.Number = 5174 Then
MsgBox "File selected could not be found.", vbOKOnly, "File Error"
Else
If Err.Number = 4198 Then
oDoc.Quit (False)
MsgBox "You cancelled the opening of the document.", vbOKOnly, "User Cancelled"
End If
If Err.Number = 4605 Then
MsgBox "You have selected an Email template which is not a merge document." & Chr(13) & Chr(10) & _
"Please check and try again.", vbExclamation + vbOKOnly, "No Merge Fields"
oDoc.Documents.Close (False)
oDoc.Application.Quit (False)
Set rsEmail = Nothing
Set oLetter = Nothing
Set oDoc = Nothing
Set oItem = Nothing
DoCmd.Hourglass False
End If
End If
Exit Sub
MergeError:
If Err.Number = 4605 Then
MsgBox "You cancelled the process.", vbOKOnly, "User Cancelled"
oDoc.Documents.Close (False)
oDoc.Application.Quit (False)
Set rsEmail = Nothing
Set oLetter = Nothing
Set oDoc = Nothing
Set oItem = Nothing
DoCmd.Hourglass False
Else
If Err.Number = 53 Then
Resume Next
End If
End If
oDoc.Documents.Close (False)
oDoc.Application.Quit (False)
Set rsEmail = Nothing
Set oLetter = Nothing
Set oDoc = Nothing
Set oItem = Nothing
DoCmd.Hourglass False
End Sub
