'Purpose:
' Windows DDK WinUSB API and Setup API Converted to Visual Basic 5/6
' Note: WinUSB Index represents CurrentControlSet device index
' MultiUSB Index represents Index of stored WinUsbDevice for multiple DPP devices
Option Explicit
'#Const bEnableDeviceNotification = 0
#Const bEnableDeviceNotification = 1
'Purpose: MultiUSB Index to DPP Serial Number storage type.
Public Type MUSB_SN_TO_INDEX
Index As Long 'WinUSB Device Information Array Index for Device
SerNum As Long 'DPP Device Serial Number
End Type
Public MUSB_MAX_INDEX As Long 'max index is 4 for five devices 0-4
Public MUSB_LAST_INDEX As Long 'last index is read fron vbDP5_MultiUSB.ini file
Public MUSB_SN(4) As Long 'multiusb serial numbers read from file
Public MUSB_Idx(4) As MUSB_SN_TO_INDEX 'multiusb serial numbers read from file
Public CurrentUSBDevice As Long 'WinUSB
Public NumUSBDevices As Long
'Purpose: Enumerates the error levels returned by ProcessError.
Public Type Message
hwnd As Long 'Handle of window.
Msg As Long 'Message.
wParam As Long 'First message parameter.
lParam As Long 'Second message parameter.
End Type
Public Enum ERRORLEVEL
elevCodeReturn 'Return error code.
elevDescReturn 'Return error description string.
elevSrcDescReturn 'Return error description string and error source string.
elevMsgBox 'Return/Display error description string and error source string.
End Enum
'Purpose: CopyMemory (RtlMoveMemory) moves memory either forward or backward, _
' aligned or unaligned, in 4-byte blocks, followed by any remaining bytes.
'
'
'Remarks: The (Source + Length) can overlap the Destination range passed in to CopyMemory (RtlMoveMemory).
'
'
'Parameter: Destination Points to the destination of the move.
'Parameter: Source Points to the memory to be copied.
'Parameter: Length Specifies the number of bytes to be copied.
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = (-4)
Public glngPrevWndProc As Long
Public Declare Function RtlMoveMemory Lib "kernel32" (Dest As Any, src As Any, ByVal Count As Long) As Long
Public Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByRef lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageZId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByVal Arguments As Long) As Long
Public Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Public Const DBT_DEVICEARRIVAL As Long = 32768
Public Const DBT_DEVICEREMOVECOMPLETE As Long = 32772
Public Const DBT_DEVTYP_DEVICEINTERFACE As Long = 5
Public Const DEVICE_NOTIFY_WINDOW_HANDLE As Long = 0
Public Const WM_DEVICECHANGE As Long = &H219
Public Const DIGCF_PRESENT As Integer = &H2
Public Const DIGCF_DEVICEINTERFACE As Integer = &H10
Public Type Guid
D1 As Long
D2 As Integer
D3 As Integer
D4(7) As Byte
End Type
Public Type DEV_BROADCAST_DEVICEINTERFACE
dbcc_size As Long
dbcc_devicetype As Long
dbcc_reserved As Long
dbcc_classguid As Guid
dbcc_name As Long
End Type
Public Type DEV_BROADCAST_DEVICEINTERFACE2
dbcc_size As Long
dbcc_devicetype As Long
dbcc_reserved As Long
dbcc_classguid As Guid
dbcc_name As String * 1024
End Type
Public Type DEV_BROADCAST_HDR
dbch_size As Long
dbch_devicetype As Long
dbch_reserved As Long
End Type
Public Type SP_DEVICE_INTERFACE_DATA
cbSize As Long
InterfaceClassGuid As Guid
Flags As Long
Reserved As Long
End Type
Public Type SP_DEVICE_INTERFACE_DETAIL_DATA
cbSize As Long
DevicePath As Byte
'DataPath(256) As Byte
End Type
Public Declare Function SetupDiDestroyDeviceInfoList Lib "setupapi.dll" (ByVal DeviceInfoSet As Long) As Long
Public Declare Function SetupDiEnumDeviceInterfaces Lib "setupapi.dll" (ByVal DeviceInfoSet As Long, ByVal DeviceInfoData As Long, ByRef InterfaceClassGuid As Guid, ByVal MemberIndex As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA) As Boolean
Public Declare Function SetupDiGetClassDevs Lib "setupapi.dll" Alias "SetupDiGetClassDevsA" (ByRef ClassGuid As Guid, ByVal Enumerator As String, ByVal hwndParent As Long, ByVal Flags As Long) As Long
Public Declare Function SetupDiGetDeviceInterfaceDetail Lib "setupapi.dll" Alias "SetupDiGetDeviceInterfaceDetailA" (ByVal DeviceInfoSet As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA, ByVal DeviceInterfaceDetailData As Long, ByVal DeviceInterfaceDetailDataSize As Long, ByRef RequiredSize As Long, ByVal DeviceInfoData As Long) As Boolean
Public Declare Function RegisterDeviceNotification Lib "user32.dll" Alias "RegisterDeviceNotificationA" (ByVal hRecipient As Long, NotificationFilter As Any, ByVal Flags As Long) As Long
Public Declare Function UnregisterDeviceNotification Lib "user32.dll" (ByVal Handle As Long) As Boolean
Public Const FILE_ATTRIBUTE_NORMAL As Integer = &H80
Public Const FILE_FLAG_OVERLAPPED As Long = &H40000000
Public Const FILE_SHARE_READ As Integer = &H1
Public Const FILE_SHARE_WRITE As Integer = &H2
Public Const GENERIC_READ As Long = &H80000000
Public Const GENERIC_WRITE As Long = &H40000000
Public Const OPEN_EXISTING As Integer = 3
Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Public Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Boolean
Public Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Public Enum PIPE_POLICY_TYPE
SHORT_PACKET_TERMINATE = &H1
AUTO_CLEAR_STALL
PIPE_TRANSFER_TIMEOUT
IGNORE_SHORT_PACKETS
ALLOW_PARTIAL_READS
AUTO_FLUSH
RAW_IO
MAXIMUM_TRANSFER_SIZE
End Enum
Public Type WINUSB_PIPE_INFORMATION
PipeType As USBD_PIPE_TYPE
PipeId As Byte
MaximumPacketSize As Integer
Interval As Byte
End Type
Public Enum USBD_PIPE_TYPE
UsbdPipeTypeControl
UsbdPipeTypeIsochronous
UsbdPipeTypeBulk
UsbdPipeTypeInterrupt
End Enum
Public Type USB_INTERFACE_DESCRIPTOR
bLength As Byte
bDescriptorType As Byte
bInterfaceNumber As Byte
bAlternateSetting As Byte
bNumEndpoints As Byte
bInterfaceClass As Byte
bInterfaceSubClass As Byte
bInterfaceProtocol As Byte
iInterface As Byte
End Type
Public Declare Function WinUsb_Initialize Lib "winusb.dll" (ByVal DeviceHandle As Long, ByRef InterfaceHandle As Long) As Boolean
Public Declare Function WinUsb_Free Lib "winusb.dll" (ByVal InterfaceHandle As Long) As Boolean
Public Declare Function WinUsb_QueryInterfaceSettings Lib "winusb.dll" (ByVal InterfaceHandle As Long, ByVal AlternateInterfaceNumber As Byte, ByRef UsbAltInterfaceDescriptor As USB_INTERFACE_DESCRIPTOR) As Boolean
Public Declare Function WinUsb_QueryPipe Lib "winusb.dll" (ByVal InterfaceHandle As Long, ByVal AlternateInterfaceNumber As Byte, ByVal PipeIndex As Byte, ByRef PipeInformation As WINUSB_PIPE_INFORMATION) As Boolean
Public Declare Function WinUsb_SetPipePolicy Lib "winusb.dll" (ByVal InterfaceHandle As Long, ByVal PipeId As Byte, ByVal PolicyType As Long, ByVal ValueLength As Long, ByRef Value As Byte) As Boolean
Public Declare Function WinUsb_SetPipePolicy1 Lib "winusb.dll" Alias "WinUsb_SetPipePolicy" (ByVal InterfaceHandle As Long, ByVal PipeId As Byte, ByVal PolicyType As Long, ByVal ValueLength As Long, ByRef Value As Long) As Boolean
Public Declare Function WinUsb_ReadPipe Lib "winusb.dll" (ByVal InterfaceHandle As Long, ByVal PipeId As Byte, ByRef Buffer As Byte, ByVal BufferLength As Long, ByRef LengthTransferred As Long, ByVal Overlapped As Long) As Boolean
Public Declare Function WinUsb_WritePipe Lib "winusb.dll" (ByVal InterfaceHandle As Long, ByVal PipeId As Byte, ByRef Buffer As Byte, ByVal BufferLength As Long, ByRef LengthTransferred As Long, ByVal Overlapped As Long) As Boolean
Public Declare Function WinUsb_ResetPipe Lib "winusb.dll" (ByVal InterfaceHandle As Long, ByVal PipeId As Byte) As Boolean
Public Declare Function WinUsb_AbortPipe Lib "winusb.dll" (ByVal InterfaceHandle As Long, ByVal PipeId As Byte) As Boolean
Public Declare Function WinUsb_FlushPipe Lib "winusb.dll" (ByVal InterfaceHandle As Long, ByVal PipeId As Byte) As Boolean
'Purpose: DPP WinUSB device information data type.
Public Type WinUsbDevice
DeviceHandle As Long 'Communications device resource handle.
winUsbHandle As Long 'WinUSB interface handle.
bulkInPipe As Long 'Bulk IN pipe id.
bulkOutPipe As Long 'Bulk OUT pipe id.
interruptInPipe As Long 'Interrupt IN pipe id.
interruptOutPipe As Long 'Interrupt OUT pipe id.
devicespeed As Long 'Device speed indicator.
SerNum As Long 'dpp serial number
idxUSB As Long 'WinUSB device index (1-NumDevices)
idxMUSB As Long 'MUSB array index
End Type
Public DppWinUSB As WinUsbDevice 'DppWinUSB device information
Public EmptyWinUSB As WinUsbDevice 'DppWinUSB device information
Public MultiWinUSB(4) As WinUsbDevice 'Multiple WinUSB device information, 0-4
Public NumMultiDpp As Long 'number of multiusb devices
Public USBDeviceNotificationHandle As Long
Public USBDeviceConnected As Boolean
Public USBDevicePathName As String
'Registry functions for counting WinUSB devices
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const KEY_QUERY_VALUE = &H1
Public Const ERROR_SUCCESS = 0&
Public Const MAX_PATH = 260
Public Const MAXREGBUFFER = 128
Public Const MAXERRBUFFER = 256
Public Const MAX_DEVPATH_LENGTH = 256
Public Const NUM_ASYNCH_IO = 100
Public Const BUFFER_SIZE = 1024
Public Const MAXDP5S = 128 ' max number of devices
Public Const WinUSBService = "SYSTEM\CurrentControlSet\Services\WinUSB\Enum"
Public Const WinUsbDP5 = "USB\Vid_10c4&Pid_842a"
Public Const WinUsbDP5Size = 21
Public Const ERROR_NO_MORE_ITEMS = 259&
Public Const REG_NONE = 0 ' No value type
Public Const REG_DWORD = 4 ' 32-bit number
Public Function OpenDevice(hwnd As Long, ByRef DppWinUSB As WinUsbDevice, ByRef DeviceConnected As Boolean, DevicePathName As String, MemberIndex As Long) As Boolean
Dim deviceFound As Boolean
Dim NewDevicePathName As String
Dim success As Boolean
Dim winUsbDemoGuid As Guid
OpenDevice = False
NewDevicePathName = ""
On Error GoTo OpenDeviceErr
If Not DeviceConnected Then
winUsbDemoGuid.D1 = &H5A8ED6A1
winUsbDemoGuid.D2 = &H7FC3
winUsbDemoGuid.D3 = &H4B6A
winUsbDemoGuid.D4(0) = &HA5
winUsbDemoGuid.D4(1) = &H36
winUsbDemoGuid.D4(2) = &H95
winUsbDemoGuid.D4(3) = &HDF
winUsbDemoGuid.D4(4) = &H35
winUsbDemoGuid.D4(5) = &HD0
winUsbDemoGuid.D4(6) = &H34
winUsbDemoGuid.D4(7) = &H48
'Fill an array with the device path names of all attached devices with matching GUIDs.
deviceFound = FindDeviceFromGuid(winUsbDemoGuid, NewDevicePathName, MemberIndex)
If deviceFound = True Then
success = GetDeviceHandle(DppWinUSB, NewDevicePathName)
success = VbBool(success)
If (success) Then
DeviceConnected = True
DevicePathName = NewDevicePathName 'Save NewDevicePathName so OnDeviceChange() knows which name is Test device.
Else 'There was a problem in retrieving the information.
DeviceConnected = False
CloseDeviceHandle DppWinUSB
End If
End If
If DeviceConnected Then 'The device was detected.
#If (bEnableDeviceNotification) Then
'(Re)Register to receive notifications if the device is removed or attached.
If USBDeviceNotificationHandle <> 0 Then 'Unregister old notification before creating new
Call UnregisterDeviceNotification(USBDeviceNotificationHandle) 'Stop receiving notification messages.
End If
SetWindowLong hwnd, GWL_WNDPROC, glngPrevWndProc 'pass control back to previous windows
success = RegisterForDeviceNotifications(DevicePathName, hwnd, winUsbDemoGuid, USBDeviceNotificationHandle)
success = VbBool(success)
If success Then
glngPrevWndProc = GetWindowLong(hwnd, GWL_WNDPROC)
SetWindowLong hwnd, GWL_WNDPROC, AddressOf WndProc
InitializeDevice DppWinUSB
End If
#Else
InitializeDevice DppWinUSB
#End If
End If
End If
OpenDevice = DeviceConnected
Exit Function
OpenDeviceErr:
Call ProcessError(Err)
End Function
'Purpose: Copies WinUsbDevice storage.
'Parameter: Source WinUsbDevice storage to be saved
'Parameter: Destination WinUsbDevice storage copy
Public Sub CopyWinUsbDevice(Source As WinUsbDevice, Destination As WinUsbDevice)
Destination.DeviceHandle = Source.DeviceHandle 'Communications device resource handle.
Destination.winUsbHandle = Source.winUsbHandle 'WinUSB interface handle.
Destination.bulkInPipe = Source.bulkInPipe 'Bulk IN pipe id.
Destination.bulkOutPipe = Source.bulkOutPipe 'Bulk OUT pipe id.
Destination.interruptInPipe = Source.interruptInPipe 'Interrupt IN pipe id.
Destination.interruptOutPipe = Source.interruptOutPipe 'Interrupt OUT pipe id.
Destination.devicespeed = Source.devicespeed 'Device speed indicator.
Destination.SerNum = Source.SerNum 'dpp serial number
Destination.idxUSB = Source.idxUSB 'WinUSB device index (1-NumDevices)
Destination.idxMUSB = Source.idxMUSB 'MUSB array index
End Sub
Public Sub DeviceConnectedDisplay(rtbStatus As RichTextLib.RichTextBox, isDetected As Boolean)
If (isDetected) Then
UpdateStatusList rtbStatus, "Device connected.", RGB(0, 128, 0)
Else
UpdateStatusList rtbStatus, "Could not connect to device.", vbRed
End If
End Sub
Public Sub UpdateStatusList(rtbStatus As RichTextLib.RichTextBox, strStatus As String, Optional clrColor As Long = vbBlack)
On Error GoTo UpdateStatusListErr
StatusList rtbStatus, strStatus, clrColor
Exit Sub
UpdateStatusListErr:
Call ProcessError(Err)
End Sub
Public Sub StatusList(rtbStatus As RichTextLib.RichTextBox, strStatus As String, clrColor As Long, Optional bNL As Boolean = True)
Dim prvlen As Long
Dim strNL As String
On Error GoTo 0
prvlen = Len(rtbStatus.Text)
rtbStatus.SelStart = Len(rtbStatus.Text) + 1
strNL = ""
If (bNL) Then strNL = vbNewLine
rtbStatus.SelText = strStatus & strNL
rtbStatus.SelStart = prvlen
rtbStatus.SelLength = Len(strStatus & strNL)
rtbStatus.SelColor = clrColor
rtbStatus.SelStart = Len(rtbStatus.Text) + 1
End Sub
'Purpose: Closes the device handle obtained with CreateFile and frees resources.
Public Sub CloseDeviceHandle(DppWinUSB As WinUsbDevice)
Dim success As Boolean
On Error GoTo CloseDeviceHandleErr
success = WinUsb_Free(DppWinUSB.winUsbHandle)
success = VbBool(success)
If Not (DppWinUSB.DeviceHandle = 0) Then
If Not (DppWinUSB.DeviceHandle) Then
CloseHandle (DppWinUSB.DeviceHandle)
End If
End If
Exit Sub
CloseDeviceHandleErr:
Call ProcessError(Err)
End Sub
'Purpose: Requests a handle with CreateFile.
'
' Returns The handle.
'
'
'Parameter: devicePathName Returned by SetupDiGetDeviceInterfaceDetail
' in an SP_DEVICE_INTERFACE_DETAIL_DATA structure.
Public Function GetDeviceHandle(ByRef DppWinUSB As WinUsbDevice, ByVal DevicePathName As String) As Boolean
Dim security As SECURITY_ATTRIBUTES
security.lpSecurityDescriptor = 0
security.bInheritHandle = 1
security.nLength = Len(security)
DppWinUSB.DeviceHandle = CreateFile(DevicePathName, _
GENERIC_WRITE Or GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, _
security, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL Or FILE_FLAG_OVERLAPPED, 0)
If Not (DppWinUSB.DeviceHandle) Then
GetDeviceHandle = True
Else
MsgBox GetErrorString(Err.LastDllError)
GetDeviceHandle = False
End If
End Function
'Purpose: Initializes a device interface and obtains information about it. Calls these
' winusb API functions: WinUsb_Initialize,WinUsb_QueryInterfaceSettings, WinUsb_QueryPipe
'
' Returns True on success, False on failure.
'
'
'Parameter: DppWinUSB DPP WinUSB device information
Public Function InitializeDevice(ByRef DppWinUSB As WinUsbDevice) As Boolean
Dim ifaceDescriptor As USB_INTERFACE_DESCRIPTOR
Dim pipeInfo As WINUSB_PIPE_INFORMATION
Dim pipeTimeout As Long
Dim success As Boolean
Dim success1 As Boolean
Dim i As Long
pipeTimeout = 500 ' 2/4/10 - seems like 500mS should be plenty?
'Erase FPGA' takes 4s, worst case! Change timeout just for that command
On Error GoTo InitializeDeviceErr
success = WinUsb_Initialize(DppWinUSB.DeviceHandle, DppWinUSB.winUsbHandle)
success = VbBool(success)
If success Then
success = WinUsb_QueryInterfaceSettings(DppWinUSB.winUsbHandle, 0, ifaceDescriptor)
success = VbBool(success)
If success Then
' Get the transfer type, endpoint number, and direction for the interface's
' bulk and interrupt endpoints. Set pipe policies.
For i = 0 To ifaceDescriptor.bNumEndpoints - 1
success1 = WinUsb_QueryPipe(DppWinUSB.winUsbHandle, 0, CByte(i), pipeInfo)
success1 = VbBool(success1)
If ((pipeInfo.PipeType = USBD_PIPE_TYPE.UsbdPipeTypeBulk) And _
UsbEndpointDirectionIn(pipeInfo.PipeId)) Then
DppWinUSB.bulkInPipe = pipeInfo.PipeId
Call SetPipePolicy(DppWinUSB, CByte(DppWinUSB.bulkInPipe), CInt(PIPE_POLICY_TYPE.IGNORE_SHORT_PACKETS), False) ' this is the default, but set it anyway
Call SetPipePolicy(DppWinUSB, CByte(DppWinUSB.bulkInPipe), CInt(PIPE_POLICY_TYPE.AUTO_CLEAR_STALL), True) ' new - 2/5/2010
Call SetPipePolicy(DppWinUSB, CByte(DppWinUSB.bulkInPipe), CInt(PIPE_POLICY_TYPE.ALLOW_PARTIAL_READS), False) ' new - 5/25/2010
Call SetPipePolicy1(DppWinUSB, CByte(DppWinUSB.bulkInPipe), CInt(PIPE_POLICY_TYPE.PIPE_TRANSFER_TIMEOUT), pipeTimeout)
ElseIf ((pipeInfo.PipeType = USBD_PIPE_TYPE.UsbdPipeTypeBulk) And _
UsbEndpointDirectionOut(pipeInfo.PipeId)) Then
DppWinUSB.bulkOutPipe = pipeInfo.PipeId
'Call SetPipePolicy(CByte(DppWinUSB.bulkOutPipe), CInt(PIPE_POLICY_TYPE.IGNORE_SHORT_PACKETS), False)
Call SetPipePolicy(DppWinUSB, CByte(DppWinUSB.bulkOutPipe), CInt(PIPE_POLICY_TYPE.SHORT_PACKET_TERMINATE), True)
Call SetPipePolicy(DppWinUSB, CByte(DppWinUSB.bulkOutPipe), CInt(PIPE_POLICY_TYPE.AUTO_CLEAR_STALL), True)
Call SetPipePolicy1(DppWinUSB, CByte(DppWinUSB.bulkOutPipe), CInt(PIPE_POLICY_TYPE.PIPE_TRANSFER_TIMEOUT), pipeTimeout)
End If
Next i
Else
success = False
End If
End If
success = VbBool(success)
InitializeDevice = success
Exit Function
InitializeDeviceErr:
Call ProcessError(Err)
End Function
'Purpose: Sets pipe policy.
' Used when the value parameter is a byte (all except PIPE_TRANSFER_TIMEOUT).
'
' Returns True on success, False on failure.
'
'
'Parameter: PipeId Pipe to set a policy for.
'Parameter: PolicyType PIPE_POLICY_TYPE member.
'Parameter: Value Policy value.
Private Function SetPipePolicy(ByRef DppWinUSB As WinUsbDevice, ByVal PipeId As Byte, ByVal PolicyType As Long, ByVal Value As Boolean) As Boolean
Dim success As Boolean
On Error GoTo SetPipePolicyErr
success = WinUsb_SetPipePolicy(DppWinUSB.winUsbHandle, PipeId, PolicyType, 1, CByte(Value))
success = VbBool(success)
SetPipePolicy = success
Exit Function
SetPipePolicyErr:
Call ProcessError(Err)
End Function
'Purpose: Sets pipe policy.
' Used when the value parameter is a long (PIPE_TRANSFER_TIMEOUT only).
'
' Returns True on success, False on failure.
'
'
'Parameter: PipeId Pipe to set a policy for.
'Parameter: PolicyType PIPE_POLICY_TYPE member.
'Parameter: Value Policy value.
Public Function SetPipePolicy1(ByRef DppWinUSB As WinUsbDevice, ByVal PipeId As Byte, ByVal PolicyType As Long, ByVal Value As Long) As Boolean
Dim success As Boolean
SetPipePolicy1 = False
On Error GoTo SetPipePolicy1Err
success = WinUsb_SetPipePolicy1(DppWinUSB.winUsbHandle, PipeId, PolicyType, 4, Value)
success = VbBool(success)
SetPipePolicy1 = success
Exit Function
SetPipePolicy1Err:
Call ProcessError(Err)
End Function
'Purpose: Is the endpoint's direction IN (device to host)
'
' Returns True if IN (device to host), False if OUT (host to device)
'
'
'Parameter: addr The endpoint address.
Private Function UsbEndpointDirectionIn(ByVal addr As Long) As Boolean
On Error GoTo UsbEndpointDirectionInErr
If ((addr And &H80) = &H80) Then
UsbEndpointDirectionIn = True
Else
UsbEndpointDirectionIn = False
End If
Exit Function
UsbEndpointDirectionInErr:
Call ProcessError(Err)
End Function
'Purpose: Is the endpoint's direction OUT (host to device)
'
' Returns True if OUT (host to device, False if IN (device to host)
'
'
'Parameter: addr The endpoint address.
Private Function UsbEndpointDirectionOut(ByVal addr As Long) As Boolean
On Error GoTo UsbEndpointDirectionOutErr
If ((addr And &H80) = 0) Then
UsbEndpointDirectionOut = True
Else
UsbEndpointDirectionOut = False
End If
Exit Function
UsbEndpointDirectionOutErr:
Call ProcessError(Err)
End Function
'Purpose: Compares two device path names. Used to find out if the device name
' of a recently attached or removed device matches the name of a
' device the application is communicating with.
'
'
' Returns True if the names match, False if not.
'
'
'Parameter: m A WM_DEVICECHANGE message. A call to RegisterDeviceNotification
' causes WM_DEVICECHANGE messages to be passed to an OnDeviceChange routine..
'Parameter: DevicePathName A device pathname returned by SetupDiGetDeviceInterfaceDetail
' in an SP_DEVICE_INTERFACE_DETAIL_DATA structure.
Public Function DeviceNameMatch(m As Message, ByVal DevicePathName As String) As Boolean
Dim deviceNameString As String
Dim stringSize As Long
deviceNameString = ""
On Error GoTo DeviceNameMatchErr
Dim devBroadcastDeviceInterface As DEV_BROADCAST_DEVICEINTERFACE2
Dim devBroadcastHeader As DEV_BROADCAST_HDR
CopyMemory devBroadcastHeader, ByVal (m.lParam), Len(devBroadcastHeader)
If (devBroadcastHeader.dbch_devicetype = DBT_DEVTYP_DEVICEINTERFACE) Then
CopyMemory devBroadcastDeviceInterface, ByVal (m.lParam), ByVal (devBroadcastHeader.dbch_size)
stringSize = CInt((devBroadcastHeader.dbch_size - 32) / 2) + 1
deviceNameString = CStr(Left(devBroadcastDeviceInterface.dbcc_name, stringSize)) 'Store the device name in a String.
If (StrComp(deviceNameString, DevicePathName, vbTextCompare) = 0) Then 'Set ignorecase True.
DeviceNameMatch = True
Else
DeviceNameMatch = False
End If
End If
Exit Function
DeviceNameMatchErr:
Call ProcessError(Err)
End Function
'Purpose: Use SetupDi (Setup Device Installation) API functions to retrieve the device path name of an
' attached device that belongs to a device interface class.
'
'
' Returns True if a device is found, False if not.
'
'
'Parameter: TestGuid Interface class GUID.
'Parameter: devicePathName A pointer to the device path name of an attached device.
Public Function FindDeviceFromGuid(ByRef TestGuid As Guid, ByRef DevicePathName As String, MemberIndex As Long) As Boolean
Dim bufferSize As Long
Dim bufferSizeReq As Long
Dim detailDataBuffer() As Byte
Dim DevDetailData As SP_DEVICE_INTERFACE_DETAIL_DATA
Dim deviceFound As Boolean
Dim DeviceInfoSet As Long
Dim lastDevice As Boolean
Dim TestDeviceInterfaceData As SP_DEVICE_INTERFACE_DATA
'Dim pDevicePathName As Long
Dim success As Boolean
Dim pDevicePathName As String
On Error GoTo FindDeviceFromGuidErr
DeviceInfoSet = SetupDiGetClassDevs(TestGuid, vbNullString, 0, DIGCF_PRESENT Or DIGCF_DEVICEINTERFACE)
deviceFound = False
'MemberIndex = 0
'Do
TestDeviceInterfaceData.cbSize = Len(TestDeviceInterfaceData) 'The size is 28 bytes.
success = SetupDiEnumDeviceInterfaces(DeviceInfoSet, 0, TestGuid, MemberIndex, TestDeviceInterfaceData)
success = VbBool(success)
If (Not CBool(success)) Then 'Find out if a device information set was retrieved.
lastDevice = True
Else 'A device is present.
success = SetupDiGetDeviceInterfaceDetail(DeviceInfoSet, TestDeviceInterfaceData, 0, 0, bufferSize, 0)
success = VbBool(success)
DevDetailData.cbSize = Len(DevDetailData)
ReDim detailDataBuffer(bufferSize) '
Call RtlMoveMemory(detailDataBuffer(0), DevDetailData, 4)
success = SetupDiGetDeviceInterfaceDetail _
(DeviceInfoSet, _
TestDeviceInterfaceData, _
VarPtr(detailDataBuffer(0)), _
bufferSize, _
bufferSizeReq, _
0)
success = VbBool(success)
pDevicePathName = CStr(detailDataBuffer()) 'Convert the byte array to a string.
pDevicePathName = StrConv(pDevicePathName, vbUnicode) 'Convert to Unicode.
pDevicePathName = Right$(pDevicePathName, Len(pDevicePathName) - 4) 'Strip cbSize (4 bytes) from the beginning.
DevicePathName = pDevicePathName 'Get the String containing the devicePathName.
deviceFound = True
End If
'MemberIndex = MemberIndex + 1
'Loop Until (lastDevice = True)
SetupDiDestroyDeviceInfoList (DeviceInfoSet)
FindDeviceFromGuid = deviceFound
Exit Function
FindDeviceFromGuidErr:
Call ProcessError(Err)
End Function
'Purpose: Requests to receive a notification when a device is attached or removed.
'
'
' Returns True on success, False otherwise.
'
'
'Parameter: devicePathName Handle to a device.
'Parameter: formHandle Handle to the window that will receive device events.
'Parameter: classGuid Device interface GUID.
'Parameter: deviceNotificationHandle Returned device notification handle.
Public Function RegisterForDeviceNotifications(ByVal DevicePathName As String, ByVal formHandle As Long, ByRef ClassGuid As Guid, ByRef deviceNotificationHandle As Long) As Boolean
Dim devBroadcastDeviceInterface As DEV_BROADCAST_DEVICEINTERFACE
Dim devBroadcastDeviceInterfaceBuffer As Long
Dim size As Long
On Error GoTo RegisterForDeviceNotificationsErr
size = Len(devBroadcastDeviceInterface) 'Set the size.
devBroadcastDeviceInterface.dbcc_size = size
devBroadcastDeviceInterface.dbcc_devicetype = DBT_DEVTYP_DEVICEINTERFACE
devBroadcastDeviceInterface.dbcc_reserved = 0
devBroadcastDeviceInterface.dbcc_classguid = ClassGuid 'Specify the interface class to receive notifications about.
#If (bEnableDeviceNotification) Then
deviceNotificationHandle = RegisterDeviceNotification(formHandle, devBroadcastDeviceInterface, DEVICE_NOTIFY_WINDOW_HANDLE)
If (deviceNotificationHandle = 0#) Then
RegisterForDeviceNotifications = False
Else
RegisterForDeviceNotifications = True
End If
#Else
RegisterForDeviceNotifications = False
#End If
Exit Function
RegisterForDeviceNotificationsErr:
Call ProcessError(Err)
End Function
'Purpose: Returns and/or displays process error messages
Public Function ProcessError(errError As ErrObject, Optional errSource As String = "", Optional errControl As ERRORLEVEL = elevSrcDescReturn) As Variant
Select Case errControl
Case elevCodeReturn
ProcessError = errError.Number
Case elevDescReturn
ProcessError = errError.Description
Case elevSrcDescReturn
ProcessError = errSource & " : " & errError.Description
Case elevMsgBox
ProcessError = errSource & " : " & errError.Description
MsgBox errError.Description, vbCritical, errSource
Case Else
ProcessError = errSource & " : " & errError.Description
End Select
MsgBox errError.Description & " " & errError.LastDllError
End Function
'Purpose: Converts any C boolean type to a VB boolean type
Public Function VbBool(bBool As Variant) As Boolean
On Error GoTo VbBoolErr
VbBool = False
If (bBool = 0) Then
VbBool = False
Else
VbBool = True
End If
Exit Function
VbBoolErr:
End Function
'Purpose: Returns the error message for the last error.
'Adapted from Dan Appleman's "Win32 API Puzzle Book"
Public 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)
'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
#If (bEnableDeviceNotification) Then
'Purpose: Overrides WndProc to enable checking for and handling WM_DEVICECHANGE messages.
'Parameter: Windows message info
Public Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error GoTo WndProcErr
If Msg = WM_DEVICECHANGE Then 'The OnDeviceChange routine processes WM_DEVICECHANGE messages.
'frmDP5.OnDeviceChange hWnd, Msg, wParam, lParam
frmDP5.OnDeviceChange hwnd, Msg, wParam, lParam
End If
Debug.Print Msg
'Pass the messages onto VB's own Window Procedure to let the base form process the message.
WndProc = CallWindowProc(glngPrevWndProc, hwnd, Msg, wParam, lParam)
Exit Function
WndProcErr:
Call ProcessError(Err)
End Function
#End If
'Purpose: Counts the number of WinUSB DPP device connected
Public Function CountDP5WinusbDevices()
Dim hKey As Long
Dim retCode As Long
Dim lRet As Long
Dim idxDP5 As Long
Dim DevicePath(MAXREGBUFFER - 1) As Byte
Dim cbDevicePath As Long
Dim KeyName As String
Dim cbKeyName As Long
Dim ErrMsg As String
Dim cbErrMsg As Long
Dim strDevicePath As String
NumUSBDevices = 0
retCode = RegOpenKeyEx(HKEY_LOCAL_MACHINE, WinUSBService, 0&, KEY_QUERY_VALUE, hKey)
If (retCode <> ERROR_SUCCESS) Then
CountDP5WinusbDevices = 0
Exit Function
End If
KeyName = Space(MAX_PATH)
' Test ALL Keys (0,1,... are device paths, Count,NextInstance,(Default) have other info)
For idxDP5 = 0 To (MAXDP5S + 3) - 1 'devs + 3 other keys
cbKeyName = MAX_PATH
cbDevicePath = MAXREGBUFFER
retCode = RegEnumValue(hKey, idxDP5, ByVal KeyName, cbKeyName, 0&, REG_NONE, DevicePath(0), cbDevicePath)
If (retCode = ERROR_SUCCESS) Then
strDevicePath = ByteArrayToString(DevicePath)
If (StrComp(Left(KeyName, 5), "Count", vbTextCompare) = 0) Then
'do nothing
ElseIf (StrComp(Left(strDevicePath, WinUsbDP5Size), WinUsbDP5, vbTextCompare) = 0) Then ' DP5 device path found
'TRACE("DP5 device [%d]: %s=%s\r\n", (NumUSBDevices + 1), KeyName, DevicePath);
NumUSBDevices = NumUSBDevices + 1
End If
ElseIf (retCode = ERROR_NO_MORE_ITEMS) Then ' no more values to read
Exit For
Else ' error reading values
cbErrMsg = MAXERRBUFFER
ErrMsg = Space(MAXERRBUFFER)
lRet = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, retCode, 0&, ErrMsg, cbErrMsg, 0&)
If (lRet > 0) Then ErrMsg = Left(ErrMsg, lRet) Else ErrMsg = ""
'MsgBox ErrMsg
Exit For
End If
Next
Call RegCloseKey(hKey)
CountDP5WinusbDevices = NumUSBDevices '/* return number of devices */
End Function
Public Function ByteArrayToString(byteArray() As Byte) As String
Dim str As String
Dim PosTerminator As String
str = StrConv(byteArray, vbUnicode)
PosTerminator = InStr(str, Chr(0))
If PosTerminator > 0 Then str = Left(str, PosTerminator - 1)
ByteArrayToString = str
End Function