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

時間 2019-12-06

標籤 vba check outlook folder exists create 欄目 Microsoft Office 简体版

原文原文鏈接

本文轉自：http://www.outlookcode.com/d/code/quarexe.htmhtml

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

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

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

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

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

More Information

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

相關標籤/搜索

每日一句

每一个你不满意的现在，都有一个你没有努力的曾经。