Using CDO to create email (1 Viewer)

[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 !