如何将 FILETIME 转换为 VBA 中的日期？
How to convert FILETIME to Date in VBA?
我正在尝试编写一个模块，它将采用从注册表项中提取的 Hex FILETIME 并将其解析为 VBA 中的可读日期。
我从注册表中提取了以下 REG_BINARY 密钥：
36 D0 56 2E 14 52 D5 01 00 60 EE 78 DE FF FF FF C4 00 8E 01 FF FF FF 7F
到目前为止，我有以下函数来尝试转换它：
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
相关帮手潜艇：
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
谁能帮我弄清楚我在从 FILETIME 到常规系统时间的转换中做错了什么？
如果您将此宏复制到 excel 和 运行，它会显示日期 9/17/6241 和一些变化。日期实际上应该在 2019 年 8 月 12 日至 8 月 15 日左右（没有确切的值）。这是怎么回事？
我正在查看的确切注册表项位于：
Computer\HKEY_CURRENT_USER\Software\Microsoft\Office.0\PowerPoint\Security\Trusted Documents\TrustRecords
显然其他人已经成功地将前 2 个字节转换为日期：
https://brettshavers.com/brett-s-blog/entry/regripper
不过，这个函数是用Perl写的，我不是很懂。
#-------------------------------------------------------------
# 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;
}
更多资源：http://www.cpearson.com/excel/FileTimes.htm
https://docs.microsoft.com/en-us/windows/win32/api/minwinbase/ns-minwinbase-filetime
像这样反转十六进制字符串的前两个字节
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)
结果 str 会像 str = "2E 56 D0 36 01 D5 52 14" 最终结果会是 Result: 13-08-2019 20:17:50
感谢 Link and Link。然而
谢谢，我学到了很多为什么要测试和研究
我正在尝试编写一个模块，它将采用从注册表项中提取的 Hex FILETIME 并将其解析为 VBA 中的可读日期。
我从注册表中提取了以下 REG_BINARY 密钥：
36 D0 56 2E 14 52 D5 01 00 60 EE 78 DE FF FF FF C4 00 8E 01 FF FF FF 7F
到目前为止，我有以下函数来尝试转换它：
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
相关帮手潜艇：
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
谁能帮我弄清楚我在从 FILETIME 到常规系统时间的转换中做错了什么？
如果您将此宏复制到 excel 和 运行，它会显示日期 9/17/6241 和一些变化。日期实际上应该在 2019 年 8 月 12 日至 8 月 15 日左右（没有确切的值）。这是怎么回事？
我正在查看的确切注册表项位于： Computer\HKEY_CURRENT_USER\Software\Microsoft\Office.0\PowerPoint\Security\Trusted Documents\TrustRecords
显然其他人已经成功地将前 2 个字节转换为日期： https://brettshavers.com/brett-s-blog/entry/regripper
不过，这个函数是用Perl写的，我不是很懂。
#-------------------------------------------------------------
# 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;
}
更多资源：http://www.cpearson.com/excel/FileTimes.htm
https://docs.microsoft.com/en-us/windows/win32/api/minwinbase/ns-minwinbase-filetime
像这样反转十六进制字符串的前两个字节
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)
结果 str 会像 str = "2E 56 D0 36 01 D5 52 14" 最终结果会是 Result: 13-08-2019 20:17:50
感谢 Link and Link。然而
谢谢，我学到了很多为什么要测试和研究