将电子邮件附件保存到相应的硬盘文件夹

Question

我有一个宏，它可以扫描子文件夹以查找带有 pdf 附件的电子邮件，并将它们保存到我共享硬盘驱动器上的特定文件夹中。

我希望根据 pdf 附件的文件名更改结束文件夹。

例如
我收到一封电子邮件附件，其中包含号码 033000.001.1。
我的共享硬盘驱动器中有一个对应的文件夹，位于该编号下。
当我收到带有该编号附件的电子邮件时，该 pdf 文件会转到我共享驱动器中的该文件夹。
另一个编号的附件会转到另一个相应的文件夹。

让代码使用保存的数字创建新文件夹是一个优点。

Sub SaveAttachmentsToFolder()
    ' This Outlook macro checks a named subfolder in the Outlook Inbox
    ' (here the "Sales Reports" folder) for messages with attached
    ' files of a specific type (here file with an "xls" extension)
    ' and saves them to disk. Saved files are timestamped. The user
    ' can choose to view the saved files in Windows Explorer.
    ' NOTE: make sure the specified subfolder and save folder exist
    ' before running the macro.
    On Error GoTo SaveAttachmentsToFolder_err
    ' Declare variables
    Dim ns As NameSpace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim i As Integer
    Dim varResponse As VbMsgBoxResult
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("Palo Park")
    i = 0
    ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in the Subm from Arch folder.", vbInformation, _
          "Nothing Found"
        Exit Sub
    End If
    ' Check each message for attachments
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            ' Check filename of each attachment and save if it has "pdf" extension
            If Right(Atmt.FileName, 3) = "pdf" Then
                ' This path must exist! Change folder name as necessary.
                FileName = "S:\1- Job Files - Active\# 3034 - BHP Palo Park\07 - Submittals\Submittals from Architect\" & _
                  Atmt.FileName
                Atmt.SaveAsFile FileName
                i = i + 1
            End If
        Next Atmt
    Next Item
    ' Show summary message
    If i > 0 Then
        varResponse = MsgBox("I found " & i & " attached files." _
          & vbCrLf & "I have saved them into the S:\1- Job Files - Active\# 3034 - BHP Palo Park\07 - Submittals\Submittals from Architect folder." _
          & vbCrLf & vbCrLf & "Would you like to view the files now?" _
          , vbQuestion + vbYesNo, "Finished!")
        ' Open Windows Explorer to display saved files if user chooses
        If varResponse = vbYes Then
            Shell "Explorer.exe /e,S:\1- Job Files - Active\# 3034 - BHP Palo Park\07 - Submittals\Submittals from Architect\", vbNormalFocus
        End If
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If

' Clear memory
SaveAttachmentsToFolder_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
    ' Handle Errors
    SaveAttachmentsToFolder_err:
    MsgBox "An unexpected error has occurred." _
    & vbCrLf & "Please note and report the following information." _
    & vbCrLf & "Macro Name: GetAttachments" _
    & vbCrLf & "Error Number: " & Err.Number _
    & vbCrLf & "Error Description: " & Err.Description _
    , vbCritical, "Error!"
    Resume SaveAttachmentsToFolder_exit
End Sub

Answer 1

尝试按照以下示例进行操作。 . .

设置对 Outlook 的引用并将代码复制/粘贴到标准模块中

1) Go to the VBA editor, Alt -F11
2) Tools>References in the Menu bar
3) Place a Checkmark before Microsoft Outlook ? Object Library
    ? is the Outlook version number
4) Insert>Module
5) Paste the code (two macros) in this module
6) Alt q to close the editor
7) Save the file

Sub Test()
'Arg 1 = Folder name of folder inside your Inbox
'Arg 2 = File extension, "" is every file
'Arg 3 = Save folder, "C:\Users\Ron\test" or ""
'        If you use "" it will create a date/time stamped folder for you in your "Documents" folder
'        Note: If you use this "C:\Users\Ron\test" the folder must exist.

    SaveEmailAttachmentsToFolder "MyFolder", "xls", ""

End Sub

注意：您不必更改以下宏中的代码。但是您可以在保存行中将 Item.SenderName 更改为 ReceivedTime，例如 Format(Item.ReceivedTime, "yyyy-mmm-dd")

当你这样做时，它会将 ReceivedTime 放在每个文件名而不是 SenderName 之前

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                                 ExtString As String, DestFolder As String)
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim SubFolder As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim MyDocPath As String
    Dim I As Integer
    Dim wsh As Object
    Dim fs As Object

    On Error GoTo ThisMacro_err

    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)

    I = 0
    ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If

    'Create DestFolder if DestFolder = ""
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.FolderExists(DestFolder) Then
            fs.CreateFolder DestFolder
        End If
    End If

    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If

    ' Check each message for attachments and extensions
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1
            End If
        Next Atmt
    Next Item

    ' Show this message when Finished
    If I > 0 Then
        MsgBox "You can find the files here : " _
             & DestFolder, vbInformation, "Finished!"
    Else
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If

    ' Clear memory
ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set fs = Nothing
    Set wsh = Nothing
    Exit Sub

    ' Error information
ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit

End Sub

https://www.rondebruin.nl/win/s1/outlook/saveatt.htm