VBA Auteur et envoi Date des fichiers .msg sur le dossier du bureau

Question

J'essaie d'écrire une macro qui passe par des fichiers .msg 30k + dans un dossier de bureau et des sous-dossiers. L'objectif est d'obtenir la date et l'auteur de l'envoi si le nom de fichier contient "Visa Process--" ou "Document Signed--". En outre, cela ne doit être fait que pour le plus ancien des documents. Alors disons que nous sommes dans un sous-dossier et qu'il y a 3 fichiers qui se rapportent à "Processus de Visa--", alors seulement le plus ancien sera considéré.

Obtenir les dates d'envoi est ce que j'ai réussi jusqu'à présent, mais je ne sais pas comment implémenter l'auteur. J'ai activé Outlook Add-In, mais je suis nouveau à VBA et les exemples de codes sur Internet ne m'a pas aidé avec mes connaissances limitées.

Toute aide est grandement appréciée!

Malheureusement, je ne sais pas comment vous fournir un fichier d'exemple ici mais je l'enverrai volontiers par Email.

Voici mon (code de travail) pour les dates d'envoi des deux types Email:

'Optimize Macro Speed 
Application.ScreenUpdating = False 
Application.EnableEvents = False 
Application.Calculation = xlCalculationManual 

Dim wb As Workbook 
Dim ws As Worksheet 
Dim FSO As Object, fld As Object, Fil As Object 
Dim fsoFile As Object 
Dim fsoFol As Object 
Dim fsoSubFol As Object 
Dim folderPath As String, subfolderPath As String, folderName As String, FilePath As String 
Dim StepOne As String, StepTwo As String, FileName As String, CompareDate As String 
Dim NextRow As Long 
Dim FindExistingEntry As Range 

Set wb = ActiveWorkbook 
Set ws = wb.Worksheets("Feuil2") 


With ws 
    .UsedRange.Clear 
    .Cells(1, 1).Value = "Main Folder:" 
    .Cells(1, 2).Value = "File Name:" 
    .Cells(1, 3).Value = "MSG Date:" 
    .Cells(1, 4).Value = "File Name:" 
    .Cells(1, 5).Value = "Approved Date:" 
    .Range("A1:E1").Font.Bold = True 
End With 

Application.DisplayAlerts = False 
With Application.FileDialog(msoFileDialogFolderPicker) 
    .AllowMultiSelect = False 
    If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub 
    folderPath = .SelectedItems(1) 
End With 

If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\" 
Set FSO = CreateObject("Scripting.FileSystemObject") 
Set fld = FSO.GetFolder(folderPath) 
If FSO.FolderExists(fld) Then 
    For Each fsoFol In FSO.GetFolder(folderPath).SubFolders 

On Error Resume Next 
      subfolderPath = fsoFol & "\Mails" 

      For Each fsoSubFol In FSO.GetFolder(subfolderPath).Files 


       FilePath = fsoSubFol 
       FileName = Split(FilePath, "\")(4)  'Get only "Visa Process--2017-06-07 15h24m00s.MSG" of target file 4 
       folderName = Split(FilePath, "\")(2) 
       If Mid(FileName, InStrRev(FileName, ".") + 1) = "MSG" Then 

        'Example: Visa Process--2017-06-07 15h24m00s.MSG 
        If InStr(1, FileName, "Visa Process--", vbTextCompare) <> 0 And Left(FileName, 1) = "V" Then 

         NextRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row 

         'Example: Visa Process--2017-06-07 15h24m00s.MSG 
         StepOne = Split(FileName, "--")(1) 'No "Visa Process--" 
         StepTwo = Mid(StepOne, 1, 10)  'No Time-Stamp 

         'Make sure to only include the earliest date for each Main Folder "MPCV....." 
         Set FindExistingEntry = ws.Range("A2:A4000").Find(folderName) 

         'If there is already an entry... 
         If Not FindExistingEntry Is Nothing Then 
          CompareDate = ws.Cells(FindExistingEntry.Row, 3).Value 

          'Replace old date for that Main Folder if new date is earlier than previous 
          If DateValue(CompareDate) > DateValue(StepTwo) Then 

           ws.Cells(FindExistingEntry.Row, 2).Value = FileName 
           ws.Cells(FindExistingEntry.Row, 3).Value = DateValue(CompareDate) 

          'Do nothing if Main Folder date is later 
          ElseIf DateValue(CompareDate) < DateValue(StepTwo) Then 

          End If 
         'If there is no entry for the same Main Folder, simply add a new line 
         ElseIf FindExistingEntry Is Nothing Then 

          ws.Cells(NextRow + 1, 1).Value = folderName 
          ws.Cells(NextRow + 1, 2).Value = FileName 
          ws.Cells(NextRow + 1, 3).Value = DateValue(StepTwo) 

         End If 

        End If 

        'Do the same for the second document 
        If InStr(1, FileName, "Document signed--", vbTextCompare) <> 0 And Left(FileName, 1) = "D" Then 

         NextRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row 

         'Example: Document signed--2017-06-07 15h24m00s.MSG 
         StepOne = Split(FileName, "--")(1) 'No "Document signed--" 
         StepTwo = Mid(StepOne, 1, 10)  'No Time-Stamp 

         'Make sure to only include the earliest date for each Main Folder "MPCV....." 
         Set FindExistingEntry = ws.Range("A2:A4000").Find(folderName) 

         'If there is already an entry... 
         If Not FindExistingEntry Is Nothing Then 
          CompareDate = ws.Cells(FindExistingEntry.Row, 3).Value 

          'Replace old date for that Main Folder if new date is earlier than previous 
          If DateValue(CompareDate) > DateValue(StepTwo) Then 

           ws.Cells(FindExistingEntry.Row, 4).Value = FileName 
           ws.Cells(FindExistingEntry.Row, 5).Value = DateValue(CompareDate) 

          'Do nothing if Main Folder date is later 
          ElseIf DateValue(CompareDate) < DateValue(StepTwo) Then 

          End If 
         'If there is no entry for the same Main Folder, simply add a new line 
         ElseIf FindExistingEntry Is Nothing Then 

          'ws.Cells(NextRow + 1, 1).Value = folderName 
          'ws.Cells(NextRow, 4).Value = Filename 
          'ws.Cells(NextRow, 5).Value = DateValue(StepTwo) 

         End If 

        End If 
       End If 
      Next 
    Next 
End If 

'Message Box when tasks are completed 
MsgBox "Scan Complete!" 

'Reset Macro Optimization Settings 
Application.EnableEvents = True 
Application.Calculation = xlCalculationAutomatic 
Application.ScreenUpdating = True 
ActiveWorkbook.Saved = True 

Answer 1

Créer une instance de l'objet Outlook.Application (avant d'entrer dans la boucle), permet de récupérer l'objet Namespace de Application.GetNamespace("MAPI"), et l'utilisation Namespace.OpenSharedItem passer le fichier na du fichier MSG. L'objet MailItem récupéré contiendra des propriétés comme Subject, SenderName, SenderEmailAddress, SentOn, etc.