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.SenderNameをReceivedTimeに変更することができます（Item.ReceivedTime、 "yyyy-mmm-dd"）

これを行うと、SenderNameの代わりに各ファイル名の前にReceivedTimeが設定されます

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