Send Email with button click on Access Form using CDO

[FNA access]

I have read through many posts that are relevant to my topic and have not had any success.

I want to click a button on my form and send an email to a list of people I have stored in a table with email addresses.

My SMTP server uses many defaults(ie port, timeout) I have been asked to leave the defaults alone, if possible.

Here is a copy of my code that I am trying to run. In my button click I call the first function:

Public Function EmailAlert() As Boolean
On Error Resume Next
Stop
Dim db As DAO.Database, rst As DAO.Recordset, sSQL As String
Dim Subjectstr As String, Bodystr As String, SendToVar As String
 
Set db = CurrentDb
 
Set rst = db.OpenRecordset("EmailAlertQuery", dbOpenForwardOnly)
 
If Not rst.EOF And Not rst.BOF Then
   rst.MoveFirst
 
    Bodystr = "DATE : " & Format(rst!AlertDate, "Long date") & vbCrLf & vbCrLf
    Bodystr = Bodystr & "Duty Officer: " & rst!DutyOfficer & vbCrLf & vbCrLf
    Subjectstr = "Alert For " & Format(rst!AlertDate, "Long Date")
 
    Do Until rst.EOF
 
    Bodystr = Bodystr & "TankerBase: " & rst!TankerBase & vbCrLf
    If rst!FCPC <> "" And Not IsNull(rst!FCPC) Then
       Bodystr = Bodystr & "Fire Center PC: " & rst!FCPC & vbCrLf
    End If
    If rst!BirddogID <> "" And Not IsNull(rst!BirddogID) Then
        Bodystr = Bodystr & "Birddog: " & rst!BirddogID & vbCrLf
    End If
    If rst!AirtankerID <> "" And Not IsNull(rst!AirtankerID) Then
        Bodystr = Bodystr & "Airtankers: " & rst!AirtankerID & vbCrLf
        Bodystr = Bodystr & "Type: " & rst!Type & vbCrLf
    End If
    If rst!Green <> "" And Not IsNull(rst!Green) Then
        Bodystr = Bodystr & "Green: " & rst!Green & vbCrLf
    End If
    If rst!Blue <> "" And Not IsNull(rst!Blue) Then
        Bodystr = Bodystr & "Blue: " & rst!Blue & vbCrLf
    End If
    If rst!Yellow <> "" And Not IsNull(rst!Yellow) Then
        Bodystr = Bodystr & "Yellow: " & rst!Yellow & vbCrLf
    End If
    If rst!Red <> "" And Not IsNull(rst!Red) Then
        Bodystr = Bodystr & "Red: " & rst!Red & vbCrLf
    End If
    If rst!AlertEnd <> "" And Not IsNull(rst!AlertEnd) Then
        Bodystr = Bodystr & "Alert End: " & rst!AlertEnd & vbCrLf
    End If
    Bodystr = Bodystr & vbCrLf
    rst.MoveNext
    Loop
 
Else
    MsgBox " You have not entered an Alert for Today yet."
End If
 
Set rst = Nothing
Set rst = db.OpenRecordset("EmailAddressListQuery", dbOpenForwardOnly)
 
If Not rst.EOF And Not rst.BOF Then
    rst.MoveFirst
 
    Do Until rst.EOF
        SendToVar = SendToVar & rst!EmailAddress & ";"
        rst.MoveNext
    Loop
End If
 
Call SendEMail_CDO("PATCCORP", SendToVar, "chriwill", Subjectstr, Bodystr)
End Function
 
Public Function SendEMail_CDO(strFrom, strTo, strCC, strSubject, strBody)
 
Dim mail
Dim config
Dim fields
 
 
Set mail = CreateObject("CDO.Message")
Set config = CreateObject("CDO.Configuration")
Set fields = config.fields
 
With fields
 
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
 
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail server name" ' IP OF SERVER
 
commented out for now would like to leave as default
'.Item"http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 10
.Update
End With
 
Set mail.Configuration = config
 
With mail
.From = strFrom
.To = strTo
.CC = strCC
.Subject = strSubject
.TextBody = strBody
.Send
End With
 
Set mail = Nothing
Set fields = Nothing
Set config = Nothing
Set rst = Nothing
Set db = Nothing
 
End Function
 

The first function works perfect with no issues.


Please help !!! I have struggled with this for days!!!

Thanks in advance

[JConsulting]

I have read through many posts that are relevant to my topic and have not had any success.

I want to click a button on my form and send an email to a list of people I have stored in a table with email addresses.

My SMTP server uses many defaults(ie port, timeout) I have been asked to leave the defaults alone, if possible.

Here is a copy of my code that I am trying to run. In my button click I call the first function:

Public Function EmailAlert() As Boolean
On Error Resume Next
Stop
Dim db As DAO.Database, rst As DAO.Recordset, sSQL As String
Dim Subjectstr As String, Bodystr As String, SendToVar As String

Set db = CurrentDb

Set rst = db.OpenRecordset("EmailAlertQuery", dbOpenForwardOnly)

If Not rst.EOF And Not rst.BOF Then
rst.MoveFirst

Bodystr = "DATE : " & Format(rst!AlertDate, "Long date") & vbCrLf & vbCrLf
Bodystr = Bodystr & "Duty Officer: " & rst!DutyOfficer & vbCrLf & vbCrLf
Subjectstr = "Alert For " & Format(rst!AlertDate, "Long Date")

