Option Explicit


Sub CopyToExcel(olItem As MailItem)
    
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim gaFolder As Folder
    Dim teFolder As Folder
    Dim vText As Variant
    Dim sText As String
    Dim sAddr As String
    Dim vAddr As Variant
    Dim vItem As Variant
    Dim i As Long, j As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim ga As String, te As String, sg As String, ot As String, re As String
    Dim ga2 As String, te2 As String, sg2 As String, ot2 As String, re2 As String
    Const strWorkSheetName As String = "Sheet2"
    Const strWorkBookName As String = "C:\Users\ko98240\Desktop\Book1.xlsm" 'the path of the workbook
    
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
    Set teFolder = olFolder.Folders("Tank & Enclosure")
    Set gaFolder = olFolder.Folders("Generator and ATS")
    
'Open the workbook to input the data
    Set xlWB = Excel.Workbooks.Open("C:\Users\ko98240\Desktop\Book1.xlsm")
    Set xlSheet = xlWB.Sheets("Sheet2")
    
'Process the message
    With olItem
        sText = olItem.Body
        vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
        rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1
        
'Check each line of text in the message body
        For i = UBound(vText) To 0 Step -1
            If InStr(1, vText(i), "Job Name:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If
            
            If InStr(1, vText(i), "Contact Name:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If
            
            If InStr(1, vText(i), "Company:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & rCount) = Trim(vItem(1))
            End If
            
            If InStr(1, vText(i), "Generator and ATS:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                ga = "Generator and ATS:  " & Trim(vItem(1))
                ga2 = Trim(vItem(1))
            End If
            
            If InStr(1, vText(i), "Tank & Enclosure:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                te = "Tank & Enclosure:  " & Trim(vItem(1))
                te2 = Trim(vItem(1))
            End If
            
            If InStr(1, vText(i), "Switchgear:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                sg = "Switchgear:  " & Trim(vItem(1))
                sg2 = Trim(vItem(1))
            End If
            
            If InStr(1, vText(i), "Other:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                ot = "Other:  " & Trim(vItem(1))
                ot2 = Trim(vItem(1))
            End If
            
            If InStr(1, vText(i), "Revisions:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                re = "Revisions:  " & Trim(vItem(1))
                re2 = Trim(vItem(1))
            End If
            
            Next i
            
'Move the incoming email to appropriate sub inbox
            If ((Len(ga2) > 0) And (Len(te2) = 0)) Then
                olItem.Move gaFolder
                
            ElseIf ((Len(sg2) > 0) And (Len(te2) = 0)) Then
                olItem.Move gaFolder
                
            ElseIf ((Len(ot2) > 0) And (Len(te2) = 0)) Then
                olItem.Move gaFolder
                
            ElseIf ((Len(re2) > 0) And (Len(te2) = 0)) Then
                olItem.Move gaFolder
                
            Else
                olItem.Move teFolder
            End If
            
'Copy notes to one note field
            xlSheet.Range("D" & rCount) = ga & "  " & te & "  " & sg & "  " & ot & "  " & re
            
'Separate date and time from time stamp
            xlSheet.Range("E" & rCount) = Format(olItem.ReceivedTime, "mm/dd/yyyy")
            xlSheet.Range("F" & rCount) = Format(olItem.ReceivedTime, "hh:mm:ss AM/PM")
            
            xlWB.Save
        End With
        xlWB.Close SaveChanges:=True
        If bXStarted Then
            xlApp.Quit
        End If
        Set xlApp = Nothing
        Set xlWB = Nothing
        Set xlSheet = Nothing
    End Sub