hidinterface.bas

利用psoc进行usb及capsense的程序编写

Attribute VB_Name = "AccessIODevice"
Option Explicit
' This module is gives Visual Basic programs access to the Windows API
'
' Copyright 2005, John Hyde, USB Design By Example
' You may use this program for development but you may not sell or publish it
' without written permission from the author
'
Dim SA As SECURITY_ATTRIBUTES

Public Function OpenForRead(FileName As String) As Long
' Open a device that has already been identified as present
' The device only sends reports on button changes, therefore I must use overlapped IO
OpenForRead = CreateFile(FileName, GENERIC_READ, FILE_SHARE_READWRITE, SA, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0)
End Function

Public Function OpenForWrite(FileName As String) As Long
' Open a device that has already been identified as present
' I need a write handle that is not overlapped
OpenForWrite = CreateFile(FileName, GENERIC_WRITE, FILE_SHARE_READWRITE, SA, OPEN_EXISTING, 0, 0)
End Function

Public Function FindHIDInterface(VID As Integer, PID As Integer, UsagePage As Integer) As String
' This function searches the system HID tables for a device matching VID, PID and UsagePage
' If found then it returns the system name for the device (for a later open)
Dim HidGuid As GUID
Dim PnPHandle, HidHandle, HidEntry, BytesReturned, i As Long
Dim HidName, NameMatch As String
Dim Success, Found As Boolean
Dim DeviceInterfaceData As Device_Interface_Data
Dim FunctionClassDeviceData As Device_Interface_Detail
Dim Attributes As HIDD_ATTRIBUTES
Dim DataPointer As Long
Dim HidCapabilities As Hid_Capabilities
Dim temp As Integer
'
' Clear the name, return this empty string if the device is not found
NameMatch = ""
'   First, get the HID class identifier
Call HidD_GetHidGuid(HidGuid)
'   Get a handle for the Plug and Play node, request currently active HID devices
PnPHandle = SetupDiGetClassDevs(HidGuid, 0, 0, DIGCF_PRESENT Or DIGCF_DEVICEINTERFACE)
If (PnPHandle = INVALID_DEVICE_HANDLE) Then ErrorExit ("Could not attach to PnP node")
'
HidEntry = 0
Found = False
DeviceInterfaceData.cbSize = Len(DeviceInterfaceData)
'   Step through the table of HID devices
Do While (SetupDiEnumDeviceInterfaces(PnPHandle, 0, HidGuid, HidEntry, DeviceInterfaceData) And Not (Found))
'   There is a device here, get it's name
    FunctionClassDeviceData.cbSize = 5 ' Minimum size, my structure can hold maximum size
    Success = SetupDiGetDeviceInterfaceDetail(PnPHandle, DeviceInterfaceData, FunctionClassDeviceData, _
        UBound(FunctionClassDeviceData.DataPath), BytesReturned, 0)
    If (Success = 0) Then ErrorExit ("Could not get the name of this HID device")
' Convert returned C string to Visual Basic String
    HidName = ""
    i = 0
    Do While FunctionClassDeviceData.DataPath(i) <> 0
        HidName = HidName & Chr$(FunctionClassDeviceData.DataPath(i))
        i = i + 1
        Loop
' Can now open this HID device for inspection
    HidHandle = CreateFile(HidName, 0, FILE_SHARE_READWRITE, SA, OPEN_EXISTING, 0, 0)
    If (HidHandle = INVALID_DEVICE_HANDLE) Then ErrorExit ("Could not open HID device")
' Is it OUR HID device?
    If HidD_GetAttributes(HidHandle, Attributes) Then
        If ((Attributes.VendorID = VID) And (Attributes.ProductID = PID)) Then
' Is it the correct interface?
            Success = HidD_GetPreparsedData(HidHandle, DataPointer)
            If (Success) Then
                Success = HidP_GetCaps(DataPointer, HidCapabilities)
                If (Success) Then
                    If (HidCapabilities.UsagePage = UsagePage) Then
                        Found = True
                        NameMatch = HidName
                        End If
                    End If
                End If
            End If
        Call CloseHandle(HidHandle)
        End If 'HidD_GetAttributes
    HidEntry = HidEntry + 1 ' Check next entry
    Loop 'SetupDiEnumDeviceInterfaces returns FALSE when there are no more entries
SetupDiDestroyDeviceInfoList (PnPHandle)
FindHIDInterface = NameMatch
End Function

Public Sub ErrorExit(Reason As String)
Dim ErrorCode As Long
ErrorCode = GetLastError()
Call MsgBox(Reason & vbCrLf & "Errorcode = [" & ErrorCode & "]" & vbCrLf, vbCritical)
If (ErrorCode <> 0) Then Stop
End Sub