Hi,
I wrote some access vba code that retrieves data from access, then creates a mail in Lotus Notes 8.5. The content of the mail is formatted text. The mail is usually send from a group mailbox but it can also be the default (user's) mailbox. When mail is sent directly, then the formatting is lost somewhere. In the send folder of notes it looks correct, but on the receiving side the formatting is gone.
However, when mail is first saved in the draft folder of the mailbox and then send manually from notes, the formatting stays correct both on sending and receiving side. I guess it must be something within the vba code. Any ideas ?
Here's the code :
Private Sub MailViaLotusNotes()
Dim objNotesDB As Object ' Notes Database
Dim objNotesDoc As Object ' Notes Document
Dim objNotesRTF As Object ' Notes Rich Text Item
Dim objNotesStyle As Object ' Notes Rich Text Style
Dim objSession As Object ' Notes Session
Dim SndTo As String
Dim SndCc As String
Dim msgSubject As String
Dim AutoSend As Boolean ' True/False is Email automatically sent
Dim itm As Variant
Dim EmbedObj(0 To 100) As Object ' Attachments
Dim sSRV As String ' Notes Server
Dim sDb As String ' Maildb name
Dim ErrMes As String
Dim rs As New ADODB.Recordset
Dim sSql As String
Dim PlTxt1 As String
Dim PlTxt2 As String
Dim PlTxt3 As String
Dim varHd As String 'HD = value of whdoc id.
Dim varHdFx As String 'HdFx = fixed text for whdoc id.
Dim varHd1 As String 'Hd1 = header values part 1
Dim varHdFx1 As String 'HdFx1 = header fixed text part 1
Dim varHd2 As String 'Hd2 = header values part 2
Dim varHdFx2 As String 'HdFx2 = header fixed text part 2
Dim iiPrb As Integer 'Problem id number.
Dim ssPrb As String 'Problem description.
Dim ssDtl As String 'Detail values.
Dim ssVal As String 'Next Problem description.
Dim ssDtlFx As String 'Detail fixed text.
Dim cctrl As Boolean 'used for tracking end of data.
'Set Variables
AutoSend = GetAutoSend ' False saves to drafts folder True would send straight away
SndTo = "<string of recipient addresses>"
cc = "<String of cc addresses>"
'Create Email
sSRV = "" 'Set default mail server
sDb = "" 'Set default mailbox
On Error GoTo Err_Handler
'If group mailbox chosen, then get server address and mailbox name.
If Me.mlGroup.Value = 2 Then
GrpMlbxSrv = Nz(Me.cboCreatedBy.Column(2), "")
GrpMlBxDb = Nz(Me.cboCreatedBy.Column(3), "")
sSRV = GrpMlbxSrv
sDb = GrpMlBxDb
If GrpMlbxSrv = "" Then
MsgBox "No group mailbox found. The default will be used.!"
End If
End If
Set objSession = CreateObject("Notes.NotesSession")
Set objNotesDB = objSession.GetDatabase(sSRV, sDb) 'Default Users Notes Account.
'Insert Server and Database details
'to use group mailboxes
'Set Notes Text Styles
Set bodytext = objSession.CreateRichTextStyle
Set bodytext1 = objSession.CreateRichTextStyle
Set headings = objSession.CreateRichTextStyle
Set bottom = objSession.CreateRichTextStyle
Set restrict = objSession.CreateRichTextStyle
Set disclaimer = objSession.CreateRichTextStyle
'Build Text Style
'Headings
With headings
.NotesFont = 4
.FontSize = 10
.Bold = -1
.Underline = 0
.NotesColor = COLOR_BLACK
End With
'Main Text
With bodytext
.NotesFont = 4
.FontSize = 10
.Bold = 0
.Underline = 0
.NotesColor = COLOR_DARK_BLUE
End With
With bodytext1
.NotesFont = 4
.FontSize = 10
.Bold = -1
.Underline = -1
.NotesColor = COLOR_DARK_BLUE
End With
'Bottom text
With bottom
.NotesFont = 1
.FontSize = 10
.Bold = 0
.Underline = 0
.NotesColor = COLOR_BLACK
End With
'Open Notes Mail
' If objNotesDB.IsOpen = True Then
' Else
' objNotesDB.openmail
' End If
If sSRV = "" Then
' Assign the current user db to the db object. In case of group mailbox this is
' done earlier. In that case the next line would generate an "already open" error.
objNotesDB.openmail
End If
If (objNotesDB.IsOpen) Then
msgSubject = "WhDoc 07 : " & Me.txtCaseNbr & " " & " [" & Me.txtBiTrip & "] ["
msgSubject = msgSubject & Me.txtShipmNbr & "]"
'Retrieve mail addresses.
Call RetrieveEmailAddresses(SndTo, SndCc)
If SndTo = "" Then
Call GetDefaultMailAddresses(SndTo, SndCc)
End If
'if no default mailaddress exist then mail will not be send straight away but
'saved in draft mailbox.
If SndTo = "" Then
AutoSend = False
End If
Call GetHeaderText(varHd, varHdFx, varHd1, varHdFx1, varHd2, varHdFx2)
'Create a new message
Set objNotesDoc = objNotesDB.CreateDocument
objNotesDoc.ReplaceItemValue "SendTo", SndTo
objNotesDoc.ReplaceItemValue "CopyTo", SndCc
objNotesDoc.ReplaceItemValue "Subject", msgSubject
objNotesDoc.Principal = objNotesDB.Title
Set objNotesRTF = objNotesDoc.CreateRichTextItem("Body")
Set objAttachRTF = objNotesDoc.CreateRichTextItem("File")
'Build Body of email
With objNotesRTF
'Write header of whdoc to mail body.
.AppendStyle (headings)
.AppendText varHdFx
.AppendStyle (bodytext)
.AddNewLine 1
.AppendText varHd
.AddNewLine 1
.AppendStyle (headings)
.AppendText varHdFx1
.AppendStyle (bodytext)
.AddNewLine 1
.AppendText varHd1
.AddNewLine 1
.AppendStyle (headings)
.AppendText varHdFx2
.AppendStyle (bodytext)
.AddNewLine 1
.AppendText varHd2
.AddNewLine 1
'Write detail of whdoc to mail body.
cctrl = True
Do While Not cctrl = False
Call RetrieveWhDocDetail(iiPrb, ssPrb, ssDtl, ssVal, ssDtlFx, cctrl)
.AddNewLine 1
.AppendStyle (bodytext1)
.AppendText ssPrb
.AddNewLine 1
.AppendStyle (headings)
.AppendText ssDtlFx
.AddNewLine 1
.AppendStyle (bodytext)
.AppendText ssDtl
Loop
.AddNewLine 1
End With
'Add Attachments
sSql = "SELECT tbPics.picsPath FROM tbPics "
sSql = sSql & "WHERE (((tbPics.picsID)='"
sSql = sSql & [Forms]![frmCaseRegWHG]![txtCaseNbr] & "'))"
Set rs = New ADODB.Recordset
rs.Open sSql, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
If rs.EOF = True And rs.BOF = True Then
'...
Else
itm = 1
Do While Not rs.EOF = True
Set EmbedObj(itm) = objAttachRTF.EmbedObject _
(EMBED_ATTACHMENT, "File", rs.Fields(0).Value)
rs.MoveNext
itm = itm + 1
Loop
End If
rs.Close
Set rs = Nothing
'Get the mail to appear in sent items folder
objNotesDoc.SaveMessageOnSend = True
objNotesDoc.Save True, True
'Send the message
If AutoSend = True Then
'objNotesDoc.postedDate = Now()
Call objNotesDoc.ReplaceItemValue("PostedDate", Now())
Call objNotesDoc.Send(0)
End If
If AutoSend = True Then
MsgBox ("Mail send.")
Else
R = MsgBox("Mail has been prepared. See draft folder ! " & vbCrLf & _
"Change if needed before sending out.", vbInformation, "Notes Mail")
End If
'Markeer [MailSend] veld om aan te geven dat de mail verstuurd werd.
MailSend = -1
Me.frameMail.BorderColor = RGB(0, 255, 0)
Else
MsgBox ("Lotus Notes Could Not Be Opened."), vbInformation
End If
Set objNotesDB = Nothing
Set objSession = Nothing
Exit Sub
Err_Handler:
If Err.Number = 7225 Then 'Picture file not found or not existing
MsgBox Err.Description
Resume Next
Else
MsgBox Err.Number & " " & Err.Description
End If
ErrMes = "Lotus Notes could not create mail" & vbCrLf
ErrMes = ErrMes & "Maybe Notes screensaver is on or Alarm is displayed." & vbCrLf
ErrMes = ErrMes & "Check Lotus Notes first and try again."
MsgBox ErrMes, vbInformation
End Sub
I wrote some access vba code that retrieves data from access, then creates a mail in Lotus Notes 8.5. The content of the mail is formatted text. The mail is usually send from a group mailbox but it can also be the default (user's) mailbox. When mail is sent directly, then the formatting is lost somewhere. In the send folder of notes it looks correct, but on the receiving side the formatting is gone.
However, when mail is first saved in the draft folder of the mailbox and then send manually from notes, the formatting stays correct both on sending and receiving side. I guess it must be something within the vba code. Any ideas ?
Here's the code :
Private Sub MailViaLotusNotes()
Dim objNotesDB As Object ' Notes Database
Dim objNotesDoc As Object ' Notes Document
Dim objNotesRTF As Object ' Notes Rich Text Item
Dim objNotesStyle As Object ' Notes Rich Text Style
Dim objSession As Object ' Notes Session
Dim SndTo As String
Dim SndCc As String
Dim msgSubject As String
Dim AutoSend As Boolean ' True/False is Email automatically sent
Dim itm As Variant
Dim EmbedObj(0 To 100) As Object ' Attachments
Dim sSRV As String ' Notes Server
Dim sDb As String ' Maildb name
Dim ErrMes As String
Dim rs As New ADODB.Recordset
Dim sSql As String
Dim PlTxt1 As String
Dim PlTxt2 As String
Dim PlTxt3 As String
Dim varHd As String 'HD = value of whdoc id.
Dim varHdFx As String 'HdFx = fixed text for whdoc id.
Dim varHd1 As String 'Hd1 = header values part 1
Dim varHdFx1 As String 'HdFx1 = header fixed text part 1
Dim varHd2 As String 'Hd2 = header values part 2
Dim varHdFx2 As String 'HdFx2 = header fixed text part 2
Dim iiPrb As Integer 'Problem id number.
Dim ssPrb As String 'Problem description.
Dim ssDtl As String 'Detail values.
Dim ssVal As String 'Next Problem description.
Dim ssDtlFx As String 'Detail fixed text.
Dim cctrl As Boolean 'used for tracking end of data.
'Set Variables
AutoSend = GetAutoSend ' False saves to drafts folder True would send straight away
SndTo = "<string of recipient addresses>"
cc = "<String of cc addresses>"
'Create Email
sSRV = "" 'Set default mail server
sDb = "" 'Set default mailbox
On Error GoTo Err_Handler
'If group mailbox chosen, then get server address and mailbox name.
If Me.mlGroup.Value = 2 Then
GrpMlbxSrv = Nz(Me.cboCreatedBy.Column(2), "")
GrpMlBxDb = Nz(Me.cboCreatedBy.Column(3), "")
sSRV = GrpMlbxSrv
sDb = GrpMlBxDb
If GrpMlbxSrv = "" Then
MsgBox "No group mailbox found. The default will be used.!"
End If
End If
Set objSession = CreateObject("Notes.NotesSession")
Set objNotesDB = objSession.GetDatabase(sSRV, sDb) 'Default Users Notes Account.
'Insert Server and Database details
'to use group mailboxes
'Set Notes Text Styles
Set bodytext = objSession.CreateRichTextStyle
Set bodytext1 = objSession.CreateRichTextStyle
Set headings = objSession.CreateRichTextStyle
Set bottom = objSession.CreateRichTextStyle
Set restrict = objSession.CreateRichTextStyle
Set disclaimer = objSession.CreateRichTextStyle
'Build Text Style
'Headings
With headings
.NotesFont = 4
.FontSize = 10
.Bold = -1
.Underline = 0
.NotesColor = COLOR_BLACK
End With
'Main Text
With bodytext
.NotesFont = 4
.FontSize = 10
.Bold = 0
.Underline = 0
.NotesColor = COLOR_DARK_BLUE
End With
With bodytext1
.NotesFont = 4
.FontSize = 10
.Bold = -1
.Underline = -1
.NotesColor = COLOR_DARK_BLUE
End With
'Bottom text
With bottom
.NotesFont = 1
.FontSize = 10
.Bold = 0
.Underline = 0
.NotesColor = COLOR_BLACK
End With
'Open Notes Mail
' If objNotesDB.IsOpen = True Then
' Else
' objNotesDB.openmail
' End If
If sSRV = "" Then
' Assign the current user db to the db object. In case of group mailbox this is
' done earlier. In that case the next line would generate an "already open" error.
objNotesDB.openmail
End If
If (objNotesDB.IsOpen) Then
msgSubject = "WhDoc 07 : " & Me.txtCaseNbr & " " & " [" & Me.txtBiTrip & "] ["
msgSubject = msgSubject & Me.txtShipmNbr & "]"
'Retrieve mail addresses.
Call RetrieveEmailAddresses(SndTo, SndCc)
If SndTo = "" Then
Call GetDefaultMailAddresses(SndTo, SndCc)
End If
'if no default mailaddress exist then mail will not be send straight away but
'saved in draft mailbox.
If SndTo = "" Then
AutoSend = False
End If
Call GetHeaderText(varHd, varHdFx, varHd1, varHdFx1, varHd2, varHdFx2)
'Create a new message
Set objNotesDoc = objNotesDB.CreateDocument
objNotesDoc.ReplaceItemValue "SendTo", SndTo
objNotesDoc.ReplaceItemValue "CopyTo", SndCc
objNotesDoc.ReplaceItemValue "Subject", msgSubject
objNotesDoc.Principal = objNotesDB.Title
Set objNotesRTF = objNotesDoc.CreateRichTextItem("Body")
Set objAttachRTF = objNotesDoc.CreateRichTextItem("File")
'Build Body of email
With objNotesRTF
'Write header of whdoc to mail body.
.AppendStyle (headings)
.AppendText varHdFx
.AppendStyle (bodytext)
.AddNewLine 1
.AppendText varHd
.AddNewLine 1
.AppendStyle (headings)
.AppendText varHdFx1
.AppendStyle (bodytext)
.AddNewLine 1
.AppendText varHd1
.AddNewLine 1
.AppendStyle (headings)
.AppendText varHdFx2
.AppendStyle (bodytext)
.AddNewLine 1
.AppendText varHd2
.AddNewLine 1
'Write detail of whdoc to mail body.
cctrl = True
Do While Not cctrl = False
Call RetrieveWhDocDetail(iiPrb, ssPrb, ssDtl, ssVal, ssDtlFx, cctrl)
.AddNewLine 1
.AppendStyle (bodytext1)
.AppendText ssPrb
.AddNewLine 1
.AppendStyle (headings)
.AppendText ssDtlFx
.AddNewLine 1
.AppendStyle (bodytext)
.AppendText ssDtl
Loop
.AddNewLine 1
End With
'Add Attachments
sSql = "SELECT tbPics.picsPath FROM tbPics "
sSql = sSql & "WHERE (((tbPics.picsID)='"
sSql = sSql & [Forms]![frmCaseRegWHG]![txtCaseNbr] & "'))"
Set rs = New ADODB.Recordset
rs.Open sSql, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
If rs.EOF = True And rs.BOF = True Then
'...
Else
itm = 1
Do While Not rs.EOF = True
Set EmbedObj(itm) = objAttachRTF.EmbedObject _
(EMBED_ATTACHMENT, "File", rs.Fields(0).Value)
rs.MoveNext
itm = itm + 1
Loop
End If
rs.Close
Set rs = Nothing
'Get the mail to appear in sent items folder
objNotesDoc.SaveMessageOnSend = True
objNotesDoc.Save True, True
'Send the message
If AutoSend = True Then
'objNotesDoc.postedDate = Now()
Call objNotesDoc.ReplaceItemValue("PostedDate", Now())
Call objNotesDoc.Send(0)
End If
If AutoSend = True Then
MsgBox ("Mail send.")
Else
R = MsgBox("Mail has been prepared. See draft folder ! " & vbCrLf & _
"Change if needed before sending out.", vbInformation, "Notes Mail")
End If
'Markeer [MailSend] veld om aan te geven dat de mail verstuurd werd.
MailSend = -1
Me.frameMail.BorderColor = RGB(0, 255, 0)
Else
MsgBox ("Lotus Notes Could Not Be Opened."), vbInformation
End If
Set objNotesDB = Nothing
Set objSession = Nothing
Exit Sub
Err_Handler:
If Err.Number = 7225 Then 'Picture file not found or not existing
MsgBox Err.Description
Resume Next
Else
MsgBox Err.Number & " " & Err.Description
End If
ErrMes = "Lotus Notes could not create mail" & vbCrLf
ErrMes = ErrMes & "Maybe Notes screensaver is on or Alarm is displayed." & vbCrLf
ErrMes = ErrMes & "Check Lotus Notes first and try again."
MsgBox ErrMes, vbInformation
End Sub
