This is very similar to code I have posted previously. Use a rule to identify the messages as they arrive, run the script 'ExtractLoggingData', and move the message to your folder of choice. The macro will create the path and workbook if not present. I have included a test macro so that you can test the code with a selected message.
Option Explicit
Private strDate As String
Private strTime As String
Private strEmail As String
Private strSubject As String
Private strValues As String
Private vValues As Variant
Private ConnectionString As String
Private strSQL As String
Private CN As Object
Private xlApp As Object
Private xlWB As Object
Private bxlStarted As Boolean
Private i As Long
Private Const strTitles As String = "Date|Time|E-Mail|Subject"
Private Const strWorkbook As String = "Logging.xlsx"
Private Const strPath As String = "C:\Data\Logging\"
Sub Test()
Dim olMsg As MailItem
On Error Resume Next
Select Case Outlook.Application.ActiveWindow.Class
Case olInspector
Set olMsg = ActiveInspector.currentItem
Case olExplorer
Set olMsg = Application.ActiveExplorer.Selection.Item(1)
End Select
ExtractLoggingData olMsg
lbl_Exit:
Exit Sub
End Sub
Sub ExtractLoggingData(Item As MailItem)
'Graham Mayor - https://www.gmayor.com - Last updated - 11 May 2020
If TypeName(Item) = "MailItem" Then
strEmail = Item.SenderEmailAddress
strDate = Format(Item.ReceivedTime, "dd/MM/yyyy")
strTime = Format(Item.ReceivedTime, "h:mm am/pm")
strSubject = Item.Subject
strValues = strDate & "', '" & _
strTime & "', '" & _
strEmail & "', '" & _
strSubject
If Not FileExists(strPath & strWorkbook) = True Then xlCreateBook strWorkbook:=strPath & strWorkbook, strTitles:=strTitles
WriteToWorksheet strWorkbook:=strPath & strWorkbook, strRange:="Sheet1", strValues:=strValues
End If
lbl_Exit:
Exit Sub
End Sub
Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function
Private Sub xlCreateBook(strWorkbook As String, strTitles As String)
CreateFolders strPath
vValues = Split(strTitles, "|")
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bxlStarted = True
End If
On Error GoTo 0
Set xlWB = xlApp.Workbooks.Add
With xlWB.Sheets(1)
For i = 0 To UBound(vValues)
.cells(1, i + 1) = vValues(i)
Next i
End With
xlWB.SaveAs strWorkbook
xlWB.Close 1
If bxlStarted Then
xlApp.Quit
Set xlApp = Nothing
Set xlWB = Nothing
End If
lbl_Exit:
Exit Sub
End Sub
Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim VPath As Variant
VPath = Split(strPath, "\")
strPath = VPath(0) & "\"
For lngPath = 1 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function
Private Function FolderExists(fldr) As Boolean
'An Outlook macro by Graham Mayor
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(fldr)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function
Private Function FileExists(filespec) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function