Open .eml file using VBA, in Outlook, then extract time and rename it

Question

I tried this VBA code in Outlook but Shellexecute only works when I step into it using F8. It opens the file so Outlook can read it.

When I press F5 it gives an error on Set MyItem = Myinspect.CurrentItem.

Here sleep is no use since the email is not opened.

I am trying to rename the .eml file after extracting received time.

#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const SW_SHOWMINIMIZED As Long = 2
Sub AgregarFechaEnvioACarpetas()
    Dim rutaCarpeta As String
    Dim carpeta As Object
    Dim archivo As Object
    Dim nombreArchivo As String
    Dim fechaEnvio As Date
    
    rutaCarpeta = "C:\Users\MBA\Desktop\PDFs\MyEmails\"
    
    Set carpeta = CreateObject("Scripting.FileSystemObject").GetFolder(rutaCarpeta)
    
    For Each archivo In carpeta.Files
        If LCase(Right(archivo.name, 4)) = ".eml" Then
            
            If Dir(archivo.Path) = "" Then
                MsgBox "File " & archivo.Path & " does not exist"
            Else
                ShellExecute 0, "Open", archivo.Path, "", archivo.Path, SW_SHOWNORMAL
            End If
            
            Sleep 5000

            fechaEnvio = GetFechaEnvioEml(archivo.Path)
            
            'nombreArchivo = archivo.name & "_" & Format(fechaEnvio, "ddmmyyyy")
            'Correction made for the right name
            nombreArchivo = Left(archivo.name, Len(archivo.name) - 4) & "_" & Format(fechaEnvio, "ddmmyyyy") & ".eml"
            
            archivo.name = nombreArchivo
        
        End If
    Next archivo
    
    MsgBox "Proceso completado."
End Sub

Function GetFechaEnvioEml(rutaArchivo As String) As Date

    Dim objOL As Object
    Dim objMail As Object
    
    Set objOL = CreateObject("Outlook.Application")
        
    Set Myinspect = objOL.ActiveInspector
    Set MyItem = Myinspect.CurrentItem
    
    GetFechaEnvioEml = MyItem.ReceivedTime
    
    MyItem.Close olDiscard
    Set MyItem = Nothing
    Set objOL = Nothing

End Function

This code works in Excel.

Answer 1

Opening a file and displaying it is an asynchronous process, so no surprise Application.ActiveInspector is not yet available.

You can either

1. Open and read the EML file as a regular text file and find the line that starts with "Received:" or "Date: " and parse the rest of it.

2. Find a MIME parser (I don't know of any VBA-specific libraries) and parse the file.

3. Use Redemption (I am its author) - you can create a temporary MSG file, import EML file into it, then retrieve the RDOMail.ReceivedTime property:

set Session = CreateObject("Redemption.RDOSession")
set Msg = Session.CreateMessageFromMsgFile("C:\Temp\test.msg")
Msg.Import "c:\temp\test.EML", 1031
MsgBox Msg.ReceivedTime