Help on a Old thread that I cant find a resolution to.

[mmartinez4]

I am on office 2019 and I have been trying to automate my emails to an excel sheet as part of a Ticket System, I know absolutely zero VBA and have just been trying to cobble something together off of some old posts. All the different vba code I have tried keeps creating a copy of my workbook every time I get an email to put the info in and that wont work for me. This post is the closest I have gotten as it doesn't recreate a workbook. The only problem is it refresh's my excel book like it is updating it with something when I get a email, but it doesn't actually put anything in the sheet. Any help would be much appreciated thank you.

Here is the link to the old post Outlook VBA How to Auto Export Information of Incoming Emails to an Excel File with Outlook VBA

In order the first set of code is in ThisOutlookSession then Standard Module then Class Module

Private Sub Application_Startup()
    Set myClass = New olEvents
    Set myClass.GMailItems = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Folders("Automation").Items
End Sub

Option Explicit

Public myClass As olEvents

Public Function IsWorkbookOpen(ByVal argFileName As String) As Boolean
    Dim fileID As Long, errNum As Long
    fileID = FreeFile()
    On Error Resume Next
    Open argFileName For Input Lock Read As #fileID
    errNum = Err.Number
    Close fileID
    IsWorkbookOpen = CBool(errNum)
End Function

Option Explicit

Public WithEvents GMailItems    As Outlook.Items

Private Sub GMailItems_ItemAdd(ByVal Item As Object)
    Dim xMailItem As Outlook.MailItem
    Dim xExcelFile As String
    Dim xExcelApp As Excel.Application
    Dim xWb As Excel.Workbook
    Dim xWs As Excel.Worksheet
    Dim xNextEmptyRow As Integer
    On Error Resume Next
    If Item.Class <> olMail Then Exit Sub
    Set xMailItem = Item
    
    xExcelFile = "C:\Users\mmartinez.MW\Desktop\Test1 - Copy.xlsm"
    If IsWorkbookOpen(xExcelFile) = True Then
        Set xExcelApp = GetObject(, "Excel.Application")
        Set xWb = GetObject(xExcelFile)
        If Not xWb Is Nothing Then xWb.Close True
    Else
        Set xExcelApp = New Excel.Application
    End If
    Set xWb = xExcelApp.Workbooks.Open(xExcelFile)
    Set xWs = xWb.Test
    xNextEmptyRow = xWs.Range("B" & xWs.Rows.Count).End(xlUp).Row + 1
    With xWs
        .Cells(xNextEmptyRow, 1) = xNextEmptyRow - 1
        .Cells(xNextEmptyRow, 2) = xMailItem.SenderName
        .Cells(xNextEmptyRow, 3) = xMailItem.SenderEmailAddress
        .Cells(xNextEmptyRow, 4) = xMailItem.Subject
        .Cells(xNextEmptyRow, 5) = xMailItem.ReceivedTime
    End With
    xWs.Columns("A:E").AutoFit
    xWb.Save
End Sub