[转]VBA Check if an outlook folder exists; if not create it

本文转自：http://www.outlookcode.com/d/code/quarexe.htm

To quarantine application file attachments

This Outlook VBA code sample monitors the Inbox folder for new items, looks for messages with attached files with the extensions listed in the USER OPTIONS section,

and moves such messages to an Inbox\Quarantine folder for later review, creating the folder if it doesn't exist. 

Place this code in the ThisOutlookSession module so that it runs when Outlook starts.

Code Sample

Private WithEvents olInboxItems As Items

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 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

  ' #### USER OPTIONS ####
  ' name of Inbox subfolder containing messages with attachments
  strAttFldName = "Quarantine"
  ' delimited list of extensions to trap
  strProgExt = "exe, bat, com, vbs, vbe"

  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
      ' create folder if needed
      Set objAttFld = objInbox.Folders.Add(strAttFldName)
    End If
    If Not objAttFld Is Nothing Then
      ' convert delimited list of extensions to array
      arrExt = Split(strProgExt, ",")
      For Each objAtt In Item.Attachments
        intPos = InStrRev(objAtt.FileName, ".")
        If intPos > 0 Then
          ' check attachment extension against array
          strExt = LCase(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

 

 

Notes

This code is no substitute for a good virus scanner. 

In most versions of Outlook, application file types such as .exe are already blocked by the Outlook Email Security Update, so this code won't have any effect.

You could adapt this technique to detect files of any particular type and perform specific processing on them. Don't forget that you must save an attachment first (Attachment.SaveAsFile) before you can access it with the methods appropriate for that file's application.

More Information

• Viruses Affecting Microsoft Outlook
• To convert incoming HTML messages to Outlook Rich Text format -- another code sample for the Inbox