frmmain.frm

实现了PC机和外接硬件实验台的通信

    
        lstResults.AddItem "  Structure size: " & DeviceAttributes.Size
        lstResults.AddItem "  Vendor ID: " & Hex$(DeviceAttributes.VendorID)
        lstResults.AddItem "  Product ID: " & Hex$(DeviceAttributes.ProductID)
        lstResults.AddItem "  Version Number: " & Hex$(DeviceAttributes.VersionNumber)
        
        '看看是不是指定的VID、PID
        If (DeviceAttributes.VendorID = MyVendorID) And (DeviceAttributes.ProductID = MyProductID) Then
            lstResults.AddItem "  My device detected "
            lstResults.AddItem "  -------------------------------------------------------------------------------------------"
            lblHID.Caption = "HID Find"
            MyDeviceDetected = True
            cmdGetCaps.Enabled = True
            cmdClose.Enabled = True
            txtVendorID.Enabled = False
            txtProductID.Enabled = False
        Else
            MyDeviceDetected = False
            Result = CloseHandle(HidDevice)
            DisplayResultOfAPICall ("CloseHandle")
        End If
    End If

    MemberIndex = MemberIndex + 1    '准备查找下一个
    
Loop Until (LastDevice = True) Or (MyDeviceDetected = True)
    
End Function

'**************************************************************************************
'获得上一个API函数的执行信息
'**************************************************************************************

Private Function GetErrorString(ByVal LastError As Long) As String

Dim Bytes As Long
Dim ErrorString As String
ErrorString = String$(129, 0)
Bytes = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, LastError, 0, ErrorString$, 128, 0)
    
If Bytes > 2 Then       '去掉其中的回车
    GetErrorString = Left$(ErrorString, Bytes - 2)
End If

End Function

'**************************************************************************************
'清除数据域显示
'**************************************************************************************

Private Sub cmdClear_Click()

txtR1.Text = ""
txtR2.Text = ""
txtYear.Text = ""
txtMonth.Text = ""
txtDay.Text = ""
txtHour.Text = ""
txtMinute.Text = ""
txtSecond.Text = ""
End Sub

'**************************************************************************************
'查找HID
'**************************************************************************************

Private Sub cmdFindHID_Click()
Call FindTheHid
End Sub

'**************************************************************************************
'显示API函数的执行结果
'**************************************************************************************

Private Sub DisplayResultOfAPICall(FunctionName As String)

Dim ErrorString As String
lstResults.AddItem ""
ErrorString = GetErrorString(Err.LastDllError)
lstResults.AddItem FunctionName
lstResults.AddItem "  Result = " & ErrorString
End Sub

'**************************************************************************************
'程序初始化
'**************************************************************************************

Private Sub Form_Load()
frmMain.Show
tmrDelay.Enabled = False
lstResults.Clear
MyVendorID = &H930A
MyProductID = &H100
End Sub

'**************************************************************************************
'获得HID的能力信息
'**************************************************************************************

Private Sub cmdGetCaps_click()

Dim ppData(29) As Byte
Dim ppDataString As Variant

'调用 HidD_GetPreparsedData 获得一个缓冲区指针

Result = HidD_GetPreparsedData(HidDevice, PreparsedData)
Call DisplayResultOfAPICall("HidD_GetPreparsedData")

Result = RtlMoveMemory(ppData(0), PreparsedData, 30)
Call DisplayResultOfAPICall("RtlMoveMemory")

ppDataString = ppData()
ppDataString = StrConv(ppDataString, vbUnicode)

'调用 HidP_GetCaps 获得HID_CAPS 结构数据

Result = HidP_GetCaps(PreparsedData, Capabilities)

Call DisplayResultOfAPICall("HidP_GetCaps")
lstResults.AddItem "  Last error: " & ErrorString
lstResults.AddItem "  Usage: " & Hex$(Capabilities.Usage)
lstResults.AddItem "  Usage Page: " & Hex$(Capabilities.UsagePage)
lstResults.AddItem "  Input Report Byte Length: " & Capabilities.InputReportByteLength
lstResults.AddItem "  Output Report Byte Length: " & Capabilities.OutputReportByteLength
lstResults.AddItem "  Feature Report Byte Length: " & Capabilities.FeatureReportByteLength
lstResults.AddItem "  Number of Link Collection Nodes: " & Capabilities.NumberLinkCollectionNodes
lstResults.AddItem "  Number of Input Button Caps: " & Capabilities.NumberInputButtonCaps
lstResults.AddItem "  Number of Input Value Caps: " & Capabilities.NumberInputValueCaps
lstResults.AddItem "  Number of Input Data Indices: " & Capabilities.NumberInputDataIndices
lstResults.AddItem "  Number of Output Button Caps: " & Capabilities.NumberOutputButtonCaps
lstResults.AddItem "  Number of Output Value Caps: " & Capabilities.NumberOutputValueCaps
lstResults.AddItem "  Number of Output Data Indices: " & Capabilities.NumberOutputDataIndices
lstResults.AddItem "  Number of Feature Button Caps: " & Capabilities.NumberFeatureButtonCaps
lstResults.AddItem "  Number of Feature Value Caps: " & Capabilities.NumberFeatureValueCaps
lstResults.AddItem "  Number of Feature Data Indices: " & Capabilities.NumberFeatureDataIndices

'调用 HidP_GetValueCaps 获得HID能力的数值

Dim ValueCaps(1023) As Byte

Result = HidP_GetValueCaps(HidP_Input, ValueCaps(0), Capabilities.NumberInputValueCaps, PreparsedData)
  
Call DisplayResultOfAPICall("HidP_GetValueCaps")
lstResults.AddItem "  -------------------------------------------------------------------------------------------"
lblCaps.Caption = "Get Caps Ok"

cmdTrans.Enabled = True
cmdReceive.Enabled = True
End Sub

'**************************************************************************************
'输出报表到HID
'**************************************************************************************

Private Sub cmdTrans_Click()


Dim Count As Integer
Dim NumberOfBytesToSend As Long
Dim NumberOfBytesWritten As Long
Dim SendBuffer() As Byte
ReDim SendBuffer(Capabilities.OutputReportByteLength - 1)

'填写报表数据到数组SendBuffer
Count = 0
SendBuffer(Count) = 0       '第一個位元組是Report ID
Count = Count + 1
SendBuffer(Count) = &H55
Count = Count + 1
SendBuffer(Count) = &HAA
Count = Count + 1
SendBuffer(Count) = &H1
Count = Count + 1
SendBuffer(Count) = &H8
Count = Count + 1
SendBuffer(Count) = Val("&H" + txtR1.Text)
Count = Count + 1
SendBuffer(Count) = Val("&H" + txtR2.Text)
Count = Count + 1
SendBuffer(Count) = Val(txtYear.Text)
Count = Count + 1
SendBuffer(Count) = Val(txtMonth.Text)
Count = Count + 1
SendBuffer(Count) = Val(txtDay.Text)
Count = Count + 1
SendBuffer(Count) = Val(txtHour.Text)
Count = Count + 1
SendBuffer(Count) = Val(txtMinute.Text)
Count = Count + 1
SendBuffer(Count) = Val(txtSecond.Text)
Count = Count + 1

'调用 WriteFile 函数,发送报表

NumberOfBytesWritten = 0
Result = WriteFile(HidDevice, SendBuffer(0), CLng(Capabilities.OutputReportByteLength), NumberOfBytesWritten, 0)

Call DisplayResultOfAPICall("WriteFile")
lstResults.AddItem "  Output Report" + Str(NumberOfBytesWritten) + " bytes"
End Sub

'**************************************************************************************
'从HID读取报表
'注意：以下代码为非重叠调用，必须保证HID输出报表
'**************************************************************************************

Private Sub cmdReceive_click()

Dim Count
Dim NumberOfBytesRead As Long
Dim ReadBuffer() As Byte
ReDim ReadBuffer(Capabilities.InputReportByteLength - 1)
    
'调用 ReadFile 函数，读取报表
Result = ReadFile(HidDevice, ReadBuffer(0), CLng(Capabilities.InputReportByteLength), NumberOfBytesRead, 0)

Call DisplayResultOfAPICall("ReadFile")
lstResults.AddItem "  Input Report" + Str(NumberOfBytesRead) + " bytes"

'将输入报表的数据填写到显示介面的相应数据域
txtR1.Text = Hex$(ReadBuffer(5))
txtR2.Text = Hex$(ReadBuffer(6))
txtYear.Text = IIf(ReadBuffer(7) < 10, "0" + Trim(Str$(ReadBuffer(7))), Trim(Str$(ReadBuffer(7))))
txtMonth.Text = IIf(ReadBuffer(8) < 10, "0" + Trim(Str$(ReadBuffer(8))), Trim(Str$(ReadBuffer(8))))
txtDay.Text = IIf(ReadBuffer(9) < 10, "0" + Trim(Str$(ReadBuffer(9))), Trim(Str$(ReadBuffer(9))))
txtHour.Text = IIf(ReadBuffer(10) < 10, "0" + Trim(Str$(ReadBuffer(10))), Trim(Str$(ReadBuffer(10))))
txtMinute.Text = IIf(ReadBuffer(11) < 10, "0" + Trim(Str$(ReadBuffer(11))), Trim(Str$(ReadBuffer(11))))
txtSecond.Text = IIf(ReadBuffer(12) < 10, "0" + Trim(Str$(ReadBuffer(12))), Trim(Str$(ReadBuffer(12))))
End Sub

'**************************************************************************************
'关闭设备，释放资源
'**************************************************************************************

Private Sub cmdClose_Click()


'调用 CloseHandle 关闭HID

Result = CloseHandle(HidDevice)
Call DisplayResultOfAPICall("CloseHandle (HidDevice)")

'调用 SetupDiDestroyDeviceInfoList和HidD_FreePreparsedData 释放占用的资源

Result = SetupDiDestroyDeviceInfoList(DeviceInfoSet)
Call DisplayResultOfAPICall("DestroyDeviceInfoList")
Result = HidD_FreePreparsedData(PreparsedData)
Call DisplayResultOfAPICall("HidD_FreePreparsedData")

lstResults.Clear
cmdClose.Enabled = False
cmdGetCaps.Enabled = False
cmdTrans.Enabled = False
cmdReceive.Enabled = False
lblHID.Caption = ""
lblCaps.Caption = ""
txtVendorID.Enabled = True
txtProductID.Enabled = True
End Sub

'**************************************************************************************
'将当前日期和时间填写到界面的数据域
'**************************************************************************************

Private Sub cmdNow_Click()

txtHour.Text = IIf(Hour(Now()) < 10, "0" + Hour(Now()), Hour(Now()))
txtMinute.Text = IIf(Minute(Now()) < 10, "0" + Trim(Str(Minute(Now()))), Minute(Now()))
txtSecond.Text = IIf(Second(Now()) < 10, "0" + Trim(Str(Second(Now()))), Second(Now()))
txtYear.Text = IIf((Year(Now()) - 2000) < 10, "0" + Trim(Str(Year(Now()) - 2000)), Str(Year(Now()) - 2000))
txtMonth.Text = IIf(Month(Now()) < 10, "0" + Trim(Str(Month(Now()))), Str(Month(Now())))
txtDay.Text = IIf(Day(Now()) < 10, "0" + Trim(Str(Day(Now()))), Day(Now()))
End Sub

'**************************************************************************************
'获得信息字符串
'**************************************************************************************

Private Function GetDataString(Address As Long, Bytes As Long) As String

Dim Offset As Integer
Dim Result$
Dim ThisByte As Byte

For Offset = 0 To Bytes - 1
    Call RtlMoveMemory(ByVal VarPtr(ThisByte), ByVal Address + Offset, 1)
    If (ThisByte And &HF0) = 0 Then
        Result$ = Result$ & "0"
    End If
    Result$ = Result$ & Hex$(ThisByte) & " "
Next Offset

GetDataString = Result$
End Function