LoginSignup
1
1

More than 5 years have passed since last update.

@Q11Q

VBA Win32Api QueryPerfomanceCounter Class Win64/32 共用

Last updated at Posted at 2018-09-04

コード

Procedure Module 標準モジュール

カウンタを秒単位に変えるため

  1. 1秒当たりの周波数
  2. 1秒あたりのSleepによるカウンタ数の平均

を使って、精度を高める


'General Declaretionに記述してください
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub QPCounterAdjustValue()
' 標準モジュール用のコードです
' Classモジュールでは動きません。かならず標準モジュールに記述してください。
' QueryPerformanceカウンターの補正値を3回Sleppをかけて求めます
' 絶対に正確ではありませんが、相対的により正確です
' Immediate Windowの値をcndOVHに入れてください
#If VBA7 And Win64 Then
Dim curFq As LongLong
Dim QPCt1 As LongLong, QPCt2 As LongLong
Dim OVH As LongLong
Const QPCFloatPoint = 1&
#Else
Dim curFq As Currency
Dim QPCt1 As Currency, QPCt2 As Currency
Dim OVH As Currency
Const QPCFloatPoint = 10000&
#End If
Dim i As Long
' Start : Dim And New For QueryPerformanceCounterClass　/////////////////
Dim clsQueryPerformanceCounter As QueryPerformanceCounterClass
Set clsQueryPerformanceCounter = New QueryPerformanceCounterClass
curFq = clsQueryPerformanceCounter.Get_Freq * QPCFloatPoint
' End : Dim And New For QueryPerformanceCounterClass　/////////////////
''1秒間のSleepで補正値を取得
' 周波数だけでは精度が出ないのでSleepで1秒間のカウントを取得、この差をもって校正値として精度を高める
' 補正値はConstで定義する
Set clsQueryPerformanceCounter = New QueryPerformanceCounterClass
For i = 1 To 3

QPCt1 = clsQueryPerformanceCounter.QPCnt * QPCFloatPoint
Sleep 1000
QPCt2 = clsQueryPerformanceCounter.QPCnt * QPCFloatPoint

OVH = (QPCt2 - QPCt1) + OVH
Next
Debug.Print Int(OVH / 3) & vbCrLf & " Const cnsOVH = " & Int(OVH / 3)
MsgBox "Adjust Value" & Int(OVH / 3), vbOKOnly + vbInformation, "Complete"
End Sub


'’’’’’’’’’’’’’’'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''  標準モジュール用 その２ 実際に計測するサンプル
'’  機種ごとでも時間補正係数は異なるし、稼働状況でも異なるので、使用の都度あらかじめ時間補正係数を取得すること
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub QueryPerfomanceCounterTest()
' 標準モジュール用のコードです
' Classモジュールでは動きません。かならず標準モジュールに記述してください。
' QueryPerfomanceCounterの例です
' 変数宣言 QueryPerformanceCounterは　BIG_Integerという変数の型を使用します。
' VBA7 かつ 64bitの場合 LongLongに相当します。それ以外ではCurrencyを代用します
' MilliSecond ( ms ) 単位の時間で計測しますが、クラスモジュールを使用するため、標準モジュールより誤差はあります。
' QPCを使う前に必ずQPCounterAdjustValueで定数cnsOVHの値を求めてください。

' QPCounterAdjustValueで求めた補正値を定数として定める。下記の値は機種ごとに異なるので暫定値です。
#If VBA7 And Win64 Then
Const cnsOVH = 1563580 'Office 2010以降で64Bitを使っている人はこちらを書き換える
#Else
Const cnsOVH = 2250679 '正常で善良な市民は通常こちらを書き換える。上を使う人間はいない。いたらおかしい。
#End If

' Start : Dim And New For QueryPerformanceCounterClass　/////////////////
#If VBA7 And Win64 Then
Dim curSt As LongLong
Dim curEn As LongLong
Dim curFq As LongLong
Dim QPCt1 As LongLong, QPCt2 As LongLong
Dim OVH As LongLong
Const QPCFloatPoint = 1&
#Else
Dim curSt As Currency
Dim curEn As Currency
Dim curFq As Currency
Const QPCFloatPoint = 10000&
#End If
Dim clsQueryPerformanceCounter As QueryPerformanceCounterClass
Set clsQueryPerformanceCounter = New QueryPerformanceCounterClass
curFq = clsQueryPerformanceCounter.Get_Freq * QPCFloatPoint
' End : Dim And New For QueryPerformanceCounterClass　/////////////////

