Problem generating multiple Lotus Notes emails looping, without sending

T

themadmrj

New Member
Joined
Mar 17, 2014
Messages
4
Hi folks,

i'm new to the forum and need some help regarding VBA Lotus automation. All the topics i've seen and read (also on other forums) have helped me generate my emails (without sending) but i seem to have a problem that happens sometimes.
What i want : have my code loop through a file which determines if an email needs to be generated and generate as many emails as required.
Problem : so far i've successfully managed to generate my emails with incorporated signature, text and copypicture from required parts of the excel file. The problem is that sometimes it works flawlessly and sometimes it doesn't (can't figure out why), i.e. all emails are created with the maildb.createdocument lign but the content of all emails is gathered in the first email. So i end up with for instance 7 emails with the first one containing 7 bodies (with the right individual content) and 6 blank emails. I'm guessing it has sometimes to do with the focus but can't figure out what exactly. Is it a variable problem ? Lotus focus problem ?
Thanks in advance,

J.

P.S. I'm french, forgive my english. Also : I have never taken VBA classes and had to learn for myself, therefore what I do works but is very messy. I have just started reading a VBA book for tips & methods.

Code :

Code: 
Sub inquiry()
Dim wbs As Workbook
Dim wbm As Workbook
Dim wbsupp As Workbook
Dim wsssl As Object, wsmasteran As Object, wssupp As Object
Dim ss As String
Dim Maildb As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDoc As Object
Dim Session As Object
Dim Subject1 As String
Dim ccRecipient As String

ss = Workbooks("PC Tool.xlsm").Sheets("Anfragen").Range("B3").Value & Workbooks("PC Tool.xlsm").Sheets("Anfragen").Range("B4").Value
ll = Workbooks("PC Tool.xlsm").Sheets("Anfragen").Range("B7").Value & Workbooks("PC Tool.xlsm").Sheets("Anfragen").Range("B8").Value
Set wbm = ThisWorkbook
'open SSL and Supplier workbooks
On Error Resume Next
testifopen = Workbooks(ss).Sheets("SSL ").Range("A1").Value
If Err > 0 Then
Workbooks.Open Filename:=Workbooks("PC Tool.xlsm").Sheets("Anfragen").Range("B2").Value & "\" & ss, ReadOnly:=True
Err = 0
Else
End If
On Error Resume Next
testifopen = Workbooks(ll).Sheets("Actual HB Suppliers").Range("A1").Value
If Err > 0 Then Workbooks.Open Filename:=Workbooks("PC Tool.xlsm").Sheets("Anfragen").Range("B6").Value & "\" & ll, ReadOnly:=True
Set wbs = Workbooks(ss)
Set wbsupp = Workbooks(ll)
Set wsmasteran = wbm.Sheets("Anfragen")
Set wsssl = wbs.Sheets("SSL ")
Set wssupp = wbsupp.Sheets("Actual HB Suppliers")

Dim inwork As Object
Dim workspace As Object
'sort supplier list to prep
    wssupp.Range("table").Sort key1:=Range("A4"), order1:=xlAscending
    
        
For i = 1 To Application.WorksheetFunction.CountA(wsmasteran.Range("Q:Q")) - 1
    If wsmasteran.Range("O1").Value = "Automatic" Then
        If wsmasteran.Cells(1 + i, 17).Value = "Floor" Or wsmasteran.Cells(1 + i, 17).Value = "Staircase" Then
            head = wsssl.Range("A:E").Find(wsmasteran.Cells(1 + i, 17).Value, LookAt:=xlWhole).Row
            ligne = wsssl.Range("A:E").Find(wsmasteran.Cells(1 + i, 17).Value, LookAt:=xlWhole).Row + 1
        Else
            head = wsssl.Range("A:E").Find(wsmasteran.Cells(1 + i, 17).Value, LookAt:=xlPart).Row + 1
            ligne = wsssl.Range("A:E").Find(wsmasteran.Cells(1 + i, 17).Value, LookAt:=xlPart).Row + 2
        End If
    Else
        If wsmasteran.Cells(1 + i, 17).Value = "Floor" Or wsmasteran.Cells(1 + i, 17).Value = "Staircase" Then
            head = wsmasteran.Cells(1 + i, 19).Value
            ligne = wsmasteran.Cells(1 + i, 19).Value + 1
        Else
            head = wsmasteran.Cells(1 + i, 19).Value + 1
            ligne = wsmasteran.Cells(1 + i, 19).Value + 2
        End If
    End If
    
   
    If Len(wsssl.Cells(ligne, 1).Value) > 0 Then
cremail:
        If IsError(Application.WorksheetFunction.VLookup(wsssl.Cells(ligne, 10).Value, wssupp.Range("table"), 4, False)) = True Then
            Recipient = wssupp.Cells(Application.WorksheetFunction.Match(wsssl.Cells(ligne, 10).Value, wssupp.Range("A4:A500"), 1) + 4, 4).Value
            nom = wssupp.Cells(Application.WorksheetFunction.Match(wsssl.Cells(ligne, 10).Value, wssupp.Range("A4:A500"), 1) + 4, 6).Value
            english = wssupp.Cells(Application.WorksheetFunction.Match(wsssl.Cells(ligne, 10).Value, wssupp.Range("A4:A500"), 1) + 4, _
            wssupp.Range("A3:AZ3").Find("Vertragszusatz").Column).Value
        Else
            Recipient = wssupp.Cells(Application.WorksheetFunction.Match(wsssl.Cells(ligne, 10).Value, wssupp.Range("A4:A500"), 0) + 3, 4).Value
            nom = wssupp.Cells(Application.WorksheetFunction.Match(wsssl.Cells(ligne, 10).Value, wssupp.Range("A4:A500"), 0) + 3, 6).Value
            english = wssupp.Cells(Application.WorksheetFunction.Match(wsssl.Cells(ligne, 10).Value, wssupp.Range("A4:A500"), 0) + 3, _
            wssupp.Range("A3:AZ3").Find("Vertragszusatz").Column).Value
        End If
        proj = wsmasteran.Range("B10").Value
        
'copy picture to paste later
        picligne = ligne
pic:
        If Len(wsssl.Cells(picligne + 1, 10).Value) > 0 Then
            If wsssl.Cells(picligne + 1, 10).Value = wsssl.Cells(picligne, 10).Value Then
                If wsssl.Cells(picligne + 1, 1).Value > 0 Then
                    picligne = picligne + 1
                    GoTo pic
                End If
            End If
        End If
        
        wsssl.Range(wsssl.Cells(ligne, 1), wsssl.Cells(picligne, 9)).CopyPicture xlScreen, xlBitmap
        
'lotus part starts here
        Set Session = CreateObject("Notes.NotesSession")
        UserName = Session.UserName
        MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
        Set Maildb = Session.GETDATABASE("", MailDbName)
        
        If Maildb.IsOpen = True Then
        Else: Maildb.OPENMAIL
        End If
        Set MailDoc = Maildb.createdocument
        MailDoc.Form = "Memo"
        MailDoc.Sendto = Recipient
        
        If InStr(1, english, "AUF ENGLISCH") Then
            Subject1 = proj & "-Inquiry " & wsmasteran.Cells(1 + i, 17).Value
            body_text = "Dear " & nom & "," & Chr(10) & Chr(10) & "please submit me an offer for the above mentioned project as follows :" & Chr(10) & Chr(10)
        Else
            Subject1 = proj & "-Anfrage " & wsmasteran.Cells(1 + i, 18).Value
            body_text = "Hallo " & nom & "," & Chr(10) & Chr(10) & "bitte erstellen Sie mir für das o.g. Projekt ein Angebot wie folgt :" & Chr(10) & Chr(10)
        End If
        MailDoc.Subject = Subject1
        
        Set workspace = CreateObject("Notes.NotesUIWorkspace")
    '    Call workspace.EDITDocument(True, MailDoc).fieldsettext("body", body_text & Signature)
     
'paste picture
   '     Call workspace.EDITDocument(True, MailDoc)
        Set inwork = workspace.EDITDocument(True, MailDoc)
        inwork.GOTOFIELD ("Body")
        inwork.Paste
'paste headers
        wsssl.Range(wsssl.Cells(head, 1), wsssl.Cells(head, 9)).CopyPicture xlScreen, xlBitmap
        inwork.GOTOFIELD ("Body")
        inwork.Paste
'add text
        inwork.GOTOFIELD ("Body")
        inwork.inserttext (body_text)
       
        Set workspace = Nothing
        Set inwork = Nothing
        Set MailDoc = Nothing
        Set Session = Nothing
        Set Maildb = Nothing
 
        
'create another mail if multiple suppliers
recheck:
        If Len(wsssl.Cells(ligne + 1, 10).Value) > 0 Then
            If wsssl.Cells(ligne + 1, 1).Value > 0 Then
                If wsssl.Cells(ligne + 1, 10).Value = wsssl.Cells(ligne, 10).Value Then
                    ligne = ligne + 1
                    GoTo recheck
                Else
                    ligne = ligne + 1
                    GoTo cremail
                End If
            End If
        End If
            
            
        
    Else
    End If
    
 
Next i

        
'close workbooks
Application.DisplayAlerts = False
wbsupp.Close
wbs.Close
Application.DisplayAlerts = True
    
'get focus on lotus (problem if brower is open with lotus name in tab name)
Dim wd As Object
Dim tsk As Object
Set wd = CreateObject("word.application")
For Each tsk In wd.Tasks
    If InStr(tsk.Name, "Lotus") Then
        tsk.Activate
        tsk.WindowState = wdWindowStateMaximize
        End
    End If
Next
wd.Quit
Set wd = Nothing

End Sub
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Sort by date Sort by votes
"Is it a variable problem ?"

Possibly. I tried your code in a module, but got compilation errors. Put Option Explicit at the top of the module and declare all variables, using appropriate data types, though Variant will suffice, and compile the code until no errors occur.

The On Error Resume Next hides any run-time errors, so you should use On Error Goto 0 after the point where you have handled any errors yourself to reinstate the default VBA error handling.

The Lotus session and database stuff only needs to be initialised once, before the loop.

Finally, try to isolate the problem by simplifying the code and test data in a single workbook.
 
Upvote 0
Hmmm. Why would you get compilation errors when the code works for me ? Anyway I'll try declaring every variable and see if it helps. The thing is, only the part where data is added into lotus shows a problem, which would indicate that if it has anything to do with variables, it should be in the section starting at :
Code: 
[COLOR=#574123] [/COLOR][COLOR=#574123]        Set workspace = CreateObject("Notes.NotesUIWorkspace")[/COLOR]

    '    Call workspace.EDITDocument(True, MailDoc).fieldsettext("body", body_text & Signature)     'paste picture   '     Call workspace.EDITDocument(True, MailDoc) [FONT=Verdana] Set inwork = workspace.EDITDocument(True, MailDoc)[/FONT][COLOR=#222222][FONT=Verdana]
The difficulty for me is exactly that the code works without any error and does exactly what i want it to do... most of the time.As for the lotus database section, yes I tried to seperate it to make it clean and still didn't fix the problem. I didn't save the change and forgot to change it back, sorry ;)I guess I'll try your last suggestion then and remove everything but the lotus part and assigning simple values to my variables.[/FONT][/COLOR]</pre>
 
Upvote 0
Ok, I changed a few things and added option explicit. The mentioned problem seems only to happen from time to time when the workbook is opened and the macro executed for the FIRST TIME. Also, rarely but it happens, I got an lotus notes error I can't explain : $EXECUTE$+19:User-defined error
When the error occurs, the code still executes (no excel error) after i click "ok" and the body of the first email is to be found on the front page next to the "Mail" picture and not in a memo, as if the section
Code: 
If Maildb.IsOpen = True Then
Else: Maildb.OPENMAIL
End If
didn't execute. Why ?
Here's what the code looks like :

Code: 
Option Explicit
Sub inquiry()
Dim wbs As Workbook
Dim wbm As Workbook
Dim wbsupp As Workbook
Dim wsssl As Object, wsmasteran As Object, wssupp As Object
Dim ss As String, ll As String, testifopen As String
Dim i As Integer, ligne As Integer, head As Integer, picligne As Integer
Dim recipient As String, nom As String, english As String, proj As String, body_text As String
Dim Maildb As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDoc As Object
Dim Session As Object
Dim Subject1 As String
Dim wd As Object
Dim tsk As Object
Dim inwork As Object
Dim workspace As Object
 
ss = Workbooks("PC Tool.xlsm").Sheets("Anfragen").Range("B3").Value & Workbooks("PC Tool.xlsm").Sheets("Anfragen").Range("B4").Value
ll = Workbooks("PC Tool.xlsm").Sheets("Anfragen").Range("B7").Value & Workbooks("PC Tool.xlsm").Sheets("Anfragen").Range("B8").Value
Set wbm = ThisWorkbook
'open SSL and Supplier workbooks
On Error Resume Next
testifopen = Workbooks(ss).Sheets("SSL ").Range("A1").Value
If Err > 0 Then
Workbooks.Open Filename:=Workbooks("PC Tool.xlsm").Sheets("Anfragen").Range("B2").Value & "\" & ss, ReadOnly:=True
Err = 0
Else
End If
On Error Resume Next
testifopen = Workbooks(ll).Sheets("Actual HB Suppliers").Range("A1").Value
If Err > 0 Then Workbooks.Open Filename:=Workbooks("PC Tool.xlsm").Sheets("Anfragen").Range("B6").Value & "\" & ll, ReadOnly:=True
Set wbs = Workbooks(ss)
Set wbsupp = Workbooks(ll)
Set wsmasteran = wbm.Sheets("Anfragen")
Set wsssl = wbs.Sheets("SSL ")
Set wssupp = wbsupp.Sheets("Actual HB Suppliers")
'sort supplier list to prep
wssupp.Range("table").Sort key1:=Range("A4"), order1:=xlAscending
    
wsssl.Range("F7").Value = Replace(wsssl.Range("F7").Value, "&", "+")
        
'setup lotus database
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GETDATABASE("", MailDbName)
                
If Maildb.IsOpen = True Then
Else: Maildb.OPENMAIL
End If
        
'start loop
For i = 1 To Application.WorksheetFunction.CountA(wsmasteran.Range("Q:Q")) - 1
    If wsmasteran.Range("O1").Value = "Automatic" Then
        If wsmasteran.Cells(1 + i, 17).Value = "Floor" Or wsmasteran.Cells(1 + i, 17).Value = "Staircase" Then
            head = wsssl.Range("A:E").Find(wsmasteran.Cells(1 + i, 17).Value, LookAt:=xlWhole).Row
            ligne = wsssl.Range("A:E").Find(wsmasteran.Cells(1 + i, 17).Value, LookAt:=xlWhole).Row + 1
        ElseIf wsmasteran.Cells(1 + i, 17).Value = "Lightbox" Then
            head = wsssl.Range("A:E").Find(wsmasteran.Cells(1 + i, 17).Value & "*", LookAt:=xlWhole).Row + 1
            ligne = wsssl.Range("A:E").Find(wsmasteran.Cells(1 + i, 17).Value & "*", LookAt:=xlWhole).Row + 2
        Else
            head = wsssl.Range("A:E").Find(wsmasteran.Cells(1 + i, 17).Value, LookAt:=xlPart).Row + 1
            ligne = wsssl.Range("A:E").Find(wsmasteran.Cells(1 + i, 17).Value, LookAt:=xlPart).Row + 2
        End If
    Else
        If wsmasteran.Cells(1 + i, 17).Value = "Floor" Or wsmasteran.Cells(1 + i, 17).Value = "Staircase" Then
            head = wsmasteran.Cells(1 + i, 19).Value
            ligne = wsmasteran.Cells(1 + i, 19).Value + 1
        Else
            head = wsmasteran.Cells(1 + i, 19).Value + 1
            ligne = wsmasteran.Cells(1 + i, 19).Value + 2
        End If
    End If
    
    If wsmasteran.Cells(1 + i, 17).Value = "Floor" Or wsmasteran.Cells(1 + i, 17).Value = "Staircase" Then
        If Len(wsssl.Cells(ligne, 10).Value) > 0 Then
            GoTo cremail
        Else
            GoTo recheck
        End If
        
    Else
        
        If Len(wsssl.Cells(ligne, 1).Value) > 0 Then
cremail:
    'tests here for supplier lign not to be considered
            If InStr(1, UCase(wsssl.Cells(ligne, 10).Value), UCase("furniture")) Or InStr(1, UCase(wsssl.Cells(ligne, 10).Value), UCase("hb")) Or _
            UCase(wsssl.Cells(ligne, 10).Value) Like "*BOSS*" Or Replace(wsssl.Cells(ligne, 10).Value, "&", "+") = wsssl.Range("F7").Value Then
            Else
    'once lign has to be considered, gather information
                If IsError(Application.WorksheetFunction.VLookup(wsssl.Cells(ligne, 10).Value, wssupp.Range("table"), 4, False)) = True Then
                    recipient = wssupp.Cells(Application.WorksheetFunction.Match(wsssl.Cells(ligne, 10).Value, wssupp.Range("A4:A500"), 1) + 4, 4).Value
                    nom = wssupp.Cells(Application.WorksheetFunction.Match(wsssl.Cells(ligne, 10).Value, wssupp.Range("A4:A500"), 1) + 4, 6).Value
                    english = wssupp.Cells(Application.WorksheetFunction.Match(wsssl.Cells(ligne, 10).Value, wssupp.Range("A4:A500"), 1) + 4, _
                    wssupp.Range("A3:AZ3").Find("Vertragszusatz").Column).Value
                Else
                    recipient = wssupp.Cells(Application.WorksheetFunction.Match(wsssl.Cells(ligne, 10).Value, wssupp.Range("A4:A500"), 0) + 3, 4).Value
                    nom = wssupp.Cells(Application.WorksheetFunction.Match(wsssl.Cells(ligne, 10).Value, wssupp.Range("A4:A500"), 0) + 3, 6).Value
                    english = wssupp.Cells(Application.WorksheetFunction.Match(wsssl.Cells(ligne, 10).Value, wssupp.Range("A4:A500"), 0) + 3, _
                    wssupp.Range("A3:AZ3").Find("Vertragszusatz").Column).Value
                End If
                proj = wsmasteran.Range("B10").Value
                
        'copy picture to paste later
                picligne = ligne
pic:
                If Len(wsssl.Cells(picligne + 1, 10).Value) > 0 Then
                    If wsssl.Cells(picligne + 1, 10).Value = wsssl.Cells(picligne, 10).Value Then
                        If wsmasteran.Cells(1 + i, 17).Value = "Floor" Or wsmasteran.Cells(1 + i, 17).Value = "Staircase" Then
                            picligne = picligne + 1
                            GoTo pic
                        ElseIf wsssl.Cells(picligne + 1, 1).Value > 0 Then
                                picligne = picligne + 1
                                GoTo pic
                        End If
                    End If
                End If
                
                wsssl.Range(wsssl.Cells(ligne, 1), wsssl.Cells(picligne, 9)).CopyPicture xlScreen, xlBitmap
                
        'lotus part starts here
                Set MailDoc = Maildb.createdocument
                MailDoc.Form = "Memo"
                MailDoc.Sendto = recipient
                
                If InStr(1, english, "AUF ENGLISCH") Then
                    Subject1 = proj & "-Inquiry " & wsmasteran.Cells(1 + i, 17).Value
                    body_text = "Dear " & nom & "," & Chr(10) & Chr(10) & "please submit me an offer for the above mentioned project as follows :" & Chr(10) & Chr(10)
                Else
                    Subject1 = proj & "-Anfrage " & wsmasteran.Cells(1 + i, 18).Value
                    body_text = "Hallo " & nom & "," & Chr(10) & Chr(10) & "bitte erstellen Sie mir für das o.g. Projekt ein Angebot wie folgt :" & Chr(10) & Chr(10)
                End If
                MailDoc.Subject = Subject1
                
                Set workspace = CreateObject("Notes.NotesUIWorkspace")
            '    Call workspace.EDITDocument(True, MailDoc).fieldsettext("body", body_text & Signature)
             
        'paste picture
           '     Call workspace.EDITDocument(True, MailDoc)
                Set inwork = workspace.EDITDocument(True, MailDoc)
                inwork.GOTOFIELD ("Body")
                inwork.Paste
        'paste headers
                wsssl.Range(wsssl.Cells(head, 1), wsssl.Cells(head, 9)).CopyPicture xlScreen, xlBitmap
                inwork.GOTOFIELD ("Body")
                inwork.Paste
        'add text
                inwork.GOTOFIELD ("Body")
                inwork.inserttext (body_text)
               
                Set workspace = Nothing
                Set inwork = Nothing
                Set MailDoc = Nothing
        
            End If
        
                
        'create another mail if multiple suppliers
recheck:
            If Len(wsssl.Cells(ligne + 1, 10).Value) > 0 Then
                If wsmasteran.Cells(1 + i, 17).Value = "Floor" Or wsmasteran.Cells(1 + i, 17).Value = "Staircase" Then
                    If wsssl.Cells(ligne + 1, 10).Value = wsssl.Cells(ligne, 10).Value Then
                        ligne = ligne + 1
                        GoTo recheck
                    Else
                        ligne = ligne + 1
                        GoTo cremail
                    End If
                Else
                    If wsssl.Cells(ligne + 1, 1).Value > 0 Then
                        If wsssl.Cells(ligne + 1, 10).Value = wsssl.Cells(ligne, 10).Value Then
                            ligne = ligne + 1
                            GoTo recheck
                        Else
                            ligne = ligne + 1
                            GoTo cremail
                        End If
                    End If
                End If
            End If
                
                
            
        Else
        End If
    End If
 
Next i
Set Session = Nothing
Set Maildb = Nothing
        
'close workbooks
Application.DisplayAlerts = False
wbsupp.Close savechanges:=False
wbs.Close savechanges:=False
Application.DisplayAlerts = True
    
'get focus on lotus (problem if brower is open with lotus name in tab name)
Set wd = CreateObject("word.application")
For Each tsk In wd.Tasks
    If InStr(tsk.Name, "Lotus") Then
        tsk.Activate
        tsk.WindowState = wd.WindowStateMaximize
        End
    End If
Next
wd.Quit
Set wd = Nothing

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Listbox2 value send email
Replies
9
Views
255
Domenic
D
R
  • Question
First Email Sends, but Second Email Fails during Loop
Replies
2
Views
304
reberryjr
R
P
  • Solved
VBA to send multiple emails, run time error 440 after ~30 emails
Replies
5
Views
845
Domenic
D
A
  • Solved
Record the sent date after executing Excel send email VBA
Replies
5
Views
665
amanphilip
A
D
  • Solved
VBA Lotus Notes using MIME HTML and attaching a PDF in Email Body
Replies
3
Views
2K
John_w
J

Forum statistics

Threads
1,214,920
Messages
6,122,269
Members
449,075
Latest member
staticfluids

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top