Solved

For Each olMail In OlItems, Outlook and Visual Basic

Posted on 2004-04-08
18
1,452 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
  • 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
 

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
Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

 

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

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
Most everyone who has done any programming in VB6 knows that you can do something in code like Debug.Print MyVar and that when the program runs from the IDE, the value of MyVar will be displayed in the Immediate Window. Less well known is Debug.Asse…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This is Part 3 in a 3-part series on Experts Exchange to discuss error handling in VBA code written for Excel. Part 1 of this series discussed basic error handling code using VBA. http://www.experts-exchange.com/videos/1478/Excel-Error-Handlin…

760 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

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now