' ClearTimeの代わりに Set Newを行う
Set clsQueryPerformanceCounter = New QueryPerformanceCounterClass
' Start Time Counter Get 開始時間を取得
curSt = clsQueryPerformanceCounter.QPCnt * QPCFloatPoint

' 実行コードを記述する

Sleep 500 'Sleepで500msecを計測する ただしSleepは正確ではないのでここでも誤差が出る

' End Time Counter Get 終了時間を取得
curEn = clsQueryPerformanceCounter.QPCnt * QPCFloatPoint

' CurrencyでもLongLongでも各項の桁数が合うので、10000を気にする必要はない.
' 単純に差を出してもFrequencyで割っても精度が出ない。
Debug.Print "Simple Count Value " & (curEn - curSt)
Debug.Print "Count with Freq " & (curEn - curSt) / curFq

' 実際は以下の2つのうち、どちらかを用いる

' 差をOVHで割ることで1秒のカウンタに補正しさらに1秒当たり周波数で補正する。単位秒数
Debug.Print "Total Seconds " & CDec((curEn - curSt) / cnsOVH / curFq * QPCFloatPoint)

' 差をOVHで割ることで1秒のカウンタに補正しさらに1秒当たり周波数で補正する。このままでは秒なのでミリセカントにするため1000倍し、Cdecで指数表示を抑制
Debug.Print "Total MilliSecond " & CDec((curEn - curSt) / cnsOVH / curFq * QPCFloatPoint * 1000)
End Sub

Class Module クラスモジュール


Option Explicit

'''''''''''''''''''''''''''''''''''''
' Class Module
' QueryPerformanceCounterClass
' Win 64/32
' Win32API 関数の QueryPerformanceFrequency が0でないか確認し、そうでなければ、 QueryPerformanceCounter
' を使用します。標準モジュール側で10000倍にしてください。
' Large_Integer は VBAでは同じ64BitであるCurrencyに使うのが主流なようです
'
'
''''''''''''''''''''''''''''''''''''''''
#If VBA7 Then
#If Win64 Then
' Performance counter API's
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LongLong) As Long
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LongLong) As Long
'Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
'Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
#Else
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

#End If
#Else
'高分解能パフォーマンスカウンタ用API
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
' Private Declare Function QueryPerformanceCounter Lib "kernel32" Alias "QueryPerformanceCounter" (lpPerformanceCount As LARGE_INTEGER) As Long
' Private Declare Function QueryPerformanceFrequency Lib "kernel32" Alias "QueryPerformanceFrequency" (lpFrequency As LARGE_INTEGER) As Long
#End If
' 将来使う時のために宣言
Private Type LARGE_INTEGER
LowPart As Long
HighPart As Long
End Type

'Class Module内の変数を宣言
#If VBA7 Then
#If Win64 Then
Dim curFreq As LongLong
Dim curNowtime As LongLong
#Else
Dim curFreq As Currency
Dim curNowtime As Currency
#End If
#Else
Dim curFreq As Currency
Dim curNowtime As Currency
#End If


#If VBA7 Then
    #If Win64 Then
    Property Get Get_Freq() As LongLong
    Get_Freq = QueryPerformanceFrequency(curFreq)
    End Property
    #Else
    Property Get Get_Freq() As Currency
    Get_Freq = QueryPerformanceFrequency(curFreq)
    End Property
    #End If
#Else
Property Get Get_Freq() As Currency
Get_Freq = QueryPerformanceFrequency(curFreq)
End Property
#End If

' アクセサ Property Get QPCnt //////////////////////////////////////////////////////////////////////////
#If VBA7 Then
    #If Wih64 Then
        Property Get QPCnt() As LongLong
        If QueryPerformanceFrequency(curFreq) > 0 Then
        Call QueryPerformanceCounter(curNowtime)
        QPCnt = curNowtime
        End If
    End Property
    #Else
        Property Get QPCnt() As Currency
        If QueryPerformanceFrequency(curFreq) > 0 Then
        Call QueryPerformanceCounter(curNowtime)
        QPCnt = CCur(curNowtime)
        End If
        End Property
    #End If
#Else
Property Get QPCnt() As Currency
If QueryPerformanceFrequency(curFreq) > 0 Then
Call QueryPerformanceCounter(curNowtime)
QPCnt = curNowtime
End If
End Property
#End If

''''SampleCode For Module
' 標準モジュールコ用のコードです
' Classモジュールでは動きません。かならず標準モジュールに記述してください。

