Help deleting messages with certain Attachments

  • Thread starter Thread starter Wayne Delph
  • Start date Start date
W

Wayne Delph

I'm a newbe to VBA/Outlook but am an experienced Delphi programmer so
bear with me.

I want to write a script to delete or move to the Junk E-mail folder all
incoming messages with attachments that have certain file extensions
(scr, pif..). I know that Outlook 2003 blocks some of these but I want
to delete the message altogether whether or not they are blocked.

I found this code and I copy/pasted it into ThisOutLookSession but I
can't get the olInboxItems_ItemAdd to fire at all. The
Application_Startup is being fired however. Obviously I'm doing
something wrong, Please help.
****

Private Sub Application_Startup()
Dim objNS As NameSpace
Set objNS = Application.GetNamespace("MAPI")
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
Set objNS = Nothing
End Sub

Private Sub Application_Quit()
Set olInboxItems = Nothing
End Sub

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
Dim objAttFld As MAPIFolder
Dim objInbox As MAPIFolder
Dim objNS As NameSpace
Dim strAttFldName As String
Dim strProgExt As String
Dim arrExt() As String
Dim objAtt As Attachment
Dim intPos As Integer
Dim I As Integer
Dim strExt As String
MsgBox ("ItemAdd")
' #### USER OPTIONS ####
' name of Inbox subfolder containing messages with attachments
strAttFldName = "Attachments"
' delimited list of extensions to trap
strProgExt = "exe, bat, com, vbs, vbe, pif, scr"

On Error Resume Next
Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objAttFld = objInbox.Folders(strAttFldName)
If Item.Class = olMail Then
If objAttFld Is Nothing Then
Set objAttFld = objInbox.Folders.Add(strAttFldName)
End If
If Not objAttFld Is Nothing Then
arrExt = Split(strProgExt, ",")
For Each objAtt In Item.Attachments
intPos = InStrRev(objAtt.FileName, ".")
If intPos > 0 Then
strExt = Mid(objAtt.FileName, intPos + 1)
For I = LBound(arrExt) To UBound(arrExt)
If strExt = Trim(arrExt(I)) Then
Item.Move objAttFld
Exit For
End If
Next
Else
' no extension; unknown type
Item.Move objAttFld
End If
Next
End If
End If

On Error GoTo 0
Set objAttFld = Nothing
Set objInbox = Nothing
Set objNS = Nothing
Set objAtt = Nothing
End Sub
 
I don't see any statement in the Declaration section (i.e. before all
procedures) declaring olInboxItems WithEvents:

Dim WithEvents olInboxItems as Outlook.Items
 
Back
Top