Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1490
  • Last Modified:

For Each olMail In OlItems, Outlook and Visual Basic

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
Hook333
Asked:
Hook333
  • 10
  • 6
  • 2
1 Solution
 
vinnyd79Commented:
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
 
Hook333Author Commented:
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
 
vinnyd79Commented:
Yes,but for everyone it deletes it will skip 1. Thats why it only process' half of them at a time.
0
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!

 
Hook333Author Commented:
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
 
Hook333Author Commented:
Oh I understand what you are saying is there a way to go back an item?
0
 
Hook333Author Commented:
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
 
Hook333Author Commented:
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
 
Hook333Author Commented:
This is what i tried


For Each olMail In OlItems
Call delete(olMail)
Next



Function delete(s)
s.delete
End Function
0
 
jjafferrCommented:
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
 
Hook333Author Commented:
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
 
vinnyd79Commented:
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
 
vinnyd79Commented:
Oops, take out the "End Function" at the top,that should not be there.
0
 
vinnyd79Commented:
Looking again I don't think it will work unless you put these lines after every oMail.Delete:

ProcessMail = True
Exit Function
0
 
Hook333Author Commented:
vinnyd79 I just tried that and it still produced the same result.
0
 
vinnyd79Commented:
Did you add the 2 lines above after all Deletes?
0
 
Hook333Author Commented:
Ok that worked!
0
 
jjafferrCommented:
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
 
Hook333Author Commented:
thanks for trying jaffer!
0

Featured Post

Hire Technology Freelancers with Gigs

Work with freelancers specializing in everything from database administration to programming, who have proven themselves as experts in their field. Hire the best, collaborate easily, pay securely, and get projects done right.

  • 10
  • 6
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now