【EXCEL】USB赤外線リモコンの送出 その２

やること

　前回(【EXCEL】USB赤外線リモコンの送出 #Excel - Qiita)、送出するための信号は、「赤外線送信アプリ(ADIR01P_Trns_CT_v12)」で学習したものを利用した。
　今回、EXCELで対応する。

USBIR_Remote_Controller_Advance_Library

前回同様、ドキュメント、DLLは以下より入手。
GitHub - bit-trade-one/ADIR01P-USB_IR_Remote_Controller_Advance

　自分の場合は、USB_IR_Library_x64_v6.0.0.0.zipを使用し、「USB_IR_Library.dll」を C:\ に置いた。

USB_IR_RCAL_x64_64bit

Option Explicit
'GitHub -bit - trade - one / ADIR01P - USB_IR_Remote_Controller_Advance
'https://github.com/bit-trade-one/ADIR01P-USB_IR_Remote_Controller_Advance
'
' DLLﾌｧｲﾙの関数定義:USB_IR_Library_x64_v6.0.0.0.zip
' 「USB_IR_Remote_Controller_Advance_Library x64 64bit 版 取扱説明書 2022/11/21 x64 版 R01」より
' 以下の事例では、USB_IR_Library.dll は C:\ に置いている
' ("USB_IR_Library.dll"として、C:\Windows\System や C:\Windows\System32 に置いても良い)
Declare PtrSafe Function openUSBIR Lib "C:\USB_IR_Library.dll" (ByVal hRecipient As LongLong _
) As LongLong       ' USB IR Remote Controller Advance と接続をします。
Declare PtrSafe Function closeUSBIR Lib "C:\USB_IR_Library.dll" (ByVal HandleToUSBDevice As LongLong _
) As Integer        ' USB IR Remote Controller Advance との接続を切断します。
Declare PtrSafe Function writeUSBIRData2 Lib "C:\USB_IR_Library.dll" ( _
    ByVal HandleToUSBDevice As LongLong, _
    ByVal freq As Long, _
    ByRef data As Byte, _
    ByVal bit_len As Long _
) As Integer        ' USB IR Remote Controller Advance から赤外線コードを送信します。
Declare PtrSafe Function recUSBIRData_Start Lib "C:\USB_IR_Library.dll" ( _
    ByVal HandleToUSBDevice As LongLong, _
    ByVal freq As Long _
) As Integer    ' USB IR Remote Controller Advance に赤外線コードの記録を開始します。
Declare PtrSafe Function recUSBIRData_Stop Lib "C:\USB_IR_Library.dll" ( _
    ByVal HandleToUSBDevice As LongLong _
) As Integer    ' USB IR Remote Controller Advance に赤外線コードの記録を停止します。
Declare PtrSafe Function readUSBIRData Lib "C:\USB_IR_Library.dll" ( _
    ByVal HandleToUSBDevice As LongLong, _
    ByRef data As LongPtr, _
    ByRef data_len As Long, _
    ByRef bit_len As Long _
) As Integer    ' USB IR Remote Controller Advance から記録した赤外線コードを取得します
' Windows API
Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String _
) As LongPtr
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    Destination As Any, _
    Source As Any, _
    ByVal Length As LongPtr _
)

' グローバル変数でハンドルを保持
Dim gHandleToUSBDevice As LongLong


Sub CallOpenUSBIR()
    Dim hRecipient As LongLong
    hRecipient = FindWindow("XLMAIN", vbNullString)
    gHandleToUSBDevice = openUSBIR(hRecipient)
    If gHandleToUSBDevice <> 0 Then
'        MsgBox "openUSBIR関数が成功しました。ハンドル: " & gHandleToUSBDevice, vbInformation
    Else
        MsgBox "openUSBIR関数の呼び出しに失敗しました。", vbCritical
    End If
End Sub


Sub CallCloseUSBIR()
    Dim closeResult As Integer
    If gHandleToUSBDevice = 0 Then
        MsgBox "openUSBIR関数をcloseUSBIR関数より先に実行してください。", vbCritical
        Exit Sub
    End If
    closeResult = closeUSBIR(gHandleToUSBDevice)
    If closeResult = 0 Then
'        MsgBox "closeUSBIR関数が正常に実行されました。", vbInformation
        gHandleToUSBDevice = 0
    Else
        MsgBox "closeUSBIR関数の実行中にエラーが発生しました。エラーコード: " & closeResult, vbCritical
    End If
End Sub


Sub CallWriteUSBIRData2()
    Dim i As Single
    Dim j As Single
    j = 2                           ' ADIR01P_Trns_CT_v12のNo.1 (1行目)
    Dim freq As Long
    freq = Cells(j, 2)              ' ADIR01P_Trns_CT_v12の値を使用
'    freq = 38000                   ' 一般的なリモコンの周波数は、38kHz
    Dim irData(0 To 9599) As Byte
    For i = 1 To Cells(j, 3)
        irData(i * 2 - 2) = CStr(Val("&H" & Mid(Cells(j, i + 3), 3, 2)))
        irData(i * 2 - 1) = CStr(Val("&H" & Mid(Cells(j, i + 3), 5, 2)))
    Next i
    Dim bit_len As Long
    bit_len = Cells(j, 3) * 2
    Dim result As Integer
    Debug.Print "ハンドル: " & gHandleToUSBDevice
    Debug.Print "周波数: " & freq
    Debug.Print "データ長: " & bit_len
    For i = LBound(irData) To bit_len
        Debug.Print "irData(" & i & ") = " & irData(i)
    Next i
    result = writeUSBIRData2(gHandleToUSBDevice, freq, irData(0), bit_len)
    If result = 0 Then
'        MsgBox "writeUSBIRData2関数が正常に実行されました。" & Cells(j, 1), vbInformation
    Else
        MsgBox "writeUSBIRData2関数の実行中にエラーが発生しました。エラーコード: " & result, vbCritical
    End If
End Sub

Sub CallReadUSBIRData()
    Dim i As Single
    Dim j As Single
    j = 2                           ' ADIR01P_Trns_CT_v12のNo.2 (2行目)
    Dim freq As Long
    freq = 38000                    ' 一般的なリモコンの周波数は、38kHz
    Cells(j, 2) = freq
    Dim result As Integer
    result = recUSBIRData_Start(gHandleToUSBDevice, freq)
    If result <> 0 Then
        MsgBox "赤外線コード記録開始に失敗しました。エラーコード: " & result, vbCritical
        GoTo Cleanup
    End If
    MsgBox "リモコンのボタンを押してください。記録を停止するにはOKを押します。", vbInformation
    result = recUSBIRData_Stop(gHandleToUSBDevice)
    If result <> 0 Then
        MsgBox "赤外線コード記録停止に失敗しました。", vbCritical
        GoTo Cleanup
    End If
    Dim dataPtr As LongPtr
    Dim dataLen As Long
    Dim bitLen As Long
    result = readUSBIRData(gHandleToUSBDevice, dataPtr, dataLen, bitLen)
    If result <> 0 Or dataLen = 0 Then
        MsgBox "赤外線コードの取得に失敗しました。エラーコード: " & result & "dataLen:" & dataLen, vbCritical
        GoTo Cleanup
    End If
    Dim byteArray() As Byte
    ReDim byteArray(dataLen - 1)
    CopyMemory byteArray(0), ByVal dataPtr, dataLen
    MsgBox "赤外線コードの取得に成功しました。ビット長: " & bitLen, vbInformation
    Cells(j, 3) = bitLen
    For i = 1 To Cells(j, 3) * 2
        Cells(j, i + 3) = "0x" & WorksheetFunction.Dec2Hex(byteArray(i * 2 - 2), 2) & WorksheetFunction.Dec2Hex(byteArray(i * 2 - 1), 2)
    Next i

Cleanup:
End Sub



Sub Main_SendIR()
    Call CallOpenUSBIR
    Call CallWriteUSBIRData2
    Call CallCloseUSBIR
End Sub

Sub Main_RecIR()
    Call CallOpenUSBIR
    Call CallReadUSBIRData
    Call CallCloseUSBIR
End Sub

Main_RecIRを使用すると、2行目に「赤外線送信アプリ(ADIR01P_Trns_CT_v12)」と同様のフォーマットでデータが記録される。