Outlook VBA ----- ALEX--- help

Have any of you all written any code that reads an email when it arrives in the inbox??

I'm trying to develop a tool that will delete emails if certain words are in the body of the email....


I know a wizard can do it but it's not getting all the words.

I found this in another thread.... Seems to be working.

How could I replace the oEmail.Body, "xxxx" with a link to a db that has a large list of phrases that the macro could run through?

Code:

---

Private Sub Application_NewMail()

    Dim oNS As Outlook.NameSpace
    Dim oInbox As Outlook.MAPIFolder
    Dim oEmail As Outlook.MailItem
    Dim i As Integer
   
    Set oNS = Application.GetNamespace("MAPI")
    Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
   
    If oInbox.UnReadItemCount > 0 Then MsgBox "New Email!", vbOKOnly + vbInformation
    Do While i < oInbox.Items.Count And oInbox.UnReadItemCount > 0
        i = i + 1
        DoEvents
        If oInbox.UnReadItemCount > 0 Then
            Set oEmail = oInbox.Items.Item(i)
            If InStr(1, oEmail.Body, "enlarge your *****") > 0 Then
                oEmail.Delete
            Else
                If oEmail.UnRead = True Then oEmail.UnRead = False
            End If
            Set oEmail = Nothing
        End If
        Set oInbox = Nothing
        Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
    Loop

    Set oInbox = Nothing
    Set oNS = Nothing

End Sub

---

I think this should be it - think I should let you know this is untested though & if there are any errors thrown up by it, let me know!

VB Code:

Private Sub Application_NewMail()
    Dim oNS As Outlook.NameSpace
    Dim oInbox As Outlook.MAPIFolder
    Dim oEmail As Outlook.MailItem
    Dim i As Integer
    
    ' Set reference to microsoft activex data objects 2.6 library
    ' from tools > references menu in Outlook.
    
    ' Declare ADO objects to talk to the database here
    Dim cnnFilterDb As ADODB.Connection
    Dim rsFilterWords As ADODB.Recordset
    
    Set oNS = Application.GetNamespace("MAPI")
    Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
    
    If oInbox.UnReadItemCount > 0 Then MsgBox "New Email!", vbOKOnly + vbInformation
    Do While i < oInbox.Items.Count And oInbox.UnReadItemCount > 0
        i = i + 1
        DoEvents
        If oInbox.UnReadItemCount > 0 Then
            Set oEmail = oInbox.Items.Item(i)
            
            ' setup a connection to the database here. If you've not done this before,
            ' I suggest you try looking up the ADO tutorial by Karl Moore on the Net.
            ' If you need to build your own connection string for accessing SQL server etc.,
            ' search the forums for any posts by me with 'udl' in.
            Set cnnFilterDb = New ADODB.Connection
            
            cnnFilterDb.ConnectionString = "Provider = Microsoft.Jet.OLEDB.4.0; " & _
            "DATA Source=C:\Path\MyAccessFileName.mdb;"
            cnnFilterDb.Open
            
            ' setup a recordset object - for this purpose basically a reference or copy of
            'your database table here, only looking at 1 single column.
            Set rsFilterWords = New ADODB.Recordset
            rsFilterWords.Open "SELECT fieldColumnFilterWordList FROM tableName" & _
            cnnFilterDb, adOpenStatic, adLockReadOnly, adCmdText
            
            If oEmail.UnRead = True Then oEmail.UnRead = False
            
            ' Loop through all the records/rows in the recordset, if the word from the
            ' currently looked at recordset row is found in the body of the e-mail, then
            ' delete the mail and exit the loop (preventing all the other records from being
            ' evaluated / looked at).
            Do Until rsFilterWords.EOF
                If InStr(1, oEmail.Body, rsFilterWords!fieldColumnFilterWordList) > 0 Then
                    oEmail.Delete
                    Exit Do
                End If
            
                ' move to the next record in the recordset which will be 'read' on the
                ' next time the loop goes round...
                rsFilterWords.MoveNext
            Loop
            
            ' clean up unused ADO objects
            Set rsFilterWords = Nothing
            Set cnnFilterDb = Nothing
            
            Set oEmail = Nothing
        End If
        Set oInbox = Nothing
        Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
    Loop
 
    Set oInbox = Nothing
    Set oNS = Nothing
End Sub

alex_read

the code is working

