I'm trying to write a function that will load email from Lotus Notes and save the contents of the email to a table as well as save the attachments to disk.
I keep getting the error above when it gets to the "For Each oAttachment" line in the code blurb below. I've included the full code for the function after.
Any thoughts on what I'm missing?
Thanks.
I keep getting the error above when it gets to the "For Each oAttachment" line in the code blurb below. I've included the full code for the function after.
Any thoughts on what I'm missing?
Thanks.
Code:
If oDoc.HasEmbedded = True Then
For Each oAttachment In oDoc.EmbeddedObjects
Debug.Print oAttachment.Name & vbCrLf & oAttachment.Source
oAttachment.ExtractFile ("I:\Email Attachments\" & oAttachment.Name & oAttachment.Source)
Next oAttachment
End If
Code:
Public Function readLotusMail() As Long
'On Error Resume Next
Dim oSession As Object, oDB As Object, oView As Object, oDoc As Object, oAttachment As Object
Dim sServer, sFile, sFrom, sSubject, sBody As String, sTo As String, sCC As String, sBCC As String
Dim dDate As Date
Dim sSQL As String
Dim lCount As Long, lTest As Long
Dim rs As Recordset
sServer = "<REMOVED>"
sFile = "<REMOVED>"
Set oSession = CreateObject("Notes.NotesSession")
Set oDB = oSession.GetDatabase(sServer, sFile)
'Dim v As Variant 'Cycle through the database and print all view names to the debug window.
'For Each v In oDB.Views
' Debug.Print v.Name
'Next v
Set oView = oDB.GetView("($All)")
Set oDoc = oView.GetFirstDocument
lCount = 0
lTest = 0
Do Until oDoc Is Nothing
lTest = lCount
If lTest Mod 10000 = 0 Then
Debug.Print lCount
End If
'Check Date
On Error Resume Next
dDate = oDoc.GetFirstItem("DeliveredDate").Text
sFrom = removeDoubleQuotes(oDoc.GetFirstItem("INetFrom").Text)
If sFrom = "" Then
sFrom = removeDoubleQuotes(oDoc.GetFirstItem("From").Text)
End If
sTo = removeDoubleQuotes(oDoc.GetFirstItem("InetSendTo").Text)
If sTo = "" Then
sTo = removeDoubleQuotes(oDoc.GetFirstItem("SendTo").Text)
End If
sCC = removeDoubleQuotes(oDoc.GetFirstItem("INetCopyTo").Text)
If sCC = "" Then
sCC = removeDoubleQuotes(oDoc.GetFirstItem("CopyTo").Text)
End If
sBCC = removeDoubleQuotes(oDoc.GetFirstItem("INetBlindCopyTo").Text)
If sBCC = "" Then
sBCC = removeDoubleQuotes(oDoc.GetFirstItem("BlindCopyTo").Text)
End If
sSubject = removeDoubleQuotes(oDoc.GetFirstItem("Subject").Text)
sBody = oDoc.GetFirstItem("Body").Text
On Error GoTo 0
sSQL = "INSERT INTO tblEmails ( [FROM], [TO], [CC], [BCC], [SUBJECT], [DATESENT] ) " & _
"SELECT """ & sFrom & """, """ & sTo & """, """ & sCC & """, """ & sBCC & """, """ & sSubject & """, #" & dDate & "#;"
DoCmd.SetWarnings False
DoCmd.RunSQL sSQL
DoCmd.SetWarnings True
Set rs = CurrentDb.OpenRecordset("tblEmails", dbOpenDynaset)
rs.MoveLast
rs.Edit
rs![BODY] = sBody
rs.Update
rs.Close
Set rs = Nothing
'Check Attachment
If oDoc.HasEmbedded = True Then
For Each oAttachment In oDoc.EmbeddedObjects
Debug.Print oAttachment.Name & vbCrLf & oAttachment.Source
oAttachment.ExtractFile ("I:\Email Attachments\" & oAttachment.Name & oAttachment.Source)
Next oAttachment
End If
Set oDoc = oView.GetNextDocument(oDoc)
dDate = 0
sFrom = ""
sTo = ""
sCC = ""
sBCC = ""
sSubject = ""
sBody = ""
lCount = lCount + 1
Loop
Set oDoc = Nothing
Set oView = Nothing
Set oDB = Nothing
Set oSession = Nothing
End Function