Hello. I need some help from some VBA experts.
Ideally what I'm trying to do is replace the commands for LotusNotes with commands for Outlook. For privacy reasons, I've redacted some of the indentifiable information, namely the email address to which the test email would be sent and the file path where the files are found.
I don't know if what I'm attempting to do is possible as everything I've read says the conversion from LotusNotes to Outlook is complicated, and I'm pretty novice, but any help you can provide will be very appreciated.
Thanks!
----------------------------------------------------------------------------------------------------------------------
Function ComposeEmailInLotusNotes(Optional ByVal SendToArray As Variant, _
Optional ByVal Subject As Variant, _
Optional ByVal PathToBody As Variant, _
Optional ByVal PathToDisclaimer As Variant, _
Optional ByVal CopyToArray As Variant, _
Optional ByVal BlindCopyToArray As Variant, _
Optional ByVal AttachmentFileArray As Variant) As Boolean
'On Error GoTo ErrHandler
Dim I As Long
Dim Msg As String
Dim Session As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDb As Object
Dim MailDoc As Object
Dim AttachME As Object
Dim EmbedObj As Object
Dim Workspace As Object
Dim UIDoc As Object
Dim WordApp As Object, WordDoc As Object
Dim BodyMarker As String, DiscMarker As String
'Create a Lotus Notes Session
Set Session = CreateObject("Notes.NotesSession")
'Get the Lotus Notes UserName
UserName = Session.UserName
'Construct the MailDbName from the UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set MailDb = Session.GETDATABASE("", MailDbName)
'If Lotus Notes is not already open, open it
If MailDb.IsOpen = False Then
MailDb.OPENMAIL
End If
'Create New Email
Set MailDoc = MailDb.CREATEDOCUMENT
MailDoc.Form = "Memo"
If Len(PathToBody) > 0 Then BodyMarker = "Body_Goes_Here"
If Len(PathToDisclaimer) > 0 Then
DiscMarker = "Disc_Sig_Go_Here"
Else
MsgBox "File Containing Disclaimer Message not Selected. Please Select File and Retry.", vbOKOnly + vbCritical, "Warning!"
GoTo ErrHandler
End If
'Populate the recipients
If Not VBA.IsMissing(SendToArray) Then MailDoc.SendTo = SendToArray
If Not VBA.IsMissing(CopyToArray) Then MailDoc.CopyTo = CopyToArray
If Not VBA.IsMissing(BlindCopyToArray) Then MailDoc.BlindCopyTo = BlindCopyToArray
'Populate the Subject & Body of the Email
If Not VBA.IsMissing(Subject) Then MailDoc.Subject = Subject
If Not VBA.IsMissing(PathToBody) Then MailDoc.Body = BodyMarker & vbCrLf & vbCrLf & DiscMarker Else MailDoc.Body = DiscMarker
MailDoc.Save True, False
'Add attachments, if any
If Not VBA.IsMissing(AttachmentFileArray) Then
If Not VBA.IsArray(AttachmentFileArray) Then
Call MsgBox("Attachments must be passed as an array.", vbExclamation, "Error")
Else
For I = LBound(AttachmentFileArray) To UBound(AttachmentFileArray)
If FileFolderExists(CStr(AttachmentFileArray(I))) Then
Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment" & I)
'1454 indicates a file attachment
Set EmbedObj = AttachME.EMBEDOBJECT(1454, "Attachment" & I, AttachmentFileArray(I), "") 'Required File Name
Else
Call MsgBox("Attachment file does not exist at: " & AttachmentFileArray(I) & ". Press OK to continue.", vbExclamation, "Error")
End If
Next I
End If
End If
'Specify that the email should be saved to the Database
'Specify the posted date, otherwise the email will not get saved
MailDoc.PostedDate = Now()
MailDoc.SAVEMESSAGEONSEND = True
'Create a Worksapce to hold the email
Set Workspace = CreateObject("Notes.NotesUIWorkspace")
Set UIDoc = Workspace.EDITDOCUMENT(True, MailDoc)
With UIDoc
'Find The Marker Text in the Body Item
.GOTOFIELD ("Body")
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
If Len(PathToBody) > 0 Then
.FINDSTRING BodyMarker
'Open the Word document containing Body Text
Set WordDoc = WordApp.Documents.Open(PathToBody)
'Copy all contents to clipboard
With WordApp.Selection
.WholeStory
.Copy
End With
'Paste Body into the Email
.Paste
WordDoc.Close SaveChanges:=False
Set WordDoc = Nothing
End If
.FINDSTRING DiscMarker
'Open the Disclaimer Signature Word document
Set WordDoc = WordApp.Documents.Open(PathToDisclaimer)
'Copy all contents to clipboard
With WordApp.Selection
.WholeStory
.Copy
End With
'Paste Disclaimer into Email
.Paste
Application.CutCopyMode = False
WordApp.Quit SaveChanges:=False
Set WordApp = Nothing
Set WordDoc = Nothing
End With
'Varun's Historical Code - Similar to above
' 'Open the Workspace and put the cursor in the Body of the email
' Call Workspace.EDITDOCUMENT(True, MailDoc).GOTOFIELD("Body")
' Call Workspace.RELOADWINDOW
'Exit function successfully
Set Session = Nothing
Set MailDb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set EmbedObj = Nothing
Set Workspace = Nothing
On Error GoTo 0
ComposeEmailInLotusNotes = True
Exit Function
ErrHandler:
Msg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
Set Session = Nothing
Set MailDb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set EmbedObj = Nothing
Set Workspace = Nothing
ComposeEmailInLotusNotes = False
On Error GoTo 0
End Function
____________________________________________________________________________________________________________________________
Sub avtest()
Dim attachment As Variant
ReDim attachment(1)
attachment(1) = "C:\Users\XXXXXX\Desktop\Test Attachment.pdf"
Call ComposeEmailInLotusNotes(SendToArray:="name@gmail.com", Subject:="Test", _
PathToBody:="C:\Users\XXXXXX\Desktop\TestBody.docx", PathToDisclaimer:="C:\Users\XXXXXX\Desktop\DiscSig.docx", _
CopyToArray:="name@gmail.com", BlindCopyToArray:="name@gmail.com", AttachmentFileArray:=attachment)
End Sub
Bookmarks