Function Email(strTo As String, strSubject As String, _
Optional varMsg As Variant, _
Optional varAttachment As Variant)
On Error GoTo ErrHandler
Dim strBCC As String
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim objOutl As Outlook.Application
Dim i As Integer
Set db = CurrentDb
Set rst = db.OpenRecordset("qryContacts", dbOpenSnapshot)
Set objOutl = CreateObject("Outlook.application")
With rst
If .RecordCount > 0 Then
.MoveLast
.MoveFirst
End If
End With
For i = 1 To rst.RecordCount
If Len(rst!EmailAddress) > 0 Then
strTo = rst!EmailAddress
Dim objEml As Outlook.MailItem
Set objEml = objOutl.CreateItem(olMailItem)
With objEml
.To = strTo
.Subject = strSubject
If Not IsNull(varMsg) Then
.Body = varMsg
End If
.Send
End With
End If
Set objEml = Nothing
rst.MoveNext
Next i
ExitHere:
On Error Resume Next
Set objOutl = Nothing
Set rst = Nothing
Set db = Nothing
Exit Function
ErrHandler:
MsgBox Err.Number & ": " & Err.Description
Resume ExitHere
End Function
Function Email2(strgTo As String, strgSubject As String, _
Optional varMesg As Variant, Optional varAttach As Variant)
On Error GoTo Error_Handler
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = strgTo
.Subject = strgSubject
.Body = varMesg
.Attachments.Add "C:\Test.htm"
.Send
End With
Exit_Here:
On Error Resume Next
Set objOutlook = Nothing
Exit Function
Error_Handler:
MsgBox Err.Number & ": " & Err.Description
Resume Exit_Here
End Function