Do Until rst.EOF

Bodystr = Bodystr & "TankerBase: " & rst!TankerBase & vbCrLf
If rst!FCPC <> "" And Not IsNull(rst!FCPC) Then
Bodystr = Bodystr & "Fire Center PC: " & rst!FCPC & vbCrLf
End If
If rst!BirddogID <> "" And Not IsNull(rst!BirddogID) Then
Bodystr = Bodystr & "Birddog: " & rst!BirddogID & vbCrLf
End If
If rst!AirtankerID <> "" And Not IsNull(rst!AirtankerID) Then
Bodystr = Bodystr & "Airtankers: " & rst!AirtankerID & vbCrLf
Bodystr = Bodystr & "Type: " & rst!Type & vbCrLf
End If
If rst!Green <> "" And Not IsNull(rst!Green) Then
Bodystr = Bodystr & "Green: " & rst!Green & vbCrLf
End If
If rst!Blue <> "" And Not IsNull(rst!Blue) Then
Bodystr = Bodystr & "Blue: " & rst!Blue & vbCrLf
End If
If rst!Yellow <> "" And Not IsNull(rst!Yellow) Then
Bodystr = Bodystr & "Yellow: " & rst!Yellow & vbCrLf
End If
If rst!Red <> "" And Not IsNull(rst!Red) Then
Bodystr = Bodystr & "Red: " & rst!Red & vbCrLf
End If
If rst!AlertEnd <> "" And Not IsNull(rst!AlertEnd) Then
Bodystr = Bodystr & "Alert End: " & rst!AlertEnd & vbCrLf
End If
Bodystr = Bodystr & vbCrLf
rst.MoveNext
Loop

Else
MsgBox " You have not entered an Alert for Today yet."
End If

Set rst = Nothing
Set rst = db.OpenRecordset("EmailAddressListQuery", dbOpenForwardOnly)

If Not rst.EOF And Not rst.BOF Then
rst.MoveFirst

Do Until rst.EOF
SendToVar = SendToVar & rst!EmailAddress & ";"
rst.MoveNext
Loop
End If

Call SendEMail_CDO("PATCCORP", SendToVar, "chriwill", Subjectstr, Bodystr)
End Function

Public Function SendEMail_CDO(strFrom, strTo, strCC, strSubject, strBody)

Dim mail
Dim config
Dim fields


Set mail = CreateObject("CDO.Message")
Set config = CreateObject("CDO.Configuration")
Set fields = config.fields

With fields

.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail server name" ' IP OF SERVER

commented out for now would like to leave as default
'.Item"http://schemas.microsoft.com/cdo/configuration/ smtpconnectiontimeout") = 10
.Update
End With

Set mail.Configuration = config

With mail
.From = strFrom
.To = strTo
.CC = strCC
.Subject = strSubject
.TextBody = strBody
.Send
End With

Set mail = Nothing
Set fields = Nothing
Set config = Nothing
Set rst = Nothing
Set db = Nothing

End Function

The first function works perfect with no issues.


Please help !!! I have struggled with this for days!!!

Thanks in advance

give this a go
j

Public Function SendEmailCDO(ByVal strTo As String, _
                          ByVal strMessage As String, _
                          ByVal strSubject As String, _
                          Optional ByVal strAttach As String)
    Dim objEmail As Object
    On Error Resume Next
    Set objEmail = CreateObject("CDO.Message")
    '**** email address of sender
    objEmail.FROM = "[e-mail]"
    objEmail.To = strTo
    objEmail.Subject = strSubject
    objEmail.TextBody = strMessage
    If strAttach <> "" Then objEmail.AddAttachment strAttach
    objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/ configuration/sendusing") = 2
    '**** smtp.xxx.com - here u enter your smtp server name, whatever that is
    objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/ cdo/configuration/smtpserver") = "smtp.xx.com"
    objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/ cdo/configuration/smtpserverport") = 25
    objEmail.Configuration.Fields.Update
    objEmail.Send
    If err.Number <> 0 Then
        MsgBox "Error in sending. " & err.Description
    Else
        MsgBox "Sent"   'remove this if u dont want confirmation
    End If
    Set objEmail = Nothing
 
End Function
 
 
 

The code above is a working model.

[FNA access]

Thank you so much for the help J !!!

Works like a dream. I have little knowledge on port assignment and was wary of sending to a wrong port, if that is possible, and the repercussions that might follow if I did.

My breadth of knowledge on ports is limited to port 80 is used for web..... I think? :p

Any insight would be appreciated

Thanks again

[JConsulting]

Thank you so much for the help J !!!

Works like a dream. I have little knowledge on port assignment and was wary of sending to a wrong port, if that is possible, and the repercussions that might follow if I did.

My breadth of knowledge on ports is limited to port 80 is used for web..... I think? :p

Any insight would be appreciated

Thanks again

We aren't the best source on what YOUR ports are set up like. You will need to check with YOUR administrator to verify port assignments. We have no way of knowing those for you.
J

[FNA access]

Understandable, No problem. Was more interested if there was code to use that just picked up the default settings on the mailserver, rather than explicitly setting it?

Side Note : Do I close the thread when done or do one of the guru"s ?
(Sorry reletivley new to the site)

Thanks again for all your help !!