How to convert FILETIME to Date in VBA?

I'm trying to write a module that will take a Hex FILETIME extracted from a registry key and parse that into a readable date in VBA.

I have the following REG_BINARY key extracted from the registry: 36 D0 56 2E 14 52 D5 01 00 60 EE 78 DE FF FF FF C4 00 8E 01 FF FF FF 7F

So far I have the following function to try an convert it:

Public Sub ConvertHex2Date()
    Dim lbyte, ubyte, convByteL, convByteU As Long
    Dim FT As FileTime
    Dim SysTimeDate As Date
    Dim bArrL() As Byte
    Dim bArrU() As Byte
    convByteL = 3577643008# 'Lower Byte Conversion Factor
    convByteU = 27111902    'Upper Byte COnversion Factor

    Dim str, strlByte, struByte As String

    str = "36 D0 56 2E 14 52 D5 01 00 60 EE 78 DE FF FF FF C4 00 8E 01 FF FF FF 7F "
    str = Left(Replace(Trim(str), " ", ""), 16)

    strlByte = Left(str, 8) 'Hex String Lower Byte
    struByte = Right(str, 8) 'Hex String Upper Byte

    bArrL = Hex2ByteArr(strlByte)
    bArrU = Hex2ByteArr(struByte)

    lbyte = ByteArr2Long(bArrL)
    ubyte = ByteArr2Long(bArrU)

    FT.dwLowDateTime = lbyte
    FT.dwHighDateTime = ubyte
    SysTimeDate = FileTimeToSerialTime(FT)
End Sub

Associated helper Subs:

Private Const FORMAT_MESSAGE_TEXT_LEN = &HA0 ' from ERRORS.H C++ include file.
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200

'''''''''''''''''''''''''''''''''''''''
' Windows API Functions
'''''''''''''''''''''''''''''''''''''''
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" ( _
    ByVal dwFlags As Long, _
    lpSource As Any, _
    ByVal dwMessageId As Long, _
    ByVal dwLanguageId As Long, _
    ByVal lpBuffer As String, _
    ByVal nSize As Long, _
    Arguments As Long) As Long


Public Type FileTime
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Public Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Private Declare Function FileTimeToSystemTime Lib "kernel32" ( _
    lpFileTime As FileTime, _
    lpSystemTime As SYSTEMTIME) As Long


Public Sub ConvertHex2Date()
    Dim lbyte, ubyte, convByteL, convByteU As Long
    Dim FT As FileTime
    Dim SysTimeDate As Date
    Dim bArrL() As Byte
    Dim bArrU() As Byte
    convByteL = 3577643008# 'Lower Byte Conversion Factor
    convByteU = 27111902    'Upper Byte COnversion Factor

    Dim str, strlByte, struByte As String

    str = "36 D0 56 2E 14 52 D5 01 00 60 EE 78 DE FF FF FF C4 00 8E 01 FF FF FF 7F "
    str = Left(Replace(Trim(str), " ", ""), 16)

    strlByte = Left(str, 8) 'Hex String Lower Byte
    struByte = Right(str, 8) 'Hex String Upper Byte

    bArrL = Hex2ByteArr(strlByte)
    bArrU = Hex2ByteArr(struByte)

    lbyte = ByteArr2Long(bArrL)
    ubyte = ByteArr2Long(bArrU)

    FT.dwLowDateTime = lbyte
    FT.dwHighDateTime = ubyte
    SysTimeDate = FileTimeToSerialTime(FT)
End Sub

Public Function FileTimeToSerialTime(FileTimeValue As FileTime) As Date
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' FileTimeToSerialTime
    ' This function converts a FILETIME to a Double Serial DateTime.
    ' TESTED
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim SysTime As SYSTEMTIME
    Dim Res As Long
    Dim ErrNum As Long
    Dim ErrText As String
    Dim ResultDate As Date

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Convert FileTimeValue FILETIME to SysTime SYSTEMTIME.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Res = FileTimeToSystemTime(lpFileTime:=FileTimeValue, lpSystemTime:=SysTime)
    If Res = 0 Then
        '''''''''''''''''''''
        ' An error occurred
        '''''''''''''''''''''
        ErrNum = Err.LastDllError
        ErrText = GetSystemErrorMessageText(ErrNum)
        Debug.Print "Error With FileTimeToSystemTime:" & vbCrLf & _
                    "Err:  " & CStr(ErrNum) & vbCrLf & _
                    "Desc: " & ErrText
        FileTimeToSerialTime = False
        Exit Function
    End If

    With SysTime
        ResultDate = DateSerial(.wYear, .wMonth, .wDay) + _
                    TimeSerial(.wHour, .wMinute, .wSecond)
        MsgBox (ResultDate)
    End With

    FileTimeToSerialTime = ResultDate
End Function

Public Function Hex2ByteArr(ByVal sHex As String) As Byte()
    Dim n As Long
    Dim nCount As Long
    Dim bArr() As Byte
    nCount = Len(sHex)
    If (nCount And 1) = 1 Then
        sHex = "0" & sHex
        nCount = nCount + 1
    End If
    ReDim bArr(nCount \ 2 - 1)
    For n = 1 To nCount Step 2
        bArr((n - 1) \ 2) = CByte("&H" & Mid$(sHex, n, 2))
    Next
    Hex2ByteArr = bArr
End Function

Public Function ByteArr2Long(ArrByte() As Byte) As Long
    Dim myLong, I As Long
    For I = 0 To UBound(ArrByte)
        myLong = myLong + ArrByte(I) * (256 ^ (UBound(ArrByte) - I))
    Next I

    ByteArr2Long = myLong
End Function

Public Function GetSystemErrorMessageText(ErrorNumber As Long) As String
    Dim ErrorText As String
    Dim TextLen As Long
    Dim FormatMessageResult As Long
    Dim LangID As Long

    ' initialize the variables
    LangID = 0&  'default language
    ErrorText = String$(FORMAT_MESSAGE_TEXT_LEN, vbNullChar)
    TextLen = Len(ErrorText)
    On Error Resume Next
    FormatMessageResult = FormatMessage( _
                    dwFlags:=FORMAT_MESSAGE_FROM_SYSTEM Or _
                             FORMAT_MESSAGE_IGNORE_INSERTS, _
                    lpSource:=0&, _
                    dwMessageId:=ErrorNumber, _
                    dwLanguageId:=0&, _
                    lpBuffer:=ErrorText, _
                    nSize:=TextLen, _
                    Arguments:=0&)
    On Error GoTo 0
    If FormatMessageResult = 0& Then
        MsgBox "An error occurred with the FormatMessage" & _
            " API functiopn call. Error: " & _
            CStr(Err.LastDllError) & _
            " Hex(" & Hex(Err.LastDllError) & ")."
        GetSystemErrorMessageText = vbNullString
        Exit Function
    End If
    If FormatMessageResult > 0 Then
        ErrorText = Left$(ErrorText, FormatMessageResult)
        GetSystemErrorMessageText = ErrorText
    Else
        GetSystemErrorMessageText = "NO ERROR DESCRIPTION AVAILABLE"
    End If
End Function

Can somone help me figure out what I'm doing wrong in the conversion from FILETIME to regular system time?

If you copy this Macro to an excel and run it, it is showing a date of 9/17/6241 and some change. The date should really be around 8/12-8/15 2019 (don't have the exact value). What's going on here?

The exact registry key I'm looking at is in: Computer\HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\PowerPoint\Security\Trusted Documents\TrustRecords

and apparently others have been successful in converting the first 2 bytes to a date: https://brettshavers.com/brett-s-blog/entry/regripper

However, thir function is written in Perl and I don't quite understand it.

#-------------------------------------------------------------
# getTime()
# Translate FILETIME object (2 DWORDS) to Unix time, to be passed
# to gmtime() or localtime()
#-------------------------------------------------------------
sub getTime($$) {
  my $lo = shift;
  my $hi = shift;
  my $t;

  if ($lo == 0 && $hi == 0) {
    $t = 0;
  } else {
    $lo -= 0xd53e8000;
    $hi -= 0x019db1de;
    $t = int($hi*429.4967296 + $lo/1e7);
  };
  $t = 0 if ($t < 0);
  return $t;
}

More resources: http://www.cpearson.com/excel/FileTimes.htm

https://learn.microsoft.com/en-us/windows/win32/api/minwinbase/ns-minwinbase-filetime

Solution

Reveres first two bytes of the hex strings like this

str = "36 D0 56 2E 14 52 D5 01 00 60 EE 78 DE FF FF FF C4 00 8E 01 FF FF FF 7F "
str = Left(Replace(Trim(str), " ", ""), 16)
str = Mid(str, 7, 2) & Mid(str, 5, 2) & Mid(str, 3, 2) & Mid(str, 1, 2) & _
      Mid(str, 15, 2) & Mid(str, 13, 2) & Mid(str, 11, 2) & Mid(str, 9, 2)

The result str will be like str = "2E 56 D0 36 01 D5 52 14" and Final result would be Result: 13-08-2019 20:17:50 Credit to Link and Link. However Thanks, I learned a lot why testing and researching