Solved

For Each olMail In OlItems, Outlook and Visual Basic

Posted on 2004-04-08
18
1,468 Views
Last Modified: 2013-11-25
I am trying to loop through my emails and process them but for some reason it only grabs about 1/2 of them each time.  I have traced it in the program and it just skips half.  Here is the code I know it is long but the top and bottom are really the only things that matter as all the if statements in the middle are almost the same with a slightly different set of process rules but it has nothing to do with the for loop and that is what seems to be messing up.  If I run it again it does the same thing...it gets about half of the emails and it keeps doing this each time I run it till there are not any emails left which is good but I only want to run it one time and it process them all.


Dim rst As Recordset
Dim x
Dim strEmail
Dim intQuota
Dim theDate
Dim dbMyDB As ADODB.Connection
Dim rsEmail As ADODB.Recordset
 Set Connect = New ADODB.Connection
 Connect.Open "DSN=hal;UID=edcust;PWD=;"
theDate = Date

Set olApp = CreateObject("Outlook.Application") ' or Set OlApp = New Outlook.Application
Set OlMapi = olApp.GetNamespace("MAPI")

'Normal Outlook folder is called [Personal Folders], I called mine [2004-Emails],
'Then the Inbox, then the subfolder in the Unbox is called "SiteForms"
Set OlFolder = OlMapi.Folders("Personal Folders").Folders("Bad Emails").Folders("test")
Set OlItems = OlFolder.Items    ' - For each mail in the collection check the subject line and process accordingly


    NoNewMessages = 0   'No new message initialized
    NoDuplicate = 0     'No Duplicates initialized