but

i have one last question.


would it be possible with the code you provided not to make the emails as "Read" currently the code is marking the emails as "Read" after it goes through them....

hmmm, okay try this one...

VB Code:

' At the top of the code
Dim blnMailWasDeleted As Boolean
            
' Place this right before the loop
blnMailWasDeleted = False
            
Do Until rsFilterWords.EOF
    If InStr(1, oEmail.Body, rsFilterWords!fieldColumnFilterWordList) > 0 Then
        blnMailWasDeleted = True
        oEmail.Delete
        
        Exit Do
    End If
    
    rsFilterWords.MoveNext
Loop
            
' If the mail didn't contain any of the words, then it wouldn't
' have been deleted & our boolean variable will be true
If blnMailWasDeleted = False Then
    oEmail.UnRead = True
End If

is this how the code should look?

Code:

---

Private Sub Application_NewMail()
    Dim oNS As Outlook.NameSpace
    Dim oInbox As Outlook.MAPIFolder
    Dim oEmail As Outlook.MailItem
    Dim blnMailWasDeleted As Boolean
    Dim i As Integer
   
    ' Set reference to microsoft activex data objects 2.6 library
    ' from tools > references menu in Outlook.
   
    ' Declare ADO objects to talk to the database here
    Dim cnnFilterDb As ADODB.Connection
    Dim rsFilterWords As ADODB.Recordset
   
    Set oNS = Application.GetNamespace("MAPI")
    Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
   
    If oInbox.UnReadItemCount > 0 Then MsgBox "New Email!", vbOKOnly + vbInformation
    Do While i < oInbox.Items.Count And oInbox.UnReadItemCount > 0
        i = i + 1
        DoEvents
        If oInbox.UnReadItemCount > 0 Then
            Set oEmail = oInbox.Items.Item(i)
           
            ' setup a connection to the database here. If you've not done this before,
            ' I suggest you try looking up the ADO tutorial by Karl Moore on the Net.
            ' If you need to build your own connection string for accessing SQL server etc.,
            ' search the forums for any posts by me with 'udl' in.
            Set cnnFilterDb = New ADODB.Connection
           
            cnnFilterDb.ConnectionString = "Provider = Microsoft.Jet.OLEDB.4.0; " & _
            "DATA Source=C:\Path\MyAccessFileName.mdb;"
            cnnFilterDb.Open
           
            ' setup a recordset object - for this purpose basically a reference or copy of
            'your database table here, only looking at 1 single column.
            Set rsFilterWords = New ADODB.Recordset
            rsFilterWords.Open "SELECT fieldColumnFilterWordList FROM tableName" & _
            cnnFilterDb, adOpenStatic, adLockReadOnly, adCmdText
           
            If oEmail.UnRead = True Then oEmail.UnRead = False
           
            ' Loop through all the records/rows in the recordset, if the word from the
            ' currently looked at recordset row is found in the body of the e-mail, then
            ' delete the mail and exit the loop (preventing all the other records from being
            ' evaluated / looked at).
            Do Until rsFilterWords.EOF
                If InStr(1, oEmail.Body, rsFilterWords!fieldColumnFilterWordList) > 0 Then
                    oEmail.Delete
                    Exit Do
                End If
           
                ' move to the next record in the recordset which will be 'read' on the
                ' next time the loop goes round...
                rsFilterWords.MoveNext
       
                    blnMailWasDeleted = False
                       
            Do Until rsFilterWords.EOF
                If InStr(1, oEmail.Body, rsFilterWords!fieldColumnFilterWordList) > 0 Then
                    blnMailWasDeleted = True
                    oEmail.Delete
                   
                    Exit Do
                End If
               
                rsFilterWords.MoveNext
            Loop
                       
            ' If the mail didn't contain any of the words, then it wouldn't
            ' have been deleted & our boolean variable will be true
            If blnMailWasDeleted = False Then
                oEmail.UnRead = True
            End If
                   
       
            Loop
           
            ' clean up unused ADO objects
            Set rsFilterWords = Nothing
            Set cnnFilterDb = Nothing
           
            Set oEmail = Nothing
        End If
        Set oInbox = Nothing
        Set oInbox = oNS.GetDefaultFolder(olFolderInbox)
    Loop

    Set oInbox = Nothing
    Set oNS = Nothing
End Sub

---