Hi,
I have the following code that creates an e-mail from a query if multiple parameters on a form are met. When the email is created the information from the recordset is listed line by line. If the EmailText string is over 120 characters it creates an extra line break. I have tried vbnewline, vblf, vbcrlf when opening the recordset but they all produce the same result. Any help would be greatly appreciated. Office 2007 Professional, Office 2010 64-bit, saving as mdb for users with 2003 runtime.
Thanks.
I have the following code that creates an e-mail from a query if multiple parameters on a form are met. When the email is created the information from the recordset is listed line by line. If the EmailText string is over 120 characters it creates an extra line break. I have tried vbnewline, vblf, vbcrlf when opening the recordset but they all produce the same result. Any help would be greatly appreciated. Office 2007 Professional, Office 2010 64-bit, saving as mdb for users with 2003 runtime.
Thanks.
Code:
Private Sub CreateEmail2()
On Error GoTo ErrorHandler
Const olMailItem As Long = 0
Dim olApp As Object
Dim objEmail As Object
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim qdf2 As DAO.QueryDef
Dim prm As DAO.Parameter
Dim prm2 As DAO.Parameter
Dim RS As DAO.Recordset
Dim RS2 As DAO.Recordset
Dim SESSION_ID As Long
Dim EmailText As String
Dim ESignature As String
Set db = CurrentDb()
Set qdf = db.QueryDefs("qryEmailText")
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set RS = qdf.OpenRecordset()
Do While Not RS.EOF
EmailText = EmailText & Space(10) & RS.Fields("ReferralText") & vbCrLf
RS.MoveNext
Loop
Set qdf2 = db.QueryDefs("qryEmailSignature")
For Each prm2 In qdf2.Parameters
prm2.Value = Eval(prm.Name)
Next prm2
Set RS2 = qdf2.OpenRecordset()
If RS2.RecordCount = 0 Then
MsgBox "Your User Id is not listed in this database. Please contact the help desk to be added.", vbInformation + vbOKOnly, "MISSING INFORMATION"
Else
Do While Not RS2.EOF
ESignature = ESignature & RS2.Fields("Signature") & vbCrLf
RS2.MoveNext
Loop
End If
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
End If
Set objEmail = olApp.CreateItem(olMailItem)
With objEmail
.To = Me.EMAIL
.Subject = "Additional Resources"
.Body = "Dear " & StrConv(Me.COMBINED_NAME, vbProperCase) & "," & vbNewLine & "Here is a list of the additional resources that we spoke about." & vbNewLine & vbCrLf & EmailText & vbNewLine & _
"Please feel free to contact me if you need any further assistance." & vbNewLine & vbCrLf & "Regards," & vbNewLine & vbCrLf & ESignature
' .send 'this command automatically sends the e-mail without viewing it.
.display
End With
EndSub:
RS.Close: Set RS = Nothing: Set prm = Nothing: Set qdf = Nothing: RS2.Close: Set RS2 = Nothing: Set prm2 = Nothing: Set qdf2 = Nothing
db.Close: Set db = Nothing
Exit_CreateEmail:
Exit Sub
ErrorHandler:
MsgBox "Error Number" & Err.Number & ", " & Err.Description, vbOKOnly, "Error"
Resume Exit_CreateEmail:
End Sub
