Using CDO to create email

[upnorth]

I have the code below which creates an email to Outlook.

I would like to use CDO to email but can not figure out how to incorporate CDO code into this
Any help would be much appreciated
David

Private Sub Command68_Click()
On Error GoTo Handler

If DCount("[dob]", "[cpp12q]") = 0 Then
MsgBox "There are no records to send"
Exit Sub
Else
DoCmd.OpenQuery "bcmsdeletebirthtable", acNormal, acEdit
DoCmd.Close acQuery, "bcmsdeletebirthtable"
DoCmd.OpenQuery "bcmsbirths", acNormal, acEdit
DoCmd.Close acQuery, "bcmsbirths"
End If
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Dim strMessage As String
Dim strSubject As String
Dim strspareline As String
Set rs = db.OpenRecordset("BCMSREGgrab")
If Not rs.BOF And Not rs.EOF Then
rs.MoveFirst
Dim olObj As Outlook.Application
Dim olMail As Outlook.MailItem
Set olObj = New Outlook.Application
Set olMail = olObj.CreateItem(olMailItem)

Set olMail = olObj.CreateItem(olMailItem)


Do
strMessage = strMessage & vbCrLf & Trim(rs![Tag No] & Chr(124) & rs![DateOB] & Chr(124) & rs![Sex] & Chr(124) & rs![Breeds] & Chr(124) & rs![electID] & Chr(124) & rs![Dam I D] & Chr(124) & rs![surrdamid2] & Chr(124) & rs![Ear Tag] & Chr(124) & rs![Holding No] & Chr(124) & rs![birthherdsuffix] & Chr(124) & rs![Holding No] & Chr(124) & rs![postherdsuffix]) 'data
strSubject = Trim(rs![BCMSapplicID] & Chr(124) & rs![BCMSVno] & Chr(124) & rs![BCMSorigionater ID] & Chr(124) & rs.RecordCount & Chr(124) & rs![timestamp]) 'header
strspareline = ""
rs.MoveNext

Loop Until rs.EOF


With olMail

.Subject = "."
.Body = strSubject & vbNewLine & strspareline & vbNewLine & strMessage & vbNewLine
.To =""
.Send
End With
Set olMail = Nothing

End If
exitsub:
olObj.Quit
Set olObj = Nothing
rs.Close
Set rs = Nothing
Set db = Nothing
MsgBox "Email has been created. Open Outlook then press F5 to dial"

Dim stAppName As String
stAppName = "C:\Program Files\Microsoft Office\Office\outlook.exe"
Call Shell(stAppName, 1)
pbooClickTest = True
DoCmd.Close
Exit Sub

Handler:
Select Case Err.Number
Case Else
MsgBox Err.Number & " " & Err.Description
Resume exitsub
End Select

End Sub

 

[GinaWhipp]

Perhaps this will help...
http://www.blueclaw-db.com/access_email_gmail.htm

 

[upnorth]

Perhaps this will help...

Thanks for that
I can get it to create and send an email
However the message body comes like this -
strSubject & vbNewLine & strspareline & vbNewLine & strMessage & vbNewLine

Can anyone see why this is happening

TIA
David
My code below




Private Sub Command87_Click()


If DCount("[dob]", "[cpp12q]") = 0 Then
MsgBox "There are no records to send"
Exit Sub
Else
DoCmd.OpenQuery "bcmsdeletebirthtable", acNormal, acEdit
DoCmd.Close acQuery, "bcmsdeletebirthtable"
DoCmd.OpenQuery "bcmsbirths", acNormal, acEdit
DoCmd.Close acQuery, "bcmsbirths"
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Dim strMessage As String
Dim strSubject As String
Dim strspareline As String
Set rs = db.OpenRecordset("BCMSREGgrab")
If Not rs.BOF And Not rs.EOF Then
rs.MoveFirst
End If
End If
Set cdomsg = CreateObject("CDO.message")
Had to delete this bit as the forum would not take links - this bit must be OK as the email sends


.Update
End With
Do
strMessage = strMessage & vbCrLf & Trim(rs![Tag No] & Chr(124) & rs![DateOB] & Chr(124) & rs![Sex] & Chr(124) & rs![Breeds] & Chr(124) & rs![electID] & Chr(124) & rs![Dam I D] & Chr(124) & rs![surrdamid2] & Chr(124) & rs![Ear Tag] & Chr(124) & rs![Holding No] & Chr(124) & rs![birthherdsuffix] & Chr(124) & rs![Holding No] & Chr(124) & rs![postherdsuffix]) 'data
strSubject = Trim(rs![BCMSapplicID] & Chr(124) & rs![BCMSVno] & Chr(124) & rs![BCMSorigionater ID] & Chr(124) & rs.RecordCount & Chr(124) & rs![timestamp]) 'header
strspareline = ""
rs.MoveNext

Loop Until rs.EOF
With cdomsg
.To = ""
.From = ""
.Subject = "."
.TextBody = " strSubject & vbNewLine & strspareline & vbNewLine & strMessage & vbNewLine"
.Send
End With
Set cdomsg = Nothing
End Sub

 

[upnorth]

Solved it !
Quotation marks after text body were the problem

Working fine now

 

[GinaWhipp]

Hmm, I arrived too late to help but great that you found it!

 

[upnorth]

The example code in Gina`s post above sends through gmail.

I played about and found changing the SMPT server names , port number, user name & password it would work through my Bt email.
- So you don`t need a gmail account to use it

Impressed !

 

[upnorth]

Returning to this thread after 9 years -

Have used this to send emails from a MS Access database for 9 years.
The send using has just been changed to OAuth2
Can CDO deal with that ?
David
TIA

 

[The_Doc_Man]

Probably not, as CDO hasn't been updated since 2006 and OAuth methods are more recent than that. Unless CDO got updated and I missed it.

 

[upnorth]

Probably not, as CDO hasn't been updated since 2006 and OAuth methods are more recent than that. Unless CDO got updated and I missed it.

Thanks for the reply
Suggestions for plan B would be ?

 

[The_Doc_Man]

I'll have to defer to my colleagues on the forum for that one. I never got a chance to play with OAuth methods and my Outlook at home still allows use of ordinary (if rather long) passwords.

 

[Gasman]

Crossposted https://www.accessforums.net/showthread.php?t=90263

 

[isladogs]

AFAIAA, yes it can. Test it using my example app:

CDO EMail Tester

Used to test sending HTML or plain text emails directly from Access without using Outlook. Attachments can also be added. Attachments can also be added. EMail settings can optionally be included in the email body.

www.isladogs.co.uk

if you have issues with port 587, try changing to port 25

 

[upnorth]

Thanks for that reply.
Created an app password, tried changing ports, still no success.
App password includes spaces, assume they stay in ?

 

[Gasman]

I would never have a password with spaces.
Didn't even know you could have that?

 

[upnorth]

Yes, the app password created does contain spaces.
Update.
I have got this to work with a gmail.com account but not with an outlook.com account

Any thoughts on why ?

 

[cheekybuddha]

Does Outlook.com have the facility to create app passwords like gmail?

 

[Gasman]

Yes, the app password created does contain spaces.
Update.
I have got this to work with a gmail.com account but not with an outlook.com account

Any thoughts on why ?

Have you tested outlook.com with @isladogs app?