0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@kenichiro_ayaki(綾木 健一郎)

特許情報取得APIとUSPTO APIのテスト

0
Last updated at Posted at 2026-01-22

app_progress

アクセス時間 1.6秒 程度

Option Explicit

' APIのエンドポイント
Private Const JPO_BASE_URL As String = "https://ip-data.jpo.go.jp/api/patent/v1/app_progress/"


#If Win64 Then
    Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (frequency As Double) As Long
    Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (procTime As Double) As Long
#Else
    Declare Function QueryPerformanceFrequency Lib "kernel32" (frequency As Double) As Long
    Declare Function QueryPerformanceCounter Lib "kernel32" (procTime As Double) As Long
#End If

'---------------------------------------------------------------------------------------
' メイン処理: セルからID/Passを読み込んで認証し、経過情報を取得する
'---------------------------------------------------------------------------------------
Public Sub Test_JPO_app_progress_API_CellInput()
    Dim userId As String
    Dim password As String
    Dim appNumber As String
    Dim accessToken As String
    Dim strResponse As String
    Dim ws As Worksheet
    Dim jpo_auth_url As String
    
    Set ws = ActiveSheet
    
    ' --- 1. セルから情報の取得 ---
    ' IDとパスワードを取得 (空欄チェック付き)
    userId = CStr(ws.Range("B1").Value)
    password = CStr(ws.Range("B2").Value)
    jpo_auth_url = CStr(ws.Range("B3").Value)
    
    ' 出願番号は B4
    appNumber = CStr(ws.Range("B4").Value)
    Range("A5:Z8192").Clear
    
    ' 入力チェック
    If userId = "" Or password = "" Then
        MsgBox "B1セルにID、B2セルにパスワードを入力してください。", vbExclamation
        Exit Sub
    End If
    
    If appNumber = "" Then
        MsgBox "B4セルに出願番号を入力してください。", vbExclamation
        Exit Sub
    End If
    
    ' --- 2. アクセストークンの取得 (認証) ---
    ' セルから取得したIDとパスワードを渡す
    accessToken = GetJPOAccessToken(userId, password, jpo_auth_url)
    
    If accessToken = "" Then
        MsgBox "認証に失敗しました。" & vbCrLf & _
               "ID(B1)とパスワード(B2)が正しいか確認してください。", vbCritical
        Exit Sub
    End If
    
    Debug.Print "Token取得成功: " & Left(accessToken, 10) & "..."
    
    ' --- 3. 経過情報の取得 ---
    Dim tick_start As Double
    tick_start = GetMicroSecond()
    strResponse = CallJPOProgressAPI(appNumber, accessToken)
    Dim tick_end As Double
    tick_end = GetMicroSecond()
    
    ' --- 4. 結果出力 ---
    ' 結果をB5以降に出力
    ws.Range("A5").Value = "access_token"
    ws.Range("B5").Value = accessToken
    
    ws.Range("A6").Value = "API URL"
    ws.Range("B6").Value = JPO_BASE_URL & appNumber
    
    ws.Range("A7").Value = "レスポンス(JSON)"
    ws.Range("B7").Value = Left(strResponse, 32000)
    
    ws.Range("A8").Value = "アクセス時間"
    ws.Range("B8").Value = tick_end - tick_start
    
    MsgBox "処理完了。", vbInformation
    
End Sub

'---------------------------------------------------------------------------------------
' 関数: ID/Passを送信してアクセストークンを取得する (変更なし)
'---------------------------------------------------------------------------------------
Private Function GetJPOAccessToken(userId As String, password As String, jpo_auth_url As String) As String
    Dim httpReq As Object
    Dim strBody As String
    Dim strResp As String
    
    ' JSONボディの作成
    ' ※IDやPassにダブルクォーテーションが含まれることは稀ですが、ある場合はエスケープが必要です
    strBody = "grant_type=password"
    strBody = strBody & "&username=" & encodeUrlUtf8(userId)
    strBody = strBody & "&password=" & encodeUrlUtf8(password)
    
    Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    With httpReq
        .Open "POST", jpo_auth_url, False
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        
        On Error Resume Next
        .Send strBody
        If Err.Number <> 0 Then
            Debug.Print "Auth通信エラー: " & Err.Description
            Exit Function
        End If
        On Error GoTo 0
        
        If .Status = 200 Then
            ' JSONから "accessToken" の値を簡易的に抽出
            GetJPOAccessToken = ExtractJsonValue(GetUTF8String(.ResponseBody), "access_token")
        Else
            Debug.Print "Auth Error Status: " & .Status
            Debug.Print GetUTF8String(.ResponseBody)
        End If
    End With
    Set httpReq = Nothing
End Function

'---------------------------------------------------------------------------------------
' 関数: アクセストークンを使って経過情報を取得する (変更なし)
'---------------------------------------------------------------------------------------
Private Function CallJPOProgressAPI(appNum As String, token As String) As String
    Dim httpReq As Object
    Dim targetUrl As String
    
    targetUrl = JPO_BASE_URL & appNum
    
    Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    With httpReq
        .Open "GET", targetUrl, False
        
        ' Bearer認証ヘッダーの設定
        .SetRequestHeader "Authorization", "Bearer " & token
        .SetRequestHeader "Accept", "application/json"
        
        On Error Resume Next
        .Send
        If Err.Number <> 0 Then
            CallJPOProgressAPI = "通信エラー: " & Err.Description
            Exit Function
        End If
        On Error GoTo 0
        
        CallJPOProgressAPI = GetUTF8String(.ResponseBody)
        
        If .Status <> 200 Then
            Debug.Print "API Error: " & .Status
        End If
    End With
    Set httpReq = Nothing
End Function

'---------------------------------------------------------------------------------------
' 共通関数: バイナリデータをUTF-8文字列に変換 (変更なし)
'---------------------------------------------------------------------------------------
Private Function GetUTF8String(ByVal rawBinary As Variant) As String
    Dim adoStream As Object
    Set adoStream = CreateObject("ADODB.Stream")
    With adoStream
        .Type = 1 ' Binary
        .Open
        .Write rawBinary
        .Position = 0
        .Type = 2 ' Text
        .Charset = "UTF-8"
        GetUTF8String = .ReadText
        .Close
    End With
    Set adoStream = Nothing
End Function

'---------------------------------------------------------------------------------------
' 簡易JSON値抽出関数 (変更なし)
'---------------------------------------------------------------------------------------
Private Function ExtractJsonValue(jsonStr As String, key As String) As String
    Dim p1 As Long, p2 As Long
    Dim searchKey As String
    
    searchKey = """" & key & """"
    p1 = InStr(jsonStr, searchKey)
    
    If p1 > 0 Then
        p1 = InStr(p1 + Len(searchKey), jsonStr, """")
        If p1 > 0 Then
            p2 = InStr(p1 + 1, jsonStr, """")
            If p2 > 0 Then
                ExtractJsonValue = Mid(jsonStr, p1 + 1, p2 - p1 - 1)
            End If
        End If
    End If
End Function

'----------------------------------------------------------------------
' 機能: 文字列をURLエンコード (UTF-8)
' 備考: 64bit版 Excel対応 (htmlfileオブジェクトを使用)
'----------------------------------------------------------------------
Private Function encodeUrlUtf8(ByVal strSource As String) As String
    Dim objHtml As Object
    
    ' ScriptControlの代わりに htmlfile を使用
    Set objHtml = CreateObject("htmlfile")
    
    ' htmlfile 内で JScript を実行できる環境を作る
    objHtml.parentWindow.execScript "function encode(s) {return encodeURIComponent(s);}", "JScript"
    
    ' 定義した関数を呼び出す
    encodeUrlUtf8 = objHtml.parentWindow.encode(strSource)
    
    Set objHtml = Nothing
End Function

Private Function GetMicroSecond() As Double
    Dim procTime            As Double       '// 高分解能パフォーマンスカウンタ値（システム起動からの加算値）
    Dim frequency           As Double       '// 高分解能パフォーマンスカウンタの周波数（１秒間に増えるカウントの数）
    Dim ret                 As Double       '// 計測結果
    
    '// 計測時刻を0で初期化
    GetMicroSecond = 0
 
    '// 更新頻度を取得
    Call QueryPerformanceFrequency(frequency)
 
    '// 処理時刻を取得
    Call QueryPerformanceCounter(procTime)
 
    '// カウンタ値を１秒間のカウント増加数で割り、正確な時刻を算出
    GetMicroSecond = procTime / frequency
End Function

jpp_fixed_address

アクセス時間：0.67秒程度

Option Explicit

' APIのエンドポイント
Private Const JPO_BASE_URL As String = "https://ip-data.jpo.go.jp/api/patent/v1/jpp_fixed_address/"


#If Win64 Then
    Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (frequency As Double) As Long
    Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (procTime As Double) As Long
#Else
    Declare Function QueryPerformanceFrequency Lib "kernel32" (frequency As Double) As Long
    Declare Function QueryPerformanceCounter Lib "kernel32" (procTime As Double) As Long
#End If

'---------------------------------------------------------------------------------------
' メイン処理: セルからID/Passを読み込んで認証し、経過情報を取得する
'---------------------------------------------------------------------------------------
Public Sub Test_jpp_fixed_address_API_CellInput()
    Dim userId As String
    Dim password As String
    Dim appNumber As String
    Dim accessToken As String
    Dim strResponse As String
    Dim ws As Worksheet
    Dim jpo_auth_url As String
    
    
    Set ws = ActiveSheet
    
    ' --- 1. セルから情報の取得 ---
    ' IDとパスワードを取得 (空欄チェック付き)
    userId = CStr(ws.Range("B1").Value)
    password = CStr(ws.Range("B2").Value)
    jpo_auth_url = CStr(ws.Range("B3").Value)
    
    ' 出願番号は B4
    appNumber = CStr(ws.Range("B4").Value)
    Range("A5:Z8192").Clear
    
    ' 入力チェック
    If userId = "" Or password = "" Then
        MsgBox "B1セルにID、B2セルにパスワードを入力してください。", vbExclamation
        Exit Sub
    End If
    
    If appNumber = "" Then
        MsgBox "B4セルに出願番号を入力してください。", vbExclamation
        Exit Sub
    End If
    
    ' --- 2. アクセストークンの取得 (認証) ---
    ' セルから取得したIDとパスワードを渡す
    accessToken = GetJPOAccessToken(userId, password, jpo_auth_url)
    
    If accessToken = "" Then
        MsgBox "認証に失敗しました。" & vbCrLf & _
               "ID(B1)とパスワード(B2)が正しいか確認してください。", vbCritical
        Exit Sub
    End If
    
    Debug.Print "Token取得成功: " & Left(accessToken, 10) & "..."
    
    ' --- 3. 経過情報の取得 ---
    Dim tick_start As Double
    tick_start = GetMicroSecond()
    strResponse = CallJPOProgressAPI(appNumber, accessToken)
    Dim tick_end As Double
    tick_end = GetMicroSecond()
    
    ' --- 4. 結果出力 ---
    ' 結果をB5以降に出力
    ws.Range("A5").Value = "access_token"
    ws.Range("B5").Value = accessToken
    
    ws.Range("A6").Value = "API URL"
    ws.Range("B6").Value = JPO_BASE_URL & appNumber
    
    ws.Range("A7").Value = "レスポンス(JSON)"
    ws.Range("B7").Value = Left(strResponse, 32000)
    
    ws.Range("A8").Value = "アクセス時間"
    ws.Range("B8").Value = tick_end - tick_start
    
    MsgBox "処理完了。", vbInformation
    
End Sub

'---------------------------------------------------------------------------------------
' 関数: ID/Passを送信してアクセストークンを取得する (変更なし)
'---------------------------------------------------------------------------------------
Private Function GetJPOAccessToken(userId As String, password As String, jpo_auth_url As String) As String
    Dim httpReq As Object
    Dim strBody As String
    Dim strResp As String
    
    ' JSONボディの作成
    ' ※IDやPassにダブルクォーテーションが含まれることは稀ですが、ある場合はエスケープが必要です
    strBody = "grant_type=password"
    strBody = strBody & "&username=" & encodeUrlUtf8(userId)
    strBody = strBody & "&password=" & encodeUrlUtf8(password)
    
    Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    With httpReq
        .Open "POST", jpo_auth_url, False
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        
        On Error Resume Next
        .Send strBody
        If Err.Number <> 0 Then
            Debug.Print "Auth通信エラー: " & Err.Description
            Exit Function
        End If
        On Error GoTo 0
        
        If .Status = 200 Then
            ' JSONから "accessToken" の値を簡易的に抽出
            GetJPOAccessToken = ExtractJsonValue(GetUTF8String(.ResponseBody), "access_token")
        Else
            Debug.Print "Auth Error Status: " & .Status
            Debug.Print GetUTF8String(.ResponseBody)
        End If
    End With
    Set httpReq = Nothing
End Function

'---------------------------------------------------------------------------------------
' 関数: アクセストークンを使って経過情報を取得する (変更なし)
'---------------------------------------------------------------------------------------
Private Function CallJPOProgressAPI(appNum As String, token As String) As String
    Dim httpReq As Object
    Dim targetUrl As String
    
    targetUrl = JPO_BASE_URL & appNum
    
    Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    With httpReq
        .Open "GET", targetUrl, False
        
        ' Bearer認証ヘッダーの設定
        .SetRequestHeader "Authorization", "Bearer " & token
        .SetRequestHeader "Accept", "application/json"
        
        On Error Resume Next
        .Send
        If Err.Number <> 0 Then
            CallJPOProgressAPI = "通信エラー: " & Err.Description
            Exit Function
        End If
        On Error GoTo 0
        
        CallJPOProgressAPI = GetUTF8String(.ResponseBody)
        
        If .Status <> 200 Then
            Debug.Print "API Error: " & .Status
        End If
    End With
    Set httpReq = Nothing
End Function

'---------------------------------------------------------------------------------------
' 共通関数: バイナリデータをUTF-8文字列に変換 (変更なし)
'---------------------------------------------------------------------------------------
Private Function GetUTF8String(ByVal rawBinary As Variant) As String
    Dim adoStream As Object
    Set adoStream = CreateObject("ADODB.Stream")
    With adoStream
        .Type = 1 ' Binary
        .Open
        .Write rawBinary
        .Position = 0
        .Type = 2 ' Text
        .Charset = "UTF-8"
        GetUTF8String = .ReadText
        .Close
    End With
    Set adoStream = Nothing
End Function

'---------------------------------------------------------------------------------------
' 簡易JSON値抽出関数 (変更なし)
'---------------------------------------------------------------------------------------
Private Function ExtractJsonValue(jsonStr As String, key As String) As String
    Dim p1 As Long, p2 As Long
    Dim searchKey As String
    
    searchKey = """" & key & """"
    p1 = InStr(jsonStr, searchKey)
    
    If p1 > 0 Then
        p1 = InStr(p1 + Len(searchKey), jsonStr, """")
        If p1 > 0 Then
            p2 = InStr(p1 + 1, jsonStr, """")
            If p2 > 0 Then
                ExtractJsonValue = Mid(jsonStr, p1 + 1, p2 - p1 - 1)
            End If
        End If
    End If
End Function

'----------------------------------------------------------------------
' 機能: 文字列をURLエンコード (UTF-8)
' 備考: 64bit版 Excel対応 (htmlfileオブジェクトを使用)
'----------------------------------------------------------------------
Private Function encodeUrlUtf8(ByVal strSource As String) As String
    Dim objHtml As Object
    
    ' ScriptControlの代わりに htmlfile を使用
    Set objHtml = CreateObject("htmlfile")
    
    ' htmlfile 内で JScript を実行できる環境を作る
    objHtml.parentWindow.execScript "function encode(s) {return encodeURIComponent(s);}", "JScript"
    
    ' 定義した関数を呼び出す
    encodeUrlUtf8 = objHtml.parentWindow.encode(strSource)
    
    Set objHtml = Nothing
End Function

Private Function GetMicroSecond() As Double
    Dim procTime            As Double       '// 高分解能パフォーマンスカウンタ値（システム起動からの加算値）
    Dim frequency           As Double       '// 高分解能パフォーマンスカウンタの周波数（１秒間に増えるカウントの数）
    Dim ret                 As Double       '// 計測結果
    
    '// 計測時刻を0で初期化
    GetMicroSecond = 0
 
    '// 更新頻度を取得
    Call QueryPerformanceFrequency(frequency)
 
    '// 処理時刻を取得
    Call QueryPerformanceCounter(procTime)
 
    '// カウンタ値を１秒間のカウント増加数で割り、正確な時刻を算出
    GetMicroSecond = procTime / frequency
End Function

OA REJECTION

アクセス時間 0.25秒 程度

Option Explicit

' USPTO APIのエンドポイント
Private Const USPTO_API_URL As String = "https://developer.uspto.gov/ds-api/oa_rejections/v3"

#If Win64 Then
    Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (frequency As Double) As Long
    Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (procTime As Double) As Long
#Else
    Declare Function QueryPerformanceFrequency Lib "kernel32" (frequency As Double) As Long
    Declare Function QueryPerformanceCounter Lib "kernel32" (procTime As Double) As Long
#End If

'---------------------------------------------------------------------------------------
' メイン処理: USPTO APIを呼び出して結果をシートに出力する（文字化け対策済み）
'---------------------------------------------------------------------------------------
Public Sub POST_OA_REJECTION()
    Dim httpReq As Object
    Dim strCriteria As String
    Dim strStart As String
    Dim strRows As String
    Dim strBody As String
    Dim strUrl As String        ' URLを格納する変数
    Dim strResponse As String
    Dim ws As Worksheet
    
    ' --- 1. テスト条件 ---
    strCriteria = Range("B1").Value
    strStart = Range("B2").Value
    strRows = Range("B3").Value
    Range("A4:Z8192").Clear
    
    ' --- 2. リクエストボディ作成 (URLエンコード) ---
    strBody = "criteria=" & URLEncode(strCriteria) & "&start=" & strStart & "&rows=" & strRows
    
    Dim tick_start As Double
    Dim tick_end As Double
    tick_start = GetMicroSecond()
    
    ' --- 3. HTTPリクエスト送信 ---
    Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    With httpReq
        strUrl = USPTO_API_URL & "/records"
        .Open "POST", strUrl, False
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .SetRequestHeader "Accept", "application/json"
      
        ' タイムアウト設定 (左から: Resolve, Connect, Send, Receive) - ミリ秒
        .SetTimeouts 10000, 10000, 10000, 30000
        
        On Error Resume Next
        .Send strBody
        
        tick_end = GetMicroSecond()
        If Err.Number <> 0 Then
            MsgBox "通信エラー: " & Err.Description, vbCritical
            Exit Sub
        End If
        On Error GoTo 0
        
        If .Status = 200 Then
            strResponse = GetUTF8String(.ResponseBody)
        Else
            strResponse = GetUTF8String(.ResponseBody)
        End If
        ' ★★★★★★★★★★★★★★★★★
        
        ' --- 4. 結果出力 ---
        Set ws = ActiveSheet
        Range("A4:Z8192").Clear
        
        ws.Range("A6").Value = "項目"
        ws.Range("B6").Value = "値"
        
        ws.Range("A7").Value = "通信時間"
        ws.Range("B7").Value = tick_end - tick_start
        
        ws.Range("A8").Value = "ステータスコード"
        ws.Range("B8").Value = .Status
        
        ws.Range("A9").Value = "リクエストURL"
        ws.Range("B9").Value = strUrl  ' どのようなURLで送信したか確認用
        
        ws.Range("A10").Value = "レスポンス(デコード済み)"
        ws.Range("B10").Value = Left(strResponse, 32000)
        
        If .Status = 200 Then
            MsgBox "成功！文字化けせずに取得できました。", vbInformation
        Else
            MsgBox "APIエラー: " & .Status, vbCritical
        End If
    End With
    
    Set httpReq = Nothing
End Sub

Public Sub GET_OA_REJECTION()
    Dim httpReq As Object
    Dim strCriteria As String
    Dim strStart As String
    Dim strRows As String
    Dim strUrl As String        ' GET用にURLを格納する変数
    Dim strResponse As String
    Dim ws As Worksheet
    
    ' --- 1. テスト条件 ---
    strCriteria = Range("B1").Value
    strStart = Range("B2").Value
    strRows = Range("B3").Value
    
    ' --- 2. URLの作成 (GETリクエスト用) ---
    strUrl = USPTO_API_URL & "/fields"
    Range("A4:Z8192").Clear
    
    
    Dim tick_start As Double
    Dim tick_end As Double
    tick_start = GetMicroSecond()
    
    ' --- 3. HTTPリクエスト送信 ---
    Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    
    With httpReq
        ' ★変更点: メソッドを "GET" にし、パラメータ付きURLを指定
        .Open "GET", strUrl, False
        .SetRequestHeader "Accept", "application/json"
        
        ' タイムアウト設定 (Resolve, Connect, Send, Receive)
        .SetTimeouts 10000, 10000, 10000, 30000
        
        On Error Resume Next
        ' ★変更点: GETの場合、Sendの引数(Body)は不要です
        .Send
        tick_end = GetMicroSecond()

        
        If Err.Number <> 0 Then
            MsgBox "通信エラー: " & Err.Description, vbCritical
            Exit Sub
        End If
        On Error GoTo 0
        
        ' --- レスポンスの取得と変換 ---
        If .Status = 200 Then
            strResponse = GetUTF8String(.ResponseBody)
        Else
            strResponse = GetUTF8String(.ResponseBody)
        End If
        
        ' --- 4. 結果出力 ---
        Set ws = ActiveSheet
        Range("A4:Z8192").Clear
        
     
        ws.Range("A6").Value = "項目"
        ws.Range("B6").Value = "値"
        
        ws.Range("A7").Value = "通信時間"
        ws.Range("B7").Value = tick_end - tick_start
        
        ws.Range("A8").Value = "ステータスコード"
        ws.Range("B8").Value = .Status
        
        ws.Range("A9").Value = "リクエストURL"
        ws.Range("B9").Value = strUrl  ' どのようなURLで送信したか確認用
        
        ws.Range("A10").Value = "レスポンス(デコード済み)"
        ws.Range("B10").Value = Left(strResponse, 32000)
        
        If .Status = 200 Then
            MsgBox "GETリクエスト成功！" & vbCrLf & "データを取得しました。", vbInformation
        Else
            MsgBox "APIエラー: " & .Status, vbCritical
        End If
    End With
    
    Set httpReq = Nothing
End Sub

'---------------------------------------------------------------------------------------
' 共通関数: URLエンコード
'---------------------------------------------------------------------------------------
Private Function URLEncode(ByVal StringVal As String) As String
    Dim i As Long
    Dim CharCode As Integer
    Dim Char As String
    Dim Result As String
    
    For i = 1 To Len(StringVal)
        Char = Mid$(StringVal, i, 1)
        CharCode = Asc(Char)
        Select Case CharCode
            Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
                Result = Result & Char
            Case 32
                Result = Result & "%20"
            Case Else
                Result = Result & "%" & Right("0" & Hex(CharCode), 2)
        End Select
    Next i
    URLEncode = Result
End Function

'---------------------------------------------------------------------------------------
' 共通関数: バイナリデータをUTF-8文字列に変換 (変更なし)
'---------------------------------------------------------------------------------------
Private Function GetUTF8String(ByVal rawBinary As Variant) As String
    Dim adoStream As Object
    Set adoStream = CreateObject("ADODB.Stream")
    With adoStream
        .Type = 1 ' Binary
        .Open
        .Write rawBinary
        .Position = 0
        .Type = 2 ' Text
        .Charset = "UTF-8"
        GetUTF8String = .ReadText
        .Close
    End With
    Set adoStream = Nothing
End Function

Function GetMicroSecond() As Double
    Dim procTime            As Double       '// 高分解能パフォーマンスカウンタ値（システム起動からの加算値）
    Dim frequency           As Double       '// 高分解能パフォーマンスカウンタの周波数（１秒間に増えるカウントの数）
    Dim ret                 As Double       '// 計測結果
    
    '// 計測時刻を0で初期化
    GetMicroSecond = 0
 
    '// 更新頻度を取得
    Call QueryPerformanceFrequency(frequency)
 
    '// 処理時刻を取得
    Call QueryPerformanceCounter(procTime)
 
    '// カウンタ値を１秒間のカウント増加数で割り、正確な時刻を算出
    GetMicroSecond = procTime / frequency
End Function
0
0
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
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?