Add ID To Row And Update Reply Rows With Same ID?

[Legacy 286866]

Hi All,

Hope you are all well. I have made an email reporting tool and I am really struggling with this. Each row has an ID number (starting from 1 and on row 2 in Column G). When a reply comes in I need the reply to have its original ID. Tried using entryid but this value changes when a reply email comes back so its not very good.
Here is my code bellow;

Option Explicit

Const fPath As String = "C:\Users\neo_s_000\Desktop\Emails\" 'The path to save the messages
Const sfName As String = "C:\Users\neo_s_000\Desktop\Message Log.xlsx"


Sub Download_Outlook_Mail_To_Excel()
Dim olApp As Object
Dim olFolder As Object
Dim olNS As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim NextRow As Long
Dim i As Long
Dim olItem As Object
    If FileExists(sfName) Then
        Set xlBook = Workbooks.Open(sfName)
        Set xlSheet = xlBook.Sheets(1)
    Else
        Set xlBook = Workbooks.Add
        Set xlSheet = xlBook.Sheets(1)
        With xlSheet
            .Cells(1, 1) = "Sender"
            .Cells(1, 2) = "Subject"
            .Cells(1, 3) = "Date"
            '.Cells(1, 4) = "Size"
            .Cells(1, 5) = "EmailID"
            .Cells(1, 6) = "Body"
            .Cells(1, 7) = "ID"
        End With
        xlBook.SaveAs sfName
    End If
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    With xlSheet
        .Cells(1, 1) = "Sender"
        .Cells(1, 2) = "Subject"
        .Cells(1, 3) = "Date"
        '.Cells(1, 4) = "Size"
        .Cells(1, 5) = "EmailID"
        .Cells(1, 6) = "Body"
        .Cells(1, 7) = "ID"
        CreateFolders fPath
        Set olNS = olApp.GetNamespace("MAPI")
        olNS.Logon
        Set olFolder = olNS.PickFolder
        For Each olItem In olFolder.Items
            NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            If olItem.Class = 43 Then
                .Cells(NextRow, 1) = olItem.Sender
                .Cells(NextRow, 2) = olItem.Subject
                .Cells(NextRow, 3) = olItem.SentOn
                '.Cells(NextRow, 4) =
                .Cells(NextRow, 5) = SaveMessage(olItem)
                .Cells(NextRow, 6) = olItem.Body
            End If
        Next olItem
        MsgBox "Outlook Mails Extracted to Excel"
    End With
    xlBook.Close SaveChanges:=True
lbl_Exit:
    Set olApp = Nothing
    Set olFolder = Nothing
    Set olItem = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Exit Sub
End Sub


Function SaveMessage(olItem As Object) As String
Dim Fname As String
    Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
            Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.sendername & " - " & olItem.Subject
    Fname = Replace(Fname, Chr(58) & Chr(41), "")
    Fname = Replace(Fname, Chr(58) & Chr(40), "")
    Fname = Replace(Fname, Chr(34), "-")
    Fname = Replace(Fname, Chr(42), "-")
    Fname = Replace(Fname, Chr(47), "-")
    Fname = Replace(Fname, Chr(58), "-")
    Fname = Replace(Fname, Chr(60), "-")
    Fname = Replace(Fname, Chr(62), "-")
    Fname = Replace(Fname, Chr(63), "-")
    Fname = Replace(Fname, Chr(124), "-")
    SaveMessage = SaveUnique(olItem, fPath, Fname)
lbl_Exit:
    Exit Function
End Function


Private Function SaveUnique(oItem As Object, _
                            strPath As String, _
                            strFileName As String) As String
                            
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFileName)
    Do While FileExists(strPath & strFileName & ".msg") = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    oItem.SaveAs strPath & strFileName & ".msg"
    SaveUnique = strPath & strFileName & ".msg"
lbl_Exit:
    Exit Function
End Function


Private Sub CreateFolders(strPath As String)
Dim strTempPath As String
Dim iPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For iPath = 1 To UBound(vPath)
        strPath = strPath & vPath(iPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next iPath
End Sub


Private Function FolderExists(ByVal PathName As String) As Boolean
   Dim nAttr As Long
   On Error GoTo NoFolder
   nAttr = GetAttr(PathName)
   If (nAttr And vbDirectory) = vbDirectory Then
      FolderExists = True
   End If
NoFolder:
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

Any ideas?