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
