Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

send multiple mails

Access Howto:

send multiple mails

by  hermanlaksko  Posted    (Edited  )
The whole thing is controled via a form, one table and the below incl. code. You do not need to make any refrences to run the code.

I drop all recipients into my table and mail from this table: MergeMail.

First make a form in order to control the mail. The form should be made as a continues form, showing all recipiants. The form header should incl. a button to enable users to browse for attachments, choose importance of the mail and how to show the "To"-names in the actual mail i.e. to/cc/bcc. And last but not least the "SendPost"-button.

Last I have incl. the function IsBlank, this is a function that I use frequently in all my apps it checks for missing/isnull/isempty etc. and with success .... so far ;-)

Private Sub SendPost_Click()
On Error GoTo Err_cmdSend_Click
Dim Re as DAO.Recordset

Set Re = CurrentDb.OpenRecordset("Select * From MergeMail Where Email Is not null")
If Re.RecordCount = 0 Then
MsgBox "No recipients was found.", vbCritical + vbOKOnly, "YourAppName"
Exit Sub
End If
Do While Not Re.EOF
SRecept = SRecept & Re!PName & "<" & Re!Email & ">; "
CountOf = CountOf + 1
Re.MoveNext
Loop
SRecept = Left(SRecept , Len(SRecept ) - 2)
bOK = SendMailMB(SRecept ie. "Herman Laksko <some@email.com>" , strFrom, Frm.Subject, Frm.EM_Text, strCC, strBCC, strReplyTo, strAttachment, "", Me!Priority, Me!HTML)
Exit_cmdSend_Click:
Exit Sub
Err_cmdSend_Click:
MsgBox Err.Description
Resume Exit_cmdSend_Click
End Sub

'This does the actual mailing
Function SendMailMB(sTo As String, _
sFrom As String, _
sSubject As String, _
sBody As String, _
Optional sCC As Boolean, _
Optional sBCC As Boolean, _
Optional sReplyTo As String = "", _
Optional sAttachment As String = "", _
Optional sAttachmentAlias As String = "", _
Optional sPriority As Integer = 1, _
Optional sHTML As Boolean) As Boolean
On Error GoTo Fejl 'Resume Next
Dim CCOk As Boolean, objEmail As Object,sSMTP
Set objEmail = CreateObject("CDO.Message")

objEmail.From = sFrom
If sCC Then
objEmail.CC = sTo
CCOk = True
ElseIf sBCC Then
objEmail.BCC = sTo
CCOk = True
End If
If Not IsBlank(sTo) And Not CCOk Then objEmail.To = sTo
objEmail.Fields("urn:schemas:httpmail:importance").Value = sPriority
objEmail.Fields.Update 'opdates priority Hmmm objEmail.Subject = sSubject
If sHTML Then objEmail.HTMLBody = sBody Else objEmail.Textbody = sBody

Set Re = CurrentDb.OpenRecordset("SELECT * FROM AttFiles Where FileID <> '001'", dbOpenDynaset)
If Re.RecordCount > 0 Then
Do While Not Re.EOF
If Not IsBlank(Re!FilName) Then objEmail.AddAttachment Re!FilName
Re.MoveNext
Loop
End If
sSMTP=Dlookup("YrSmtpAdd","YrTbl")
If Not IsNull(sSMTP) Then
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'Name or IP of remote SMTP server
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver")= sSMTP
'Server port
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Update
end if
objEmail.Send
If Err Then SendMailMB = False Else SendMailMB = True
FejlExit:
Exit Function
Fejl:
MsgBox Err.Description, , "YrAppName"
Resume FejlExit
End Function

Function IsBlank(V As Variant) As Boolean
On Error Resume Next
V = "" & V
If Len(V) = 0 Then IsBlank = True
End Function
Register to rate this FAQ  : BAD 1 2 3 4 5 6 7 8 9 10 GOOD
Please Note: 1 is Bad, 10 is Good :-)

Part and Inventory Search

Back
Top