''General Declaretionに記述してください
'#If VBA7 Then
'Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'#Else
'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'#End If
'Sub QPCounterAdjustValue()
'' 標準モジュール用のコードです
'' Classモジュールでは動きません。かならず標準モジュールに記述してください。
'' QueryPerformanceカウンターの補正値を3回Sleppをかけて求めます
'' 絶対に正確ではありませんが、相対的により正確です
'' Immediate Windowの値をcndOVHに入れてください
'#If VBA7 And Win64 Then
'Dim curFq As LongLong
'Dim QPCt1 As LongLong, QPCt2 As LongLong
'Dim OVH As LongLong
'Const QPCFloatPoint = 1&
'#Else
'Dim curFq As Currency
'Dim QPCt1 As Currency, QPCt2 As Currency
'Dim OVH As Currency
'Const QPCFloatPoint = 10000&
'#End If
'Dim i As Long
'' Start : Dim And New For QueryPerformanceCounterClass　/////////////////
'Dim clsQueryPerformanceCounter As QueryPerformanceCounterClass
'Set clsQueryPerformanceCounter = New QueryPerformanceCounterClass
'curFq = clsQueryPerformanceCounter.Get_Freq * QPCFloatPoint
'' End : Dim And New For QueryPerformanceCounterClass　/////////////////
'''1秒間のSleepで補正値を取得
'' 周波数だけでは精度が出ないのでSleepで1秒間のカウントを取得、この差をもって校正値として精度を高める
'' 補正値はConstで定義する
'Set clsQueryPerformanceCounter = New QueryPerformanceCounterClass
'For i = 1 To 3
'
'QPCt1 = clsQueryPerformanceCounter.QPCnt * QPCFloatPoint
'Sleep 1000
'QPCt2 = clsQueryPerformanceCounter.QPCnt * QPCFloatPoint
'
'OVH = (QPCt2 - QPCt1) + OVH
'Next
'Debug.Print Int(OVH / 3) & vbCrLf & " Const cnsOVH = " & Int(OVH / 3)
'MsgBox "Adjust Value" & Int(OVH / 3), vbOKOnly + vbInformation, "Complete"
'End Sub


'’’’’’’’’’’’’’’'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''  標準モジュール用 その２ 実際に計測するサンプル
'’  機種ごとでも時間補正係数は異なるし、稼働状況でも異なるので、使用の都度あらかじめ時間補正係数を取得すること
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Sub QueryPerfomanceCounterTest()
'' 標準モジュール用のコードです
'' Classモジュールでは動きません。かならず標準モジュールに記述してください。
'' QueryPerfomanceCounterの例です
'' 変数宣言 QueryPerformanceCounterは　BIG_Integerという変数の型を使用します。
'' VBA7 かつ 64bitの場合 LongLongに相当します。それ以外ではCurrencyを代用します
'' MilliSecond ( ms ) 単位の時間で計測しますが、クラスモジュールを使用するため、標準モジュールより誤差はあります。
'' QPCを使う前に必ずQPCounterAdjustValueで定数cnsOVHの値を求めてください。
'
'' QPCounterAdjustValueで求めた補正値を定数として定める。下記の値は機種ごとに異なるので暫定値です。
'#If VBA7 And Win64 Then
'Const cnsOVH = 1563580
'#Else
'Const cnsOVH = 2250679
'#End If
'
'' Start : Dim And New For QueryPerformanceCounterClass　/////////////////
'#If VBA7 And Win64 Then
'Dim curSt As LongLong
'Dim curEn As LongLong
'Dim curFq As LongLong
'Dim QPCt1 As LongLong, QPCt2 As LongLong
'Dim OVH As LongLong
'Const QPCFloatPoint = 1&
'#Else
'Dim curSt As Currency
'Dim curEn As Currency
'Dim curFq As Currency
'Const QPCFloatPoint = 10000&
'#End If
'Dim clsQueryPerformanceCounter As QueryPerformanceCounterClass
'Set clsQueryPerformanceCounter = New QueryPerformanceCounterClass
'curFq = clsQueryPerformanceCounter.Get_Freq * QPCFloatPoint
'' End : Dim And New For QueryPerformanceCounterClass　/////////////////
'
'' ClearTimeの代わりに Set Newを行う
'Set clsQueryPerformanceCounter = New QueryPerformanceCounterClass
'
'curSt = clsQueryPerformanceCounter.QPCnt * QPCFloatPoint ' Start Time Counter Get 開始時間を取得
'' 実行コードを記述する SampleではSleepを500ms行う
'
'Sleep 500 'Sleepで500msecを計測する ただしSleepは正確ではないのでここでも誤差が出る
'
'' End Time Counter Get 終了時間を取得
'curEn = clsQueryPerformanceCounter.QPCnt * QPCFloatPoint
'
'' CurrencyでもLongLongでも各項の桁数が合うので、10000を気にする必要はない.
'' 単純に差を出してもFrequencyで割っても精度が出ない。
'Debug.Print "Simple Count Value " & (curEn - curSt)
'Debug.Print "Count with Freq " & (curEn - curSt) / curFq
'
'' 実際は以下の2つのうち、どちらかを用いる
'
'' 差をOVHで割ることで1秒のカウンタに補正しさらに1秒当たり周波数で補正する。単位秒数
'Debug.Print "Total Seconds " & CDec((curEn - curSt) / cnsOVH / curFq * QPCFloatPoint)
'
'' 差をOVHで割ることで1秒のカウンタに補正しさらに1秒当たり周波数で補正する。このままでは秒なのでミリセカントにするため1000倍し、Cdecで指数表示を抑制
'Debug.Print "Total MilliSecond " & CDec((curEn - curSt) / cnsOVH / curFq * QPCFloatPoint * 1000)
'End Sub

ポイント

Big_IntegerはCurrencyにする(64 bit 以外)

Best Milliseconds Timer in VBA Tutorial

GetTickCount, timeGetTime等の精度について

しかし Currencyではなく Doubleを使うべきだという説もある

Excel作業をVBAで効率化

高分解能パフォーマンスカウンタ値変数の型について

5行目と6行目の変数定義ではDouble型を利用しています。
これには理由があります。
ネット上にあるマイクロ秒の取得方法では、高分解能パフォーマンスカウンタ値用の変数の型に、通貨型であるCurrency型を使っているものがとても多いですが、これには問題があります。
なぜCurrency型を使っているのかと言うと、おそらくマイクロソフトがサンプル（https://msdn.microsoft.com/ja-jp/library/aa730921.aspx）で出しているコードがそう書いてあるからだと思います。
何が問題なのかと言うと、型の精度が関数の結果と異なる点です。
16行目のQueryPerformanceCounter関数の引数はLARGE_INTEGER型いう構造体になっており、実際のカウンタ値を保持する変数はLONGLONG型という、-9,223,372,036,854,775,808 ～ 9,223,372,036,854,775,807 の値範囲の符号付き 64ビット(8バイト)数値の型です。
それに対してVBAのCurrency型は整数15桁と小数4桁として-922,337,203,685,477.5808 ～ 922,337,203,685,477,5807 の値範囲の8バイトです。
見た目の数値は似ていますが整数精度が異なります。
そのため、PCが起動してからの時間が長い場合に、QueryPerformanceCounter関数の結果がCurrency型の範囲を超える懸念があるため、その状況になった場合にCurrency型で正しく取得できるかには疑問が残ります。
そのことから制約がなるべく少ない方がよいと思われるため、LONGLONGと同じ8バイトのDouble型で実装しています。
Double型にはCurrency型のような精度制約はありません

MSのサイトのコード


Private Declare Function getFrequency Lib "kernel32" Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare Function getTickCount Lib "kernel32" _
Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long
'
Function MicroTimer() As Double
'

' Returns seconds.
'
    Dim cyTicks1 As Currency
    Static cyFrequency As Currency
    '
    MicroTimer = 0

' Get frequency.
    If cyFrequency = 0 Then getFrequency cyFrequency

' Get ticks.
    getTickCount cyTicks1                            

' Seconds
    If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency 
End Function

確かにCurrencyになっている。

そこで今回64bit はLonglong型を使用する

LongLong データ型

LongLong ( LongLong 整数) 変数は、-9,223,372,036,854,775,808 ～ 9,223,372,036,854,775,807 の値範囲の符号付き 64 ビット (8 バイト) 数値として格納されます。 LongLong の 型宣言文字 は、キャレット (^) です。 LongLong は、64 ビット プラットフォームのみで有効な宣言型です。

このように64bit であり、使用可能。少なくとも64bitで指摘の通り通貨型を使用する必要はない。一方でDoubleは演算誤差がある。

時刻補正値の計測追加

周波数補正だけでは時間が出なかったのですがClassモジュールで計測した値から、1秒のカウント数を求めて割るようにすると、かなり精度が高いです。
上記の500msのSleepも
Total MilliSecond 500.453446577725
Total MilliSecond 500.138784072449
Total MilliSecond 500.024303201627
このように500msが出る。

しかし補正値は出すごとに変わる

補正値は64/32はもちろん、同じ個体でも状況で変わります。
使用する前に補正値を取得してConstを書き換えた方がよいです。

長時間はgetTimegetになる

なのでこのClassの時間計測はLongLongまたはCurrencyの最大値なので長時間を計測するのには向きません。あくまでもごく短い時間用のようです。

1
1
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
1
1