Outlook-VBA to extract data Outlook mails to open Excel file

[Hermac]

Hi,
With a for/next loop I want to run through a selection of Outlook-mails and extract the same 5 items from each one, to be dropped horizontally in an open Excelfile "MailStats.xlsm", Worksheet("Stats1")

Something like in the code below but with a destination to some horizontal range in Woksheets("Stats1") instead of msgbox.
I know how to pick the next open row with End(xlUp).Offset(1, 0). And I know how to make the VBA references between Outlook en Excel with the 16.0 Object Libraries
What I'm not familiar with is the most appropriate and efficient instruction code within Outlook-VBA to pick stuff up in Outlook and drop in an Excel Cell.
I mean especially the traffic between both applications.

Public Sub SaveMailsInFiles()
Dim oMail As Outlook.MailItem, objItem As Object
Dim sPath As String, dtDate As Date, sSubj As String
Dim sSendr As String, sRecip As String, enviro As String, strFolderpath As String, sNam As String
enviro = CStr(Environ("USERPROFILE"))
strFolderpath = BrowseForFolder(enviro & "\documents\MAILTRANSIT")
For Each objItem In ActiveExplorer.Selection
Set oMail = objItem
sNam = oMail.Subject
sSendr = oMail.SenderName: sRecip = oMail.To
ReplacementsInNam sNam, "-"
ReplacementsInSendr sSendr, "HVN": ReplacementsInRecip sRecip, "HVN"
dtDate = oMail.ReceivedTime
MsgBox strFolderpath
MsgBox oMail.Attachments.Count
MsgBox oMail.MessageClass
MsgBox oMail.SenderName
MsgBox sRecip[/I]
Next
??..
Thank you very much for any hint to get me on track.
Herman Van Noten

 

[John_w]

Add this code to reference the next row in the "Stats1" sheet of the open "MailStats.xlsm" workbook:

    Dim ExcelApp As Excel.Application
    Dim ExcelWb As Excel.Workbook
    Dim destCell As Excel.Range
    Dim r As Long
        
    'Attempt to attach to running Excel instance

    Set ExcelApp = Nothing
    On Error Resume Next
    Set ExcelApp = GetObject(, "Excel.Application")
    On Error GoTo 0

    If ExcelApp Is Nothing Then
        'Excel not running, so open new instance
        Set ExcelApp = New Excel.Application 'CreateObject("Excel.Application")
    End If
    
    Set ExcelWb = Nothing
    On Error Resume Next
    Set ExcelWb = ExcelApp.Workbooks("MailStats.xlsm")
    On Error GoTo 0
    
    If ExcelWb Is Nothing Then
        MsgBox "MailStats.xlsm isn't open", vbCritical
        Exit Sub
    End If
    
    With ExcelWb.Worksheets("Stats1")
        Set destCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
    End With

and this loop to put the email details in the sheet rows:

    r = 0
    For Each objItem In ActiveExplorer.Selection
        Set oMail = objItem
        With oMail
            destCell.Offset(r).Resize(, 6).Value = Array(.Subject, .SenderName, .To, .ReceivedTime, .Attachments.Count, .MessageClass)
        End With
        r = r + 1
    Next

 

[Hermac]

Wow, this is beautiful and does precisely what I wanted, John_W ! Thank you very much for making my day.
Herman