INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Jobs

Access Howto:

send multiple mails by hermanlaksko
Posted: 22 Feb 05 (Edited 14 Feb 07)

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 winky smile

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

Back to Microsoft: Access Other topics FAQ Index
Back to Microsoft: Access Other topics Forum

My Archive

Resources

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close