For Each olMail In OlItems

    If olMail.UnRead = True Then
    NoNewMessages = NoNewMessages + 1 'new messages exist
   
        'MsgBox OlMail.Subject & Chr(10) & OlMail.ReceivedTime & Chr(10) & OlMail.Body
        'Only read messages with "Recruitment Form from Site" in the subject
       If UCase(Mid(olMail.Subject, 1, 16)) = "DELIVERY FAILURE" Then
       
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
             Do While Not EOF(1) And x < 7    ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
                strEmail = Trim(textLine)
                x = x + 1
            Loop
            Close #1            'Close the input file and move to the next file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then

                        Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Delivery Failure', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Delivery Failure', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    'strEmailMarkedType
                    'intTimesEmailMarked
                    'dtEmailMarked
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
               
            End If
        ElseIf UCase(Mid(olMail.Subject, 1, 38)) = "DELIVERY STATUS NOTIFICATION (FAILURE)" Then
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
             Do While Not EOF(1) And x < 5    ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
                strEmail = Trim(textLine)
                x = x + 1
            Loop
            Close #1            'Close the input file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then

                        Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Delivery Status Notification (Failure)', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Delivery Status Notification (Failure)', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
            End If
        ElseIf UCase(Mid(olMail.Subject, 1, 14)) = "FAILURE NOTICE" Then
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
            intQuota = 0
             Do While Not EOF(1)    ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
                If InStr(1, textLine, "Quota", 1) > 0 Then
                    intQuota = 1
                End If
               
                If Mid(textLine, 1, 3) = "To:" And x = 0 Then
                    strEmail = Trim(Mid(textLine, 5))
                    x = 1
                End If
            Loop
            Close #1            'Close the input file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then
                        If intQuota <> 0 Then
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times Because of Quota" & rsEmail("email") & "', strEmailMarkedType = 'Failure Notice', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                       
                        Else
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Failure Notice', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                        End If
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Failure Notice', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    'strEmailMarkedType
                    'intTimesEmailMarked
                    'dtEmailMarked
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
            End If
        ElseIf UCase(Mid(olMail.Subject, 1, 41)) = UCase("Returned mail: see transcript for details") Then
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
            intQuota = 0
             Do While Not EOF(1)    ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
                If InStr(1, textLine, "Quota", 1) > 0 Then
                    intQuota = 1
                End If
               
                If Mid(textLine, 10, 50) = "The following addresses had permanent fatal errors" And x = 0 Then
                    strEmail = Trim(Mid(textLine, 68))
                    strEmail = Replace(strEmail, ">", "")
                    x = 1
                End If
            Loop
            Close #1            'Close the input file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then
                        If intQuota <> 0 Then
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times Because of Quota" & rsEmail("email") & "', strEmailMarkedType = 'Returned mail:', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                       
                        Else
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Returned mail:', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                        End If
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Returned mail:', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    'strEmailMarkedType
                    'intTimesEmailMarked
                    'dtEmailMarked
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
            End If
        ElseIf UCase(Mid(olMail.Subject, 1, 27)) = UCase("Returned mail: User unknown") Then
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
            intQuota = 0
             Do While Not EOF(1)    ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
               
                If Mid(textLine, 1, 5) = "550 <" And x = 0 Then
                    strEmail = Trim(Mid(textLine, 6))
                    x = InStr(1, strEmail, ">", 1)
                    strEmail = Mid(strEmail, 1, x - 1)
                    x = 1
                End If
            Loop
            Close #1            'Close the input file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then
                        If intQuota <> 0 Then
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times Because of Quota" & rsEmail("email") & "', strEmailMarkedType = 'Returned mail: User unknown', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                       
                        Else
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Returned mail: User unknown', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                        End If
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Returned mail: User unknown', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    'strEmailMarkedType
                    'intTimesEmailMarked
                    'dtEmailMarked
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
            End If
        ElseIf UCase(Mid(olMail.Subject, 1, 41)) = UCase("Undeliverable Mail Returned to Sender") Then
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
            intQuota = 0
             Do While Not EOF(1)     ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
                If InStr(1, textLine, "Quota", 1) > 0 Then
                    intQuota = 1
                End If
                If Mid(textLine, 1, 3) = "To:" And x = 0 Then
                    strEmail = Trim(Mid(textLine, 5))
                    x = 1
                End If
            Loop
            Close #1            'Close the input file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then
                        If intQuota <> 0 Then
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times Because of Quota " & rsEmail("email") & "', strEmailMarkedType = 'Undeliverable Mail Returned to Sender', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                       
                        Else
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Undeliverable Mail Returned to Sender', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                        End If
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Undeliverable Mail Returned to Sender', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    'strEmailMarkedType
                    'intTimesEmailMarked
                    'dtEmailMarked
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
            End If
        ElseIf UCase(Mid(olMail.Subject, 1, 14)) = UCase("Undeliverable:") Then
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
            intQuota = 0
             Do While Not EOF(1)     ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
                If InStr(1, textLine, "Quota", 1) > 0 Then
                    intQuota = 1
                End If
                If Mid(textLine, 3, 3) = "To:" And x = 0 Then
                    strEmail = Trim(Mid(textLine, 4))
                    x = 1
                End If
            Loop
            Close #1            'Close the input file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then
                        If intQuota <> 0 Then
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times Because of Quota " & rsEmail("email") & "', strEmailMarkedType = 'Undeliverable Mail Returned to Sender', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                       
                        Else
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Undeliverable Mail Returned to Sender', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                        End If
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Undeliverable Mail Returned to Sender', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    'strEmailMarkedType
                    'intTimesEmailMarked
                    'dtEmailMarked
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
            End If
        Else
            olMail.Subject = "This Needs To Be Processed"
            olMail.UnRead = False
        End If  'Subject
'NextMessage:
           
                   ' olMail.UnRead = False 'Mark mail as read, if that's necessary !?
            ''        Rst.AddNew
            ''        Rst!name = OlMail.SenderName
            ''        Rst!Subject = OlMail.Subject
            ''        Rst!datesent = OlMail.ReceivedTime
            ''        Rst.Update
                   
            End If  'UnRead


Next
0
Comment
Question by:Hook333
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 10
  • 6
  • 2
18 Comments
 
LVL 28

Expert Comment

by:vinnyd79
ID: 10789030
I think the problem is with deleting the mailitem.I would put the routine into a function that exits and Returns a boolean of True after successfully processing 1 item and false when no items are left.Then call the function until it returns false.
0
 

Author Comment

