宏将Outlook文件夹中的电子邮件附件保存到多个不同的硬盘驱动器文件夹

Question

我是一名初学者VBA程序员，但我设法让宏运行顺利。它扫描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.ReceivedTime，“yyyy-mmm-dd”）等保存行中将Item.SenderName更改为ReceivedTime。

当您这样做时，它会在每个文件名之前放置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