Lotus to Outlook. VBA Code

[babafingo]

'***Code originated at access-programmers.
'***in the Code Repository Forum by KeithIT


' ##################################################  ###################################

' Tested to work with Windows NT 4 and higher NT-Versions (2000 / XP / 2003)
' Tested with Lotus Client 5.07 and higher

' The Lotus client has to be installed
' If a password, different form the NT one is choosen, Lotus has to be open
' in beforehand before this script can be used.

' ##################################################  ###################################

Const EMBED_ATTACHMENT As Integer = 1454
Const EMBED_OBJECT As Integer = 1453
Const EMBED_OBJECTLINK As Integer = 1452


Declare Function SetForegroundWindow Lib "user32" (ByVal Hwnd As Long) As Long
Declare Function ShowWindow& Lib "user32" (ByVal Hwnd As Long, ByVal nCmdShow As Long)

Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Function CreateNotesSession&(Optional edit As Boolean = True)
On Error GoTo HandleErr

Const notesclass$ = "NOTES"
' "Neues Memo - Lotus Notes"
Const SW_SHOWMAXIMIZED = 3
Dim Lotus_Session As Object

Dim rc&
Dim lotusWindow&
'Set Lotus_Session = CreateObject("Notes.NotesSession")

DoEvents
DoEvents
lotusWindow = FindWindow(notesclass, vbNullString)

If lotusWindow <> 0 Then
    If edit = True Then
        rc = ShowWindow(lotusWindow, SW_SHOWMAXIMIZED)
        rc = SetForegroundWindow(lotusWindow)
        CreateNotesSession& = True
    Else
        CreateNotesSession& = True
    End If
Else
    CreateNotesSession& = False
    Set Lotus_Session = CreateObject("Notes.NotesSession")
    lotusWindow = FindWindow(notesclass, vbNullString)
    rc = SetForegroundWindow(lotusWindow)
 End If

ExitHere:
    Exit Function
    
HandleErr:
    If Err.Number = "8965" Then
        Resume ExitHere
    Else
        MsgBox "Error #" & Err.Number & ": " & Err.Description & " at " & Err.Source
        Resume ExitHere
    End If
    
End Function

Sub CreateMailandAttachFile(Optional IsSubject As String = "", Optional ByRef SendToAdr As Variant, Optional CCToAdr As Variant, Optional BCCToAdr As Variant = "", Optional IsBody As String, Optional Attach1 As String = "", Optional Attach2 As String = "", Optional MailDB As String = "", Optional edit As Boolean = True, Optional Servr As String = "", Optional Acct As String = "")

Dim s As Object ' use back end classes to obtain mail database name
Dim db As Object '
Dim doc As Object ' front end document
Dim beDoc As Object ' back end document
Dim workspace As Object ' use front end classes to display to user
Dim bodypart As Object '

Call CreateNotesSession(False)

Set s = CreateObject("Notes.Notessession") 'create notes session
Set db = s.GetDatabase(Servr, Acct) 'set db to server and file name, if not supplied via code will automatically use the default mail db
     If db.IsOpen = True Then
        Else
            Call db.OPENMAIL 'open db to send mail
     End If
Set beDoc = db.CreateDocument
Set bodypart = beDoc.CreateRichTextItem("Body")


' Filling the fields
'###################
beDoc.Subject = IsSubject  'Subject line
beDoc.Body = IsBody  'Mail message
beDoc.SendTo = SendToAdr  'To:
beDoc.CopyTo = CCToAdr  'CC:
beDoc.BlindCopyTo = BCCToAdr  'Bcc:
'beDoc.From = IsFrom  'Sending email address, must be a valid notes account
   'name
'beDoc.PRINCIPAL = IsPrincipal  'Sender's name.  May be anything (literally).
   'Will show in the "From" field in most email agents
beDoc.SaveOnSend = True  'tells notes to put message in sent folder

'''''''''''''''''''''''''
''For multiple email addresses you just set beDoc.sendto (or CopyTo or
''BlindCopyTo) to an array of variants each of which will receive the message. So:

'Dim recip() as variant
'z = item count
'Redim recip(z)
'y = 0
'For i = 0 to ctrl.itemcount
'   recip(y) = "emailaddress1"
'   y = y + 1
'next i

'beDoc.sendto = recip
''''''''''''''''''''''''

' Attaches I
'###########
' Call bodypart.EmbedObject(EMBED_ATTACHMENT, "", DirWithPathFileName, FileName)
If Len(Attach1) > 0 Then
    If Len(Dir(Attach1)) > 0 Then
        Call bodypart.EmbedObject(EMBED_ATTACHMENT, "", Attach1, Dir(Attach1))
    End If
End If

' Attaches II
'############
If Len(Attach2) > 0 Then
    If Len(Dir(Attach2)) > 0 Then
        Call bodypart.EmbedObject(EMBED_ATTACHMENT, "", Attach2, Dir(Attach2))
    End If
End If

If edit = True Then
    Set workspace = CreateObject("Notes.NotesUIWorkspace")
      'Position cursor in body of email
    Call workspace.EDITDOCUMENT(True, beDoc).GOTOFIELD("Body")
Else
    beDoc.PostedDate = Now() 'Gets the mail to appear in the sent items folder with current date and time
    beDoc.Save True, True    'Saves to Sent Folder
    beDoc.Send 0, SendToAdr

End If

Set s = Nothing

End Sub

Hello everyone. I am new here. I have a problem with Lotus e-mail and this code. My company changed mail programm. We are using Outlook now. When we used Lotus, integrated to excel VBA macros.And now, i integrated to Outlook other moduls. But i can't make this code. I need this code counterpart for Outlook.

Please help me.

 

[Ranman256]

The email code is pretty much the same
usage:
vSuccess = Email1("rick.grimes@TWD.com","subject", "body text", "c:\folder\file.zip")

Public Function Email1(ByVal pvTo, ByVal pvSubj, ByVal pvBody, optional ByVal pvFile) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem

On Error GoTo ErrMail

    'NOTE  BE SURE YOU ADD OUTLOOK APP VIA  VBE menu:TOOLS, REFERENCES

Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)

With oMail
    .To = pvTo
    .Subject = pvSubj
    .Body = pvBody
    
    if not isempty(pvFile) then  .Attachments.Add pvFile, olByValue, 1
    .Send
End With

Email1 = True
Set oMail = Nothing
Set oApp = Nothing
Exit Function

ErrMail:
MsgBox Err.Description, vbCritical, Err
''Resume Next
End Function

 

[babafingo]

Thank You very much Ranman! This code is running very well.

God Bless You.