by:Hook333
ID: 10791844
If I follow the code it does not actually even get to some of the emails but I did check and it is deleting everyone that it gets too.
0
 
LVL 28

Expert Comment

by:vinnyd79
ID: 10791893
Yes,but for everyone it deletes it will skip 1. Thats why it only process' half of them at a time.
0
Online Training Solution

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action. Forget about retraining and skyrocket knowledge retention rates.

 

Author Comment

by:Hook333
ID: 10791906
For Each olMail In OlItems
olMail.Delete
Next

I tried this only and it is only going through half the emails still so its some problem with this.  Its not the delete as every email it does get to it deletes it just does not get to them all.
0
 

Author Comment

by:Hook333
ID: 10791930
Oh I understand what you are saying is there a way to go back an item?
0
 

Author Comment

by:Hook333
ID: 10791939
I dont want to do the function thing as I only want to delete them after each process as some are not being deleted.
0
 

Author Comment

by:Hook333
ID: 10792061
Ok i just tried putting that in a function just to make sure it was not moving to next item and it is not.  After I put it into function it still only gets half of them....its almost like it is not seeing the rest.
0
 

Author Comment

by:Hook333
ID: 10792082
This is what i tried


For Each olMail In OlItems
Call delete(olMail)
Next



Function delete(s)
s.delete
End Function
0
 
LVL 27

Expert Comment

by:jjafferr
ID: 10792196
Hi Hook333,

Why don't you finish reading your emails, once finished,
do another loop to delete ONLY the READ emails.

Hope this helps

jaffer
0
 

Author Comment

by:Hook333
ID: 10792214
jaffer I tried the code below alone and it still would only delete half of them.

For Each olMail In OlItems
Call delete(olMail)
Next



Function delete(s)
s.delete
End Function
0
 
LVL 28

Expert Comment

by:vinnyd79
ID: 10792270
I was thinking of something like this:


Public Function ProcessMail() As Boolean

End Function
Dim rst As Recordset
Dim x
Dim strEmail
Dim intQuota
Dim theDate
Dim dbMyDB As ADODB.Connection
Dim rsEmail As ADODB.Recordset
 Set Connect = New ADODB.Connection
 Connect.Open "DSN=hal;UID=edcust;PWD=;"
theDate = Date

Set olApp = CreateObject("Outlook.Application") ' or Set OlApp = New Outlook.Application
Set OlMapi = olApp.GetNamespace("MAPI")

'Normal Outlook folder is called [Personal Folders], I called mine [2004-Emails],
'Then the Inbox, then the subfolder in the Unbox is called "SiteForms"
Set OlFolder = OlMapi.Folders("Personal Folders").Folders("Bad Emails").Folders("test")
Set OlItems = OlFolder.Items    ' - For each mail in the collection check the subject line and process accordingly


    NoNewMessages = 0   'No new message initialized
    NoDuplicate = 0     'No Duplicates initialized
