VBA Download files from Lotus Notes - vba

Question

Im trying to download attachment from certain Lotus Notes e-mails. The code below works but it goes in infinite loop (code execution never ends after the procedure) after saving all required files. Something is wrong with Do until command I guess. Would appreaciate some help in fixing this issue.
Sub Test2Dobre()
Dim sess As Object
Dim db As Object
Dim view As Object
Dim doc As Object
Dim docNext As Object
Dim mailServer As String
Dim mailFile As String
Dim fld1 As String
Dim strSQL As String
Const stPath As String = "C:\Users\kuckam\Desktop\test notes\"
Const EMBED_ATTACHMENT As Long = 1454
Const RICHTEXT As Long = 1
Dim vaItem As Variant
Dim vaAttachment As Variant
Set sess = CreateObject("Notes.NotesSession")
'Call sess.Initialize(Password)
Dim objADOConnection As Object
Set objADOConnection = CreateObject("ADODB.Connection")
'to get your mail db:
mailServer = sess.GetEnvironmentString("MailServer", True)
mailFile = sess.GetEnvironmentString("MailFile", True)
Set db = sess.GetDatabase(mailServer, mailFile)
'Get Inbox folder:
Set view = db.GetView("($Inbox)")
'Loop through all documents in Inbox:
Set doc = view.GetFirstDocument
Do Until doc Is Nothing
Set docNext = view.GetNextDocument(doc)
If doc.HasEmbedded And doc.GetItemValue("From")(0) = "<Protokoly.warszawa#linde-mh.pl>" Then
MsgBox doc.GetItemValue("subject")(0)
'MsgBox doc.GetItemValue("From")(0)
'Check if the document has an attachment or not.
Set vaItem = doc.GetFirstItem("Body")
If vaItem.Type = RICHTEXT Then
For Each vaAttachment In vaItem.EmbeddedObjects
If vaAttachment.Type = EMBED_ATTACHMENT Then
'Save the attached file into the new folder and remove it from the e-mail.
With vaAttachment
.ExtractFile stPath & vaAttachment.Name
' .Remove
End With
End If
Next vaAttachment
End If
End If
Set doc = docNext
Loop
End Sub
EDIT:
Posting working code:
Function ADOExecSQL(strSQL As String)
ADOExecSQL = 1
On Error GoTo ERROR_FUNCTION
If ADODbConnect() = 0 Then GoTo ERROR_FUNCTION
cnConn.Execute strSQL
EXIT_FUNCTION:
Exit Function
ERROR_FUNCTION:
ADOExecSQL = 0
GoTo EXIT_FUNCTION
End Function
Sub Test2Dobre()
Dim sess As Object
Dim db As Object
Dim view As Object
Dim doc As Object
Dim docNext As Object
Dim mailServer As String
Dim mailFile As String
Dim fld1 As String
Dim strSQL As String
Const stPath As String = "C:\Users\kuckam\Desktop\test notes\"
Const EMBED_ATTACHMENT As Long = 1454
Const RICHTEXT As Long = 1
Dim vaItem As Variant
Dim vaAttachment As Variant
Set sess = CreateObject("Notes.NotesSession")
'Call sess.Initialize(Password)
Dim objADOConnection As Object
Set objADOConnection = CreateObject("ADODB.Connection")
'to get your mail db:
mailServer = sess.GetEnvironmentString("MailServer", True)
mailFile = sess.GetEnvironmentString("MailFile", True)
Set db = sess.GetDatabase(mailServer, mailFile)
'Get Inbox folder:
Set view = db.GetView("($Inbox)")
view.AutoUpdate = False
'Loop through all documents in Inbox:
Set doc = view.GetFirstDocument
Do Until doc Is Nothing
Set docNext = view.GetNextDocument(doc)
'If doc.HasEmbedded And doc.GetItemValue("From")(0) = "<Protokoly.warszawa#linde-mh.pl>" Then
'If doc.GetItemValue("From")(0) = "<Protokoly.warszawa#linde-mh.pl>" Then
'MsgBox doc.GetItemValue("subject")(0)
'MsgBox doc.GetItemValue("From")(0)
'Check if the document has an attachment or not.
Set vaItem = doc.GetFirstItem("Body")
On Error GoTo Line1
If vaItem.Type = RICHTEXT And doc.GetItemValue("From")(0) = "<Protokoly.warszawa#linde-mh.pl>" Then
For Each vaAttachment In vaItem.EmbeddedObjects
If vaAttachment.Type = EMBED_ATTACHMENT Then
'Save the attached file into the new folder and remove it from the e-mail.
With vaAttachment
.ExtractFile stPath & vaAttachment.Name
' .Remove
End With
End If
'Save the e-mail in order to reflect the deleting of the attached file.
'(A more sophisticated approach may be considered if several e-mails have
'several attachments in order to avoid a repeately saving of one e-mail.)
doc.Save True, False
Next vaAttachment
End If
'End If
'Call Attachment.ExtractFile("C:\Users\kuckam\Desktop\test notes")
'Call doc.PutInFolder("C:\Users\kuckam\Desktop\test notes")
Set doc = docNext
Loop
'Release objects from memory.
Set docNext = Nothing
Set doc = Nothing
Set view = Nothing
Set sess = Nothing
Set db = Nothing
Set objADOConnection = Nothing
Set vaItem = Nothing
Line1:
End Sub