VBA：ローカルフォルダ内の最後の（最新の）電子メール添付ファイルのみを保存します。

Question

特定の件名（最新のもの）を持つ最後の電子メールの添付ファイルをローカルフォルダに保存する必要があります。私のOutlookにフォルダを作成し、この特定の件名の電子メールをすべてこのフォルダに送信するルールを作成しました。最新のものだけを保存するのではなく、電子メールフォルダ内のすべての添付ファイルを保存する点を除いて、必要なことをするコードを見つけました。これはコードです：どのように私はそれが私が必要なことを行うように変更することができますか？

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 "Dependencia Financiera", "xls", "W:\dependencia financiera\test dependencia\" 

End Sub 



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 
    'JUST BEED TGE FIRST EMAIL 
    'Debug.Print Item(1).SentOn 

    For Each Item In SubFolder.Items 
     For Each Atmt In Item.Attachments 
      If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then 
       FileName = DestFolder & 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 

Answer 1

あなたはItemAddを考えてみましょう。この

Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _ 
           ExtString As String, DestFolder As String) 

    Dim ns As Namespace 
    Dim Inbox As Folder 
    Dim SubFolder As Folder 

    Dim subFolderItems As Items 

    Dim Atmt As attachment 

    Dim FileName As String 

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

    Set subFolderItems = SubFolder.Items 

    If subFolderItems.count > 0 Then 

     subFolderItems.Sort "[ReceivedTime]", True 

     For Each Atmt In subFolderItems(1).Attachments 
      If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then 
       FileName = DestFolder & Atmt.FileName 
       Atmt.SaveAsFile FileName 
      End If 
     Next Atmt 

    End If 

    ' Clear memory 
ThisMacro_exit: 
    Set SubFolder = Nothing 
    Set Inbox = Nothing 
    Set ns = Nothing 
    Set subFolderItems = Nothing 

End Sub 

を試みることができます。最新のアイテムは既に知られています。 How do I trigger a macro to run after a new mail is received in Outlook?