For Each olMail In OlItems

    If olMail.UnRead = True Then
    NoNewMessages = NoNewMessages + 1 'new messages exist
   
        'MsgBox OlMail.Subject & Chr(10) & OlMail.ReceivedTime & Chr(10) & OlMail.Body
        'Only read messages with "Recruitment Form from Site" in the subject
       If UCase(Mid(olMail.Subject, 1, 16)) = "DELIVERY FAILURE" Then
       
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
             Do While Not EOF(1) And x < 7    ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
                strEmail = Trim(textLine)
                x = x + 1
            Loop
            Close #1            'Close the input file and move to the next file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then

                        Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Delivery Failure', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Delivery Failure', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    'strEmailMarkedType
                    'intTimesEmailMarked
                    'dtEmailMarked
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
               
            End If
        ElseIf UCase(Mid(olMail.Subject, 1, 38)) = "DELIVERY STATUS NOTIFICATION (FAILURE)" Then
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
             Do While Not EOF(1) And x < 5    ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
                strEmail = Trim(textLine)
                x = x + 1
            Loop
            Close #1            'Close the input file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then

                        Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Delivery Status Notification (Failure)', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Delivery Status Notification (Failure)', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
            End If
        ElseIf UCase(Mid(olMail.Subject, 1, 14)) = "FAILURE NOTICE" Then
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
            intQuota = 0
             Do While Not EOF(1)    ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
                If InStr(1, textLine, "Quota", 1) > 0 Then
                    intQuota = 1
                End If
               
                If Mid(textLine, 1, 3) = "To:" And x = 0 Then
                    strEmail = Trim(Mid(textLine, 5))
                    x = 1
                End If
            Loop
            Close #1            'Close the input file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then
                        If intQuota <> 0 Then
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times Because of Quota" & rsEmail("email") & "', strEmailMarkedType = 'Failure Notice', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                       
                        Else
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Failure Notice', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                        End If
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Failure Notice', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    'strEmailMarkedType
                    'intTimesEmailMarked
                    'dtEmailMarked
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
            End If
        ElseIf UCase(Mid(olMail.Subject, 1, 41)) = UCase("Returned mail: see transcript for details") Then
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
            intQuota = 0
             Do While Not EOF(1)    ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
                If InStr(1, textLine, "Quota", 1) > 0 Then
                    intQuota = 1
                End If
               
                If Mid(textLine, 10, 50) = "The following addresses had permanent fatal errors" And x = 0 Then
                    strEmail = Trim(Mid(textLine, 68))
                    strEmail = Replace(strEmail, ">", "")
                    x = 1
                End If
            Loop
            Close #1            'Close the input file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then
                        If intQuota <> 0 Then
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times Because of Quota" & rsEmail("email") & "', strEmailMarkedType = 'Returned mail:', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                       
                        Else
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Returned mail:', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                        End If
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Returned mail:', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    'strEmailMarkedType
                    'intTimesEmailMarked
                    'dtEmailMarked
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
            End If
        ElseIf UCase(Mid(olMail.Subject, 1, 27)) = UCase("Returned mail: User unknown") Then
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
            intQuota = 0
             Do While Not EOF(1)    ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
               
                If Mid(textLine, 1, 5) = "550 <" And x = 0 Then
                    strEmail = Trim(Mid(textLine, 6))
                    x = InStr(1, strEmail, ">", 1)
                    strEmail = Mid(strEmail, 1, x - 1)
                    x = 1
                End If
            Loop
            Close #1            'Close the input file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then
                        If intQuota <> 0 Then
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times Because of Quota" & rsEmail("email") & "', strEmailMarkedType = 'Returned mail: User unknown', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                       
                        Else
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Returned mail: User unknown', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                        End If
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Returned mail: User unknown', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    'strEmailMarkedType
                    'intTimesEmailMarked
                    'dtEmailMarked
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
            End If
        ElseIf UCase(Mid(olMail.Subject, 1, 41)) = UCase("Undeliverable Mail Returned to Sender") Then
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
            intQuota = 0
             Do While Not EOF(1)     ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
                If InStr(1, textLine, "Quota", 1) > 0 Then
                    intQuota = 1
                End If
                If Mid(textLine, 1, 3) = "To:" And x = 0 Then
                    strEmail = Trim(Mid(textLine, 5))
                    x = 1
                End If
            Loop
            Close #1            'Close the input file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then
                        If intQuota <> 0 Then
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times Because of Quota " & rsEmail("email") & "', strEmailMarkedType = 'Undeliverable Mail Returned to Sender', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                       
                        Else
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Undeliverable Mail Returned to Sender', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                        End If
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Undeliverable Mail Returned to Sender', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                    Else
                      olMail.Delete
                    End If
                    'strEmailMarkedType
                    'intTimesEmailMarked
                    'dtEmailMarked
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
            End If
        ElseIf UCase(Mid(olMail.Subject, 1, 14)) = UCase("Undeliverable:") Then
            Open "C:\DeleteMe.txt" For Output As #1    ' Open file for output.
             Print #1, olMail.Body                     ' Print text to file.
            Close #1
           
            Open "C:\DeleteMe.txt" For Input As #1    ' Open file for input.
            x = 0
            strEmail = ""
            intQuota = 0
             Do While Not EOF(1)     ' Loop until we get to line with email address.
                Line Input #1, textLine    ' Read line into variable.
                If InStr(1, textLine, "Quota", 1) > 0 Then
                    intQuota = 1
                End If
                If Mid(textLine, 3, 3) = "To:" And x = 0 Then
                    strEmail = Trim(Mid(textLine, 4))
                    x = 1
                End If
            Loop
            Close #1            'Close the input file
           
            If strEmail <> "" Then
                If InStr(1, strEmail, "@", 1) > 0 And InStr(1, strEmail, " ", 1) = 0 Then
                    Set rsEmail = New ADODB.Recordset
                    rsEmail.Open "Select * from tContacts where Email = '" & strEmail & "';", Connect, adOpenKeyset, adLockOptimistic, adCmdText
                    If Not rsEmail.EOF Then
                      If rsEmail("intTimesEmailMarked") > 0 And rsEmail("dtEMailMarked") <> theDate Then
                        If intQuota <> 0 Then
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times Because of Quota " & rsEmail("email") & "', strEmailMarkedType = 'Undeliverable Mail Returned to Sender', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                       
                        Else
                            Connect.Execute "update tContacts set Email = ' ', Notes = '" & rsEmail("Notes") & " Email returned 2 times " & rsEmail("email") & "', strEmailMarkedType = 'Undeliverable Mail Returned to Sender', dtEmailMarked = date(), intTimesEmailMarked = 0, blnEmailOK = False where id = " & rsEmail("id") & ";"
                        End If
                      Else
                        Connect.Execute "update tContacts set strEmailMarkedType = 'Undeliverable Mail Returned to Sender', dtEmailMarked = date(), intTimesEmailMarked = 1 where id = " & rsEmail("id") & ";"
                      End If
                     
                      olMail.Delete
                      ProcessMail = True
                      Exit Function
                    Else
                      olMail.Delete
                      ProcessMail = True
                      Exit Function
                    End If
                    'strEmailMarkedType
                    'intTimesEmailMarked
                    'dtEmailMarked
                    Set rsEmail = Nothing
                Else
                    olMail.Subject = "This Needs To Be Processed"
                    Set rsEmail = Nothing
                End If
            Else
                olMail.Subject = "This Needs To Be Processed"
            End If
        Else
            olMail.Subject = "This Needs To Be Processed"
            olMail.UnRead = False
        End If  'Subject
'NextMessage:
           
                   ' olMail.UnRead = False 'Mark mail as read, if that's necessary !?
            ''        Rst.AddNew
            ''        Rst!name = OlMail.SenderName
            ''        Rst!Subject = OlMail.Subject
            ''        Rst!datesent = OlMail.ReceivedTime
            ''        Rst.Update
                   
            End If  'UnRead


Next

ProcessMail = False

End Function


Private Sub Command1_Click()
Do Until ProcessMail = False
    ProcessMail
Loop
End Sub




0
 
LVL 28

Expert Comment

by:vinnyd79
ID: 10792292
Oops, take out the "End Function" at the top,that should not be there.
0
 
LVL 28

Expert Comment

by:vinnyd79
ID: 10792336
Looking again I don't think it will work unless you put these lines after every oMail.Delete:

ProcessMail = True
Exit Function
0
 

Author Comment

by:Hook333
ID: 10792348
vinnyd79 I just tried that and it still produced the same result.
0
 
LVL 28

Accepted Solution

by:
vinnyd79 earned 250 total points
ID: 10792358
Did you add the 2 lines above after all Deletes?
0
 

Author Comment

by:Hook333
ID: 10792385
Ok that worked!
0
 
LVL 27

Expert Comment

by:jjafferr
ID: 10792470
Sorry man, I wasn't fast enough :o(
It would be faster if you have 1 Recordset, and you keep calling it, instead of making whole bunch of them.
I am glad you found your soulution.

jaffer
0
 

Author Comment

by:Hook333
ID: 10792485
thanks for trying jaffer!
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Introduction While answering a recent question about filtering a custom class collection, I realized that this could be accomplished with very little code by using the ScriptControl (SC) library.  This article will introduce you to the SC library a…
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

688 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question