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
This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
By continuing to use this site, you are consenting to our use of cookies.