実はネットで検索して見つけたプログラムをABに移植しただけで自分でもあまり理解していなかったりします。
秒未満の単位で格納されているので、1844(中略)1616秒まで対応しているわけではありませんが、少なくとも万年くらいは平気でしょう。
(注意:おそらくNT系限定だと思われます)
コード: 全て選択
#strict
Dim Second As QWord, Min As DWord, Hour As DWord, Day As DWord
Second = GetTickCount64()
Day = (Second \ 86400) As DWord
Second = Second - Day * 86400
Hour = (Second \ 3600) As DWord
Second = Second - Hour * 3600
Min = (Second \ 60) As DWord
Second = Second - Min * 60
Dim Str[1024] As Byte
wsprintf(Str, "%u日 %u時間 %u分 %u秒", Day, Hour, Min, Second As DWord)
MessageBox(0, Str, "起動してから", MB_OK)
Class TempMemory '即席
Public
Sub TempMemory()(AllocSize As DWord)
size = AllocSize
ptr = malloc(size)
End Sub
Sub ~TempMemory()
If ptr <> 0 Then free(ptr)
End Sub
Function Ptr() As *Byte
Ptr = ptr
End Function
Function Size() As DWord
Size = size
End Function
Sub ReSize(NewSize As DWord)
ptr = realloc(ptr, NewSize)
End Sub
Private
ptr As *Byte
size As DWord
End Class
Type PERF_DATA_BLOCK
Signature[ELM(4)] As WCHAR
LittleEndian As DWord
Version As DWord
Revision As DWord
TotalByteLength As DWord
HeaderLength As DWord
NumObjectTypes As DWord
DefaultObject As DWord
SystemTime As SYSTEMTIME
Private
dammy0 As DWord
Public
PerfTime As QWord
PerfFreq As QWord
PerfTime100nSec As QWord
SystemNameLength As DWord
SystemNameOffset As DWord
End Type
Type PERF_OBJECT_TYPE
TotalByteLength As DWord
DefinitionLength As DWord
HeaderLength As DWord
ObjectNameTitleIndex As DWord
ObjectNameTitle As *WCHAR
ObjectHelpTitleIndex As DWord
ObjectHelpTitle As *WCHAR
DetailLevel As DWord
NumCounters As DWord
DefaultCounter As DWord
NumInstances As DWord
CodePage As DWord
PerfTime As QWord
PerfFreq As QWord
End Type
Type PERF_COUNTER_DEFINITION
ByteLength As DWord
CounterNameTitleIndex As DWord
CounterNameTitle As *WCHAR
CounterHelpTitleIndex As DWord
CounterHelpTitle As *WCHAR
DefaultScale As DWord
DetailLevel As DWord
CounterType As DWord
CounterSize As DWord
CounterOffset As DWord
End Type
Const ERROR_MORE_DATA = 234
Function GetTickCount64() As QWord
Dim pPerfData = 0 As *PERF_DATA_BLOCK
Dim getSize As DWord
Dim lError = ERROR_MORE_DATA As Long
Dim Buffer As TempMemory(1024)
If Buffer.Ptr() = 0 Then
Exit Function
End If
'取れるまで領域を増やしつつ繰り返す
Do
getSize = Buffer.Size()
Dim hKey = HKEY_PERFORMANCE_DATA As HKEY
lError = RegQueryValueEx(hKey, "2", 0, 0, Buffer.Ptr() As VoidPtr, VarPtr(getSize))
If lError <> 0 And lError <> ERROR_MORE_DATA Then
Exit Function
End If
pPerfData = Buffer.Ptr() As *PERF_DATA_BLOCK
If getSize > 0 And memcmp(pPerfData->Signature, Ex"P\0E\0R\0F\0", 8) = 0 Then
Exit Do
End If
If Buffer.Size() > 65536 Then
Exit Do
End If
Buffer.ReSize(Buffer.Size() + 1024)
Loop While lError = ERROR_MORE_DATA
If pPerfData->NumObjectTypes = 0 Then
Exit Function
End If
Dim offset As DWord
offset = pPerfData->HeaderLength
Dim pObj As *PERF_OBJECT_TYPE
pObj = (Buffer.Ptr() + offset) As *PERF_OBJECT_TYPE
offset = offset + pObj->HeaderLength
Dim pDef As *PERF_COUNTER_DEFINITION
pDef = (Buffer.Ptr() + offset) As *PERF_COUNTER_DEFINITION
Dim pDefUptime = 0 As *PERF_COUNTER_DEFINITION
Dim i As DWord
For i = 0 To pObj->NumCounters
If pDef->CounterNameTitleIndex = 674 Then
pDefUptime = pDef
Exit For
End If
offset = offset + pDef->ByteLength
pDef = (Buffer.Ptr() + offset) As *PERF_COUNTER_DEFINITION
Next
If pDefUptime = 0 Then
Exit Function
End If
Dim Time As QWord
memcpy(VarPtr(Time), pObj As *Byte + pObj->DefinitionLength + pDefUptime->CounterOffset, SizeOf (QWord))
GetTickCount64 = (pObj->PerfTime - Time) / pObj->PerfFreq
End Function