附件2.0

Private WithEvents myFolderItems As Outlook.Items

Private Sub Application_Startup()

    Set myFolderItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("AAA").Items

End Sub

Private Sub myFolderItems_ItemAdd(ByVal item As Object)

    On Error GoTo ErrorHandler

    Dim saveFolder As String

    Dim objMail As Outlook.MailItem

    Dim objAttach As Outlook.Attachment

    Dim i As Integer

    

    ' 选择保存附件的文件夹路径

    saveFolder = "C:\"

        

    If TypeOf item Is Outlook.MailItem Then

        Set objMail = item

        

        ' 为此电子邮件创建文件夹并更改FolderPath以查找此文件夹。

        FName = objMail.Subject

        

        ' 删除非法字符

        For i = 1 To Len(FName)

            c = Mid(FName, i, 1)

            Select Case c

                Case Is = "/"

                    Mid(FName, i) = "."

                Case Is = "\", "|", "?", "<", ">", ":", "*", """"

                    Mid(FName, i) = ""

            End Select

        Next i

        

        If Len(Dir(saveFolder & "\" & FName, vbDirectory)) = 0 Then

            MkDir (saveFolder & "\" & FName)

        End If

        

        ' 循环遍历所有附件

        For Each objAttach In objMail.Attachments

            ' 将附件另存为指定的文件夹下

            objAttach.SaveAsFile saveFolder & "\" & FName & "\" & objAttach.FileName

        Next objAttach

    End If

ProgramExit:

    Exit Sub

    

ErrorHandler:

    MsgBox Err.Number & " - " & Err.Description

    Resume ProgramExit

End Sub