Hi,
I'm experiencing an issue in the code below. Basically the code connects to an inbox and saves down all pdf attachments, marks the mail as read and then archives the email.
This works most of the time but it does crash out with a error 424 object required about 3 times a day (it is on a 1 min interval timer to run)
Could you please take a look and see if you can suggest anything to stop this error?
It crashes out at this line
I'm experiencing an issue in the code below. Basically the code connects to an inbox and saves down all pdf attachments, marks the mail as read and then archives the email.
This works most of the time but it does crash out with a error 424 object required about 3 times a day (it is on a 1 min interval timer to run)
Could you please take a look and see if you can suggest anything to stop this error?
It crashes out at this line
Code:
For Each att In Item.attachments
Code:
Public Sub CheckEmails()
On Error GoTo errh
DoEvents
FilePath = GetServerPath() & "Data\"
Dim olObj As Object
Set olObj = ConnectOutlook
With olObj
' .sendrecieve
Dim oNS As Object
Dim oFolder As Object
Dim oTarget As Object
Dim colSyc As Object, objSyc As Object
Dim olMail As Object
Dim i As Integer
Dim X As Variant
Set oNS = .Application.GetNamespace("MAPI")
Set colSyc = oNS.SyncObjects
For i = 1 To colSyc.Count
Set objSyc = colSyc.Item(i)
Debug.Print objSyc.Name
objSyc.start
Next
'find the accounts receivable folder and set it as the target
For Each oFolder In oNS.folders
If oFolder.Name = "Email Inbox" Then
Set oTarget = oFolder.folders.Item("Inbox")
Exit For
End If
Next
If Not (oTarget Is Nothing) Then
MoreData: 'drops out of loop before it's finished, so re start here
Set olMail = oTarget.Items.Restrict("[UnRead] = True") 'process only unread emails
If olMail.Count > 0 Then
For Each Item In olMail
'Process each mailitem here
For Each att In Item.attachments
If LCase(Right(att.FileName, 4)) = ".pdf" Then
test = att.FileName
emailaddress = Item.sender
att.SaveAsFile FilePath & Replace(att.FileName, ".pdf", "-" & Format(Now(), "YYYYMMDDHHSS") & ".pdf") 'save the attachment
Item.unread = False 'mark the email as read
Item.UserProperties.Add "Processed", 1
Item.Save
LogFileMacro
Else
Item.unread = False 'mark the email as read
Item.Save
End If
Next att
Item.unread = False 'mark the email as read
Item.Save
DoEvents
Next Item
Else
GoTo ArchiveNow
'Exit Sub
End If
Else
Exit Sub
End If
End With
'check to see if its dropped out early
If olMail.Count > 0 Then
Debug.Print olMail.Count
GoTo MoreData
End If
ArchiveNow:
'delete any deleted items with "Processed" userproperty
Dim myOlApp, myNameSpace, Sel, objRecip As Object
Dim MyItem As Object
Dim ArchiveFolder As Object
Dim objProperty As Object
'For Each oFolder In oNS.folders
' If InStr(1, oFolder.Name, "@domainname.co.uk", vbTextCompare) > 0 Then
' Set oTarget = oFolder.folders.Item("Deleted Items")
' Exit For
' End If
'Next
Set ArchiveFolder = oFolder.folders.Item("Archive")
If Not (oTarget Is Nothing) Then
DeleteMoreData:
For Each MyItem In oTarget.Items
Set objProperty = MyItem.UserProperties.Find("Processed")
If TypeName(objProperty) <> "Nothing" Then
MyItem.Move ArchiveFolder
End If
DoEvents
Next
End If
'Stop
'check to see if its dropped out early
If oTarget.Items.Count > 0 Then
For Each MyItem In oTarget.Items
Set objProperty = MyItem.UserProperties.Find("Processed")
If TypeName(objProperty) <> "Nothing" Then
Debug.Print oTarget.Items.Count
GoTo DeleteMoreData
End If
DoEvents
Next
End If
Exit Sub
errh:
Debug.Print Err.Description
'Stop
Err.Clear
On Error GoTo 0
On Error GoTo errh
GoTo MoreData 'Resume Previous
End Sub