Here is where the program transfers the data
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'Project: usbhidio.vbp
'Version: 1.1
'Date: 11/20/99
'Copyright 1999 by Jan Axelson (jan@lvr.com)
'
'Purpose: demonstrates USB communications with an HID-class device
'Description:
'Finds an attached device that matches specific vendor and product IDs.
'Retrieves the device's capabilities.
'Sends two bytes to the device using Input reports.
'Receives two bytes from the device in Output reports.
'(The current device firmware adds 1 to the received bytes and sends them back.)
'A list box displays the data sent and received,
'along with error and status messages.
'Combo boxes enable you to select data to send, and to select 1-time or
'continuous transfers.
'The companion device firmware is usbhidio.asm,
'for Cypress Semiconductor's CY7C63001 USB Microcontroller.
'For more information, visit Lakeview Research at http://www.lvr.com .
'Send comments, bug reports, etc. to jan@lvr.com .
'Changes and updates:
'11/20/99. Revised a few of the comments.
'v1.1 added Else statement in InitializeDisplay routine
'so both combo boxes have all of the values.
Dim Capabilities As HIDP_CAPS
Dim DataString As String
Dim DetailData As Long
Dim DetailDataBuffer() As Byte
Dim DeviceAttributes As HIDD_ATTRIBUTES
Dim DevicePathName As String
Dim DeviceInfoSet As Long
Dim ErrorString As String
Dim HidDevice As Long
Dim LastDevice As Boolean
Dim MyDeviceDetected As Boolean
Dim MyDeviceInfoData As SP_DEVINFO_DATA
Dim MyDeviceInterfaceDetailData As SP_DEVICE_INTERFACE_DETAIL_DATA
Dim MyDeviceInterfaceData As SP_DEVICE_INTERFACE_DATA
Dim Needed As Long
Dim OutputReportData(7) As Byte
Dim PreparsedData As Long
Dim Result As Long
Dim Timeout As Boolean
Dim DB_0 As Long
Dim DB_1 As Long
Dim DB_2 As Long
Dim DB_3 As Long
Dim DB As Long
Dim Port As Long
Dim DB_T0 As Long
Dim DB_T1 As Long
'Set these to match the values in the device's firmware and INF file.
Const MyVendorID = &H925
Const MyProductID = &H1234
Function FindTheHid() As Boolean
'Makes a series of API calls to locate the desired HID-class device.
'Returns True if the device is detected, False if not detected.
Dim Count As Integer
Dim GUIDString As String
Dim HidGuid As GUID
Dim MemberIndex As Long
LastDevice = False
MyDeviceDetected = False
'******************************************************************************
'HidD_GetHidGuid
'Get the GUID for all system HIDs.
'Returns: the GUID in HidGuid.
'The routine doesn't return a value in Result
'but the routine is declared as a function for consistency with the other API calls.
'******************************************************************************
Result = HidD_GetHidGuid(HidGuid)
Call DisplayResultOfAPICall("GetHidGuid")
'Display the GUID.
GUIDString = _
Hex$(HidGuid.Data1) & "-" & _
Hex$(HidGuid.Data2) & "-" & _
Hex$(HidGuid.Data3) & "-"
For Count = 0 To 7
'Ensure that each of the 8 bytes in the GUID displays two characters.
If HidGuid.Data4(Count) >= &H10 Then
GUIDString = GUIDString & Hex$(HidGuid.Data4(Count)) & " "
Else
GUIDString = GUIDString & "0" & Hex$(HidGuid.Data4(Count)) & " "
End If
Next Count
lstResults.AddItem " GUID for system HIDs: " & GUIDString
'******************************************************************************
'SetupDiGetClassDevs
'Returns: a handle to a device information set for all installed devices.
'Requires: the HidGuid returned in GetHidGuid.
'******************************************************************************
DeviceInfoSet = SetupDiGetClassDevs _
(HidGuid, _
vbNullString, _
0, _
(DIGCF_PRESENT Or DIGCF_DEVICEINTERFACE))
Call DisplayResultOfAPICall("SetupDiClassDevs")
DataString = GetDataString(DeviceInfoSet, 32)
'******************************************************************************
'SetupDiEnumDeviceInterfaces
'On return, MyDeviceInterfaceData contains the handle to a
'SP_DEVICE_INTERFACE_DATA structure for a detected device.
'Requires:
'the DeviceInfoSet returned in SetupDiGetClassDevs.
'the HidGuid returned in GetHidGuid.
'An index to specify a device.
'******************************************************************************
'Begin with 0 and increment until no more devices are detected.
MemberIndex = 0
Do
'The cbSize element of the MyDeviceInterfaceData structure must be set to
'the structure's size in bytes. The size is 28 bytes.
MyDeviceInterfaceData.cbSize = LenB(MyDeviceInterfaceData)
Result = SetupDiEnumDeviceInterfaces _
(DeviceInfoSet, _
0, _
HidGuid, _
MemberIndex, _
MyDeviceInterfaceData)
Call DisplayResultOfAPICall("SetupDiEnumDeviceInterfaces")
If Result = 0 Then LastDevice = True
'If a device exists, display the information returned.
If Result <> 0 Then
lstResults.AddItem " DeviceInfoSet for device #" & CStr(MemberIndex) & ": "
lstResults.AddItem " cbSize = " & CStr(MyDeviceInterfaceData.cbSize)
lstResults.AddItem _
" InterfaceClassGuid.Data1 = " & Hex$(MyDeviceInterfaceData.InterfaceClassGuid.Data1)
lstResults.AddItem _
" InterfaceClassGuid.Data2 = " & Hex$(MyDeviceInterfaceData.InterfaceClassGuid.Data2)
lstResults.AddItem _
" InterfaceClassGuid.Data3 = " & Hex$(MyDeviceInterfaceData.InterfaceClassGuid.Data3)
lstResults.AddItem _
" Flags = " & Hex$(MyDeviceInterfaceData.Flags)
'******************************************************************************
'SetupDiGetDeviceInterfaceDetail
'Returns: an SP_DEVICE_INTERFACE_DETAIL_DATA structure
'containing information about a device.
'To retrieve the information, call this function twice.
'The first time returns the size of the structure in Needed.
'The second time returns a pointer to the data in DeviceInfoSet.
'Requires:
'A DeviceInfoSet returned by SetupDiGetClassDevs and
'an SP_DEVICE_INTERFACE_DATA structure returned by SetupDiEnumDeviceInterfaces.
'*******************************************************************************
MyDeviceInfoData.cbSize = Len(MyDeviceInfoData)
Result = SetupDiGetDeviceInterfaceDetail _
(DeviceInfoSet, _
MyDeviceInterfaceData, _
0, _
0, _
Needed, _
0)
DetailData = Needed
Call DisplayResultOfAPICall("SetupDiGetDeviceInterfaceDetail")
lstResults.AddItem " (OK to say too small)"
lstResults.AddItem " Required buffer size for the data: " & Needed
'Store the structure's size.
MyDeviceInterfaceDetailData.cbSize = _
Len(MyDeviceInterfaceDetailData)
'Use a byte array to allocate memory for
'the MyDeviceInterfaceDetailData structure
ReDim DetailDataBuffer(Needed)
'Store cbSize in the first four bytes of the array.
Call RtlMoveMemory _
(DetailDataBuffer(0), _
MyDeviceInterfaceDetailData, _
4)
'Call SetupDiGetDeviceInterfaceDetail again.
'This time, pass the address of the first element of DetailDataBuffer
'and the returned required buffer size in DetailData.
Result = SetupDiGetDeviceInterfaceDetail _
(DeviceInfoSet, _
MyDeviceInterfaceData, _
VarPtr(DetailDataBuffer(0)), _
DetailData, _
Needed, _
0)
Call DisplayResultOfAPICall(" Result of second call: ")
lstResults.AddItem " MyDeviceInterfaceDetailData.cbSize: " & _
CStr(MyDeviceInterfaceDetailData.cbSize)
'Convert the byte array to a string.
DevicePathName = CStr(DetailDataBuffer())
'Convert to Unicode.
DevicePathName = StrConv(DevicePathName, vbUnicode)
'Strip cbSize (4 bytes) from the beginning.
DevicePathName = Right$(DevicePathName, Len(DevicePathName) - 4)
lstResults.AddItem " Device pathname: " & DevicePathName
'******************************************************************************
'CreateFile
'Returns: a handle that enables reading and writing to the device.
'Requires:
'The DevicePathName returned by SetupDiGetDeviceInterfaceDetail.
'******************************************************************************
HidDevice = CreateFile _
(DevicePathName, _
GENERIC_READ Or GENERIC_WRITE, _
(FILE_SHARE_READ Or FILE_SHARE_WRITE), _
0, _
OPEN_EXISTING, _
0, _
0)
Call DisplayResultOfAPICall("CreateFile")
lstResults.AddItem " Returned handle: " & Hex$(HidDevice) & "h"
'Now we can find out if it's the device we're looking for.
'******************************************************************************
'HidD_GetAttributes
'Requests information from the device.
'Requires: The handle returned by CreateFile.
'Returns: an HIDD_ATTRIBUTES structure containing
'the Vendor ID, Product ID, and Product Version Number.
'Use this information to determine if the detected device
'is the one we're looking for.
'******************************************************************************
'Set the Size property to the number of bytes in the structure.
DeviceAttributes.Size = LenB(DeviceAttributes)
Result = HidD_GetAttributes _
(HidDevice, _
DeviceAttributes)
Call DisplayResultOfAPICall("HidD_GetAttributes")
If Result <> 0 Then
lstResults.AddItem " HIDD_ATTRIBUTES structure filled without error."
Else
lstResults.AddItem " Error in filling HIDD_ATTRIBUTES structure."
End If
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)
'Find out if the device matches the one we're looking for.
If (DeviceAttributes.VendorID = MyVendorID) And _
(DeviceAttributes.ProductID = MyProductID) Then
lstResults.AddItem " My device detected"
MyDeviceDetected = True
Else
MyDeviceDetected = False
'If it's not the one we want, close its handle.
Result = CloseHandle _
(HidDevice)
DisplayResultOfAPICall ("CloseHandle")
End If
End If
'Keep looking until we find the device or there are no more left to examine.
MemberIndex = MemberIndex + 1
Loop Until (LastDevice = True) Or (MyDeviceDetected = True)
If MyDeviceDetected = True Then
FindTheHid = True
Else
lstResults.AddItem " Device not found."
End If
End Function
Private Function GetDataString _
(Address As Long, _
Bytes As Long) _
As String
'Retrieves a string of length Bytes from memory, beginning at Address.
'Adapted from Dan Appleman's "Win32 API Puzzle Book"
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
Private Function GetErrorString _
(ByVal LastError As Long) _
As String
'Returns the error message for the last error.
'Adapted from Dan Appleman's "Win32 API Puzzle Book"
Dim Bytes As Long
Dim ErrorString As String
ErrorString = String$(129, 0)
Bytes = FormatMessage _
(FORMAT_MESSAGE_FROM_SYSTEM, _
0&, _
LastError, _
0, _
ErrorString$, _
128, _
0)
'Subtract two characters from the message to strip the CR and LF.
If Bytes > 2 Then
GetErrorString = Left$(ErrorString, Bytes - 2)
End If
End Function
Private Sub cmdContinuous_Click()
'Enables the user to select 1-time or continuous data transfers.
If cmdContinuous.Caption = "Continuous" Then
'Change the command button to Cancel Continuous
cmdContinuous.Caption = "Cancel Continuous"
'Enable the timer to read and write to the device once/second.
tmrContinuousDataCollect.Enabled = True
Call ReadAndWriteToDevice
Else
'Change the command button to Continuous
cmdContinuous.Caption = "Continuous"
'Disable the timer that reads and writes to the device once/second.
tmrContinuousDataCollect.Enabled = False
End If
End Sub
Private Sub cmdOnce_Click()
Call ReadAndWriteToDevice
End Sub
Private Sub DisplayResultOfAPICall(FunctionName As String)
'Display the results of an API call.
Dim ErrorString As String
lstResults.AddItem ""
ErrorString = GetErrorString(Err.LastDllError)
lstResults.AddItem FunctionName
lstResults.AddItem " Result = " & ErrorString
'Scroll to the bottom of the list box.
lstResults.ListIndex = lstResults.ListCount - 1
End Sub
Private Sub Set_Port0_status(A)
If ((A And 1) > 0) Then
Text_0.Text = "1"
Else
Text_0.Text = "0"
End If
If ((A And 2) > 0) Then
Text_1.Text = "1"
Else
Text_1.Text = "0"
End If
If ((A And 4) > 0) Then
Text_2.Text = "1"
Else
Text_2.Text = "0"
End If
If ((A And 8) > 0) Then
Text_3.Text = "1"
Else
Text_3.Text = "0"
End If
If ((A And 16) > 0) Then
Text_4.Text = "1"
Else
Text_4.Text = "0"
End If
If ((A And 32) > 0) Then
Text_5.Text = "1"
Else
Text_5.Text = "0"
End If
If ((A And 64) > 0) Then
Text_6.Text = "1"
Else
Text_6.Text = "0"
End If
If ((A And 128) > 0) Then
Text_7.Text = "1"
Else
Text_7.Text = "0"
End If
End Sub
Private Sub Set_Port1_status(A)
If ((A And 1) > 0) Then
Text_10.Text = "1"
Else
Text_10.Text = "0"
End If
If ((A And 2) > 0) Then
Text_11.Text = "1"
Else
Text_11.Text = "0"
End If
If ((A And 4) > 0) Then
Text_12.Text = "1"
Else
Text_12.Text = "0"
End If
If ((A And 8) > 0) Then
Text_13.Text = "1"
Else
Text_13.Text = "0"
End If
End Sub
Private Sub Command1_Click(Index As Integer)
Dim A As Byte
Dim B As Byte
A = ReadCommand(2)
Set_Port0_status (A)
Zeitabstand.Text = Hex$(A)
Timeout = False
tmrDelay.Interval = 100
tmrDelay.Enabled = True
Do
DoEvents
Loop Until Timeout = True
B = ReadCommand(3)
Zeitabstand2.Text = Hex$(B)
Set_Port1_status (B)
End Sub
Private Sub Command10_Click()
Port = 7
Call Portselect
Call Command14_Click
Call Command15_Click
End Sub
Private Sub Command11_Click()
Dim DeviceDetected As Boolean
'Report Header
lstResults.AddItem "HID Test Report"
lstResults.AddItem Format(Now, "general date")
OutputReportData(0) = &HA
OutputReportData(1) = &H0
'Find the device
DeviceDetected = FindTheHid
If DeviceDetected = True Then
'Learn the capabilities of the device
Call GetDeviceCapabilities
'Write a report to the device
Call WriteReport
'The firmware adds 1 to each received byte and sends the bytes back
'to the host.
'Add a delay to allow the host time to poll for the returned data.
Timeout = False
tmrDelay.Interval = 100
tmrDelay.Enabled = True
Do
DoEvents
Loop Until Timeout = True
'Read a report from the device.
Call ReadReport
Else
End If
'Scroll to the bottom of the list box.
lstResults.ListIndex = lstResults.ListCount - 1
End Sub
Private Sub Command12_Click()
'Writes 14h to the Device
Dim DeviceDetected As Boolean
'Report Header
lstResults.AddItem "HID Test Report"
lstResults.AddItem Format(Now, "general date")
OutputReportData(0) = &H14
OutputReportData(1) = &H0
'Find the device
DeviceDetected = FindTheHid
If DeviceDetected = True Then
'Learn the capabilities of the device
Call GetDeviceCapabilities
'Write a report to the device
Call WriteReport
'The firmware adds 1 to each received byte and sends the bytes back
'to the host.
'Add a delay to allow the host time to poll for the returned data.
Timeout = False
tmrDelay.Interval = 100
tmrDelay.Enabled = True
Do
DoEvents
Loop Until Timeout = True
'Read a report from the device.
Call ReadReport
Else
End If
'Scroll to the bottom of the list box.
lstResults.ListIndex = lstResults.ListCount - 1
End Sub
Private Sub Command13_Click()
'Writes 15h to the Device
Dim DeviceDetected As Boolean
'Report Header
lstResults.AddItem "HID Test Report"
lstResults.AddItem Format(Now, "general date")
OutputReportData(0) = &H15
OutputReportData(1) = &H0
'Find the device
DeviceDetected = FindTheHid
If DeviceDetected = True Then
'Learn the capabilities of the device
Call GetDeviceCapabilities
'Write a report to the device
Call WriteReport
'The firmware adds 1 to each received byte and sends the bytes back
'to the host.
'Add a delay to allow the host time to poll for the returned data.
Timeout = False
tmrDelay.Interval = 100
tmrDelay.Enabled = True
Do
DoEvents
Loop Until Timeout = True
'Read a report from the device.
Call ReadReport
'Save read values to variables
Else
End If
'Scroll to the bottom of the list box.
lstResults.ListIndex = lstResults.ListCount - 1
End Sub
Private Sub Command14_Click()
Call Command12_Click
DB_0 = DB_T0
DB_1 = DB_T1
Call Command13_Click
DB_2 = DB_T0
DB_3 = DB_T1
Spannung.Text = " "
Spannung.SelText = Hex$(DB_0)
Spannung.SelText = Hex$(DB_1)
Spannung.SelText = Hex$(DB_2)
Spannung.SelText = Hex$(DB_3)
End Sub
Private Sub Command15_Click()
Call Command12_Click
DB_0 = DB_T0
DB_1 = DB_T1
Call Command13_Click
DB_2 = DB_T0
DB_3 = DB_T1
Call Addbytes
DECVolt.Text = " "
DECVolt.SelText = DB
End Sub
Private Sub Command3_Click()
Port = 0
Call Portselect
Call Command14_Click
Call Command15_Click
End Sub
Private Sub Command4_Click()
Port = 1
Call Portselect
Call Command14_Click
Call Command15_Click
End Sub
Private Sub Command5_Click()
Port = 2
Call Portselect
Call Command14_Click
Call Command15_Click
End Sub
Private Sub Command6_Click()
Port = 3
Call Portselect
Call Command14_Click
Call Command15_Click
End Sub
Private Sub Command7_Click()
Port = 4
Call Portselect
Call Command14_Click
Call Command15_Click
End Sub
Private Sub Command8_Click()
Port = 5
Call Portselect
Call Command14_Click
Call Command15_Click
End Sub
Private Sub Command9_Click()
Port = 6
Call Portselect
Call Command14_Click
Call Command15_Click
End Sub
Private Sub Form_Load()
frmMain.Show
tmrDelay.Enabled = False
Call Startup
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call Shutdown
End Sub
Private Sub GetDeviceCapabilities()
'******************************************************************************
'HidD_GetPreparsedData
'Returns: a pointer to a buffer containing information about the device's capabilities.
'Requires: A handle returned by CreateFile.
'There's no need to access the buffer directly,
'but HidP_GetCaps and other API functions require a pointer to the buffer.
'******************************************************************************
Dim ppData(29) As Byte
Dim ppDataString As Variant
'Preparsed Data is a pointer to a routine-allocated buffer.
Result = HidD_GetPreparsedData _
(HidDevice, _
PreparsedData)
Call DisplayResultOfAPICall("HidD_GetPreparsedData")
'Copy the data at PreparsedData into a byte array.
Result = RtlMoveMemory _
(ppData(0), _
PreparsedData, _
30)
Call DisplayResultOfAPICall("RtlMoveMemory")
ppDataString = ppData()
'Convert the data to Unicode.
ppDataString = StrConv(ppDataString, vbUnicode)
'******************************************************************************
'HidP_GetCaps
'Find out the device's capabilities.
'For standard devices such as joysticks, you can find out the specific
'capabilities of the device.
'For a custom device, the software will probably know what the device is capable of,
'so this call only verifies the information.
'Requires: The pointer to a buffer containing the information.
'The pointer is returned by HidD_GetPreparsedData.
'Returns: a Capabilites structure containing the information.
'******************************************************************************
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
'Returns a buffer containing an array of HidP_ValueCaps structures.
'Each structure defines the capabilities of one value.
'This application doesn't use this data.
'******************************************************************************
'This is a guess. The byte array holds the structures.
Dim ValueCaps(1023) As Byte
Result = HidP_GetValueCaps _
(HidP_Input, _
ValueCaps(0), _
Capabilities.NumberInputValueCaps, _
PreparsedData)
Call DisplayResultOfAPICall("HidP_GetValueCaps")
'lstResults.AddItem "ValueCaps= " & GetDataString((VarPtr(ValueCaps(0))), 180)
'To use this data, copy the byte array into an array of structures.
End Sub
Private Sub InitializeDisplay()
Dim Count As Integer
Dim ByteValue As String
'Create a dropdown list box for each byte to send.
For Count = 0 To 255
If Len(Hex$(Count)) < 2 Then
ByteValue = "0" & Hex$(Count)
Else
ByteValue = Hex$(Count)
End If
frmMain.cboByte0.AddItem ByteValue, Count
Next Count
For Count = 0 To 255
If Len(Hex$(Count)) < 2 Then
ByteValue = "0" & Hex$(Count)
Else
ByteValue = Hex$(Count)
End If
frmMain.cboByte1.AddItem ByteValue, Count
Next Count
'Select a default item for each box
frmMain.cboByte0.ListIndex = 0
frmMain.cboByte1.ListIndex = 128
End Sub
Private Sub ReadAndWriteToDevice()
'Sends two bytes to the device and reads two bytes back.
Dim DeviceDetected As Boolean
'Report Header
lstResults.AddItem "HID Test Report"
lstResults.AddItem Format(Now, "general date")
'Some data to send
'(if not using the combo boxes):
'OutputReportData(0) = &H12
'OutputReportData(1) = &H34
'OutputReportData(2) = &HF0
'OutputReportData(3) = &HF1
'OutputReportData(4) = &HF2
'OutputReportData(5) = &HF3
'OutputReportData(6) = &HF4
'OutputReportData(7) = &HF5
'Get the bytes to send from the combo boxes.
'Increment the values if the autoincrement check box is selected.
If chkAutoincrement.Value = 1 Then
If cboByte0.ListIndex < 255 Then
cboByte0.ListIndex = cboByte0.ListIndex + 1
Else
cboByte0.ListIndex = 0
End If
If cboByte1.ListIndex < 255 Then
cboByte1.ListIndex = cboByte1.ListIndex + 1
Else
cboByte1.ListIndex = 0
End If
End If
OutputReportData(0) = cboByte0.ListIndex
OutputReportData(1) = cboByte1.ListIndex
'Find the device
DeviceDetected = FindTheHid
If DeviceDetected = True Then
'Learn the capabilities of the device
Call GetDeviceCapabilities
'Write a report to the device
Call WriteReport
'The firmware adds 1 to each received byte and sends the bytes back
'to the host.
'Add a delay to allow the host time to poll for the returned data.
Timeout = False
tmrDelay.Interval = 100
tmrDelay.Enabled = True
Do
DoEvents
Loop Until Timeout = True
'Read a report from the device.
Call ReadReport
Else
End If
'Scroll to the bottom of the list box.
lstResults.ListIndex = lstResults.ListCount - 1
End Sub
Private Sub ReadReport()
'Read data from the device.
Dim Count
Dim NumberOfBytesRead As Long
'Allocate a buffer for the report.
'Byte 0 is the report ID.
Dim ReadBuffer() As Byte
Dim UBoundReadBuffer As Integer
'******************************************************************************
'ReadFile
'Returns: the report in ReadBuffer.
'Requires: a device handle returned by CreateFile,
'the Input report length in bytes returned by HidP_GetCaps.
'******************************************************************************
'ReadFile is a blocking call. The application will hang until the device
'sends the requested amount of data. To prevent hanging, be sure that
'the device always has data to send.
Dim ByteValue As String
'The ReadBuffer array begins at 0, so subtract 1 from the number of bytes.
ReDim ReadBuffer(Capabilities.InputReportByteLength - 1)
'Pass the address of the first byte of the read buffer.
Result = ReadFile _
(HidDevice, _
ReadBuffer(0), _
CLng(Capabilities.InputReportByteLength), _
NumberOfBytesRead, _
0)
Call DisplayResultOfAPICall("ReadFile")
lstResults.AddItem " Report ID: " & ReadBuffer(0)
lstResults.AddItem " Report Data:"
txtBytesReceived.Text = ""
For Count = 1 To UBound(ReadBuffer)
'Add a leading 0 to values 0 - Fh.
If Len(Hex$(ReadBuffer(Count))) < 2 Then
ByteValue = "0" & Hex$(ReadBuffer(Count))
Else
ByteValue = Hex$(ReadBuffer(Count))
End If
'Get the Values of DB0 and DB1 to the Temp Variable
lstResults.AddItem " " & ByteValue
'Display the received bytes in the text box.
txtBytesReceived.SelStart = Len(txtBytesReceived.Text)
txtBytesReceived.SelText = ByteValue & vbCrLf
Next Count
DB_T0 = ReadBuffer(1)
DB_T1 = ReadBuffer(2)
End Sub
Private Sub Shutdown()
'Includes actions that must execute when the program ends.
'Close the open handle to the device.
Result = CloseHandle _
(HidDevice)
Call DisplayResultOfAPICall("CloseHandle (HidDevice)")
'Free memory used by SetupDiGetClassDevs
'Nonzero = success
Result = SetupDiDestroyDeviceInfoList _
(DeviceInfoSet)
Call DisplayResultOfAPICall("DestroyDeviceInfoList")
Result = HidD_FreePreparsedData _
(PreparsedData)
Call DisplayResultOfAPICall("HidD_FreePreparsedData")
End Sub
Private Sub Startup()
Call InitializeDisplay
tmrContinuousDataCollect.Enabled = False
tmrContinuousDataCollect.Interval = 1000
End Sub
Private Sub Text1_Change()
End Sub
Private Sub tmrContinuousDataCollect_Timer()
Call ReadAndWriteToDevice
End Sub
Private Sub tmrDelay_Timer()
Timeout = True
tmrDelay.Enabled = False
End Sub
Private Sub WriteCommand(Command As Byte, sendValue As Byte)
'Send data to the device
Dim Count As Integer
Dim NumberOfBytesRead As Long
Dim NumberOfBytesToSend As Long
Dim NumberOfBytesWritten As Long
Dim ReadBuffer() As Byte
Dim SendBuffer() As Byte
ReDim SendBuffer(Capabilities.OutputReportByteLength - 1)
SendBuffer(1) = Command
SendBuffer(2) = sendValue
'For Count = 1 To Capabilities.OutputReportByteLength - 1
' SendBuffer(Count) = OutputReportData(Count - 1)
' Next Count
NumberOfBytesWritten = 0
Result = WriteFile(HidDevice, SendBuffer(0), _
CLng(Capabilities.OutputReportByteLength), NumberOfBytesWritten, _
0)
End Sub
Private Function ReadCommand(Command As Byte) As Byte
' Read data from the device.
Dim Count
Dim NumberOfBytesRead As Long
Dim ReadBuffer() As Byte
Dim UBoundReadBuffer As Integer
Dim A As Byte
Dim ByteValue As String
'The ReadBuffer array begins at 0, so subtract 1 from the number of bytes.
ReDim ReadBuffer(Capabilities.InputReportByteLength - 1)
Call WriteCommand(Command, 0)
Timeout = False
tmrDelay.Interval = 100
tmrDelay.Enabled = True
Do
DoEvents
Loop Until Timeout = True
'Pass the address of the first byte of the read buffer.
repeatread:
Result = ReadFile _
(HidDevice, _
ReadBuffer(0), _
CLng(Capabilities.InputReportByteLength), _
NumberOfBytesRead, _
0)
If (NumberOfBytesRead > 1) Then
ReadCommand = ReadBuffer(2)
Else
GoTo repeatread
End If
Call DisplayResultOfAPICall("ReadFile")
lstResults.AddItem " Report ID: " & ReadBuffer(0)
lstResults.AddItem " Report Data:"
txtBytesReceived.Text = ""
For Count = 1 To UBound(ReadBuffer)
'Add a leading 0 to values 0 - Fh.
If Len(Hex$(ReadBuffer(Count))) < 2 Then
ByteValue = "0" & Hex$(ReadBuffer(Count))
Else
ByteValue = Hex$(ReadBuffer(Count))
End If
lstResults.AddItem " " & ByteValue
'Display the received bytes in the text box.
txtBytesReceived.SelStart = Len(txtBytesReceived.Text)
txtBytesReceived.SelText = ByteValue & vbCrLf
Next Count
End Function
Private Sub WriteReport()
'Send data to the device.
Dim Count As Integer
Dim NumberOfBytesRead As Long
Dim NumberOfBytesToSend As Long
Dim NumberOfBytesWritten As Long
Dim ReadBuffer() As Byte
Dim SendBuffer() As Byte
'The SendBuffer array begins at 0, so subtract 1 from the number of bytes.
ReDim SendBuffer(Capabilities.OutputReportByteLength - 1)
'******************************************************************************
'WriteFile
'Sends a report to the device.
'Returns: success or failure.
'Requires: the handle returned by CreateFile and
'The output report byte length returned by HidP_GetCaps
'******************************************************************************
'The first byte is the Report ID
SendBuffer(0) = 0
'The next bytes are data
For Count = 1 To Capabilities.OutputReportByteLength - 1
SendBuffer(Count) = OutputReportData(Count - 1)
Next Count
NumberOfBytesWritten = 0
Result = WriteFile _
(HidDevice, _
SendBuffer(0), _
CLng(Capabilities.OutputReportByteLength), _
NumberOfBytesWritten, _
0)
Call DisplayResultOfAPICall("WriteFile")
lstResults.AddItem " OutputReportByteLength = " & Capabilities.OutputReportByteLength
lstResults.AddItem " NumberOfBytesWritten = " & NumberOfBytesWritten
lstResults.AddItem " Report ID: " & SendBuffer(0)
lstResults.AddItem " Report Data:"
For Count = 1 To UBound(SendBuffer)
lstResults.AddItem " " & Hex$(SendBuffer(Count))
Next Count
End Sub
Private Sub Pause(HowLong As Date)
Dim TempTime As Date
TempTime = DateAdd("s", HowLong, Now)
While TempTime > Now
Wend
End Sub
Private Sub Addbytes()
DB_0 = DB_0 And 7
DB = DB_0 * 256
DB = DB * 256
DB = DB * 256
DB = DB + DB_1 * 256 * 256
DB = DB + DB_2 * 256
DB = DB + DB_3
End Sub
Private Sub Portselect()
If Port = 0 Then
OutputReportData(0) = &HA
OutputReportData(1) = &H0
Else
If Port = 1 Then
OutputReportData(0) = &HB
OutputReportData(1) = &H0
Else
If Port = 2 Then
OutputReportData(0) = &HC
OutputReportData(1) = &H0
Else
If Port = 3 Then
OutputReportData(0) = &HD
OutputReportData(1) = &H0
Else
If Port = 4 Then
OutputReportData(0) = &HE
OutputReportData(1) = &H0
Else
If Port = 5 Then
OutputReportData(0) = &HF
OutputReportData(1) = &H0
Else
If Port = 6 Then
OutputReportData(0) = &H10
OutputReportData(1) = &H0
Else
OutputReportData(0) = &H17
OutputReportData(1) = &H0
End If
End If
End If
End If
End If
End If
End If
Dim DeviceDetected As Boolean
'Report Header
lstResults.AddItem "HID Test Report"
lstResults.AddItem Format(Now, "general date")
'Find the device
DeviceDetected = FindTheHid
If DeviceDetected = True Then
'Learn the capabilities of the device
Call GetDeviceCapabilities
'Write a report to the device
Call WriteReport
'The firmware adds 1 to each received byte and sends the bytes back
'to the host.
'Add a delay to allow the host time to poll for the returned data.
Timeout = False
tmrDelay.Interval = 100
tmrDelay.Enabled = True
Do
DoEvents
Loop Until Timeout = True
'Read a report from the device.
Call ReadReport
Else
End If
'Scroll to the bottom of the list box.
lstResults.ListIndex = lstResults.ListCount - 1
End Sub