Attribute VB_Name = "ModuloUSB"
Option Explicit
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 HidDevice As Long
Dim LastDevice 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(65) As Byte
Dim DispositivoDetectado As Boolean
Dim PreparsedData As Long
Dim Result As Long
Dim TimeOut As Boolean
'Valores del HID
Const VID = &H1234
Const PID = &H1
'Variable que nos indica si esta detectada la placa
Public DetectBoard As Boolean
Sub DetectarUSB()
Dim HidGuid As GUID
Dim MemberIndex As Long
LastDevice = False
DetectBoard = 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)
'******************************************************************************
'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))
'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
MyDeviceInfoData.cbSize = Len(MyDeviceInfoData)
Result = SetupDiGetDeviceInterfaceDetail(DeviceInfoSet, MyDeviceInterfaceData, 0, 0, Needed, 0)
DetailData = 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)
'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)
HidDevice = CreateFile(DevicePathName, GENERIC_READ Or GENERIC_WRITE, (FILE_SHARE_READ Or FILE_SHARE_WRITE), 0, OPEN_EXISTING, 0, 0)
'Set the Size property to the number of bytes in the structure.
DeviceAttributes.Size = LenB(DeviceAttributes)
Result = HidD_GetAttributes(HidDevice, DeviceAttributes)
'Find out if the device matches the one we're looking for.
If (DeviceAttributes.VendorID = VID) And (DeviceAttributes.ProductID = PID) Then
DetectBoard = True 'Variable de deteccion de la placa controladora de servos
Else
DetectBoard = False 'Variable de deteccion de la placa controladora de servos
'If it's not the one we want, close its handle.
Result = CloseHandle(HidDevice)
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 (DispositivoDetectado = True)
'Si se detecta la controladora y se capturan las propiedades
If DetectBoard Then
Dim ppData(29) As Byte
Dim ppDataString As Variant
'Preparsed Data is a pointer to a routine-allocated buffer.
Result = HidD_GetPreparsedData(HidDevice, PreparsedData)
'Copy the data at PreparsedData into a byte array.
Result = RtlMoveMemory(ppData(0), PreparsedData, 30)
ppDataString = ppData()
'Convert the data to Unicode.
ppDataString = StrConv(ppDataString, vbUnicode)
Result = HidP_GetCaps(PreparsedData, Capabilities)
Debug.Print Capabilities.OutputReportByteLength
Debug.Print Capabilities.InputReportByteLength
Else
MsgBox "No se detecta la controladora... Revise la conexión USB", vbCritical, "Error"
End If
End Sub
Private Function LeerUSB(ByRef ByteValue As Byte) As Boolean
Dim Count
Dim NumberOfBytesRead As Long
Dim ReadBuffer() As Byte
Dim UBoundReadBuffer As Integer
'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)
'Debug.Print NumberOfBytesRead
If Result Then
For Count = 1 To UBound(ReadBuffer)
'Add a leading 0 to values 0 - Fh.
If Len(Hex$(ReadBuffer(Count))) < 2 Then
ByteValue = ReadBuffer(Count)
Else
ByteValue = ReadBuffer(Count)
End If
Debug.Print ByteValue
Next Count
LeerUSB = True
End If
End Function
Private Function EscribirUSB() As Boolean
Dim Count As Integer
Dim NumberOfBytesRead As Long
Dim NumberOfBytesToSend As Long
Dim NumberOfBytesWritten As Long
Dim ReadBuffer() As Byte
Dim SendBuffer() As Byte
If Capabilities.OutputReportByteLength <= 0 Then
Exit Function
End If
'The SendBuffer array begins at 0, so subtract 1 from the number of bytes.
ReDim SendBuffer(Capabilities.OutputReportByteLength - 1)
'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)
If Result Then EscribirUSB = True
End Function
'Lee las posiciones de los servos
Function LeerPosicion(nServo As Integer) As Byte
On Error GoTo Rutina
'Leemos la posicion de los servos
OutputReportData(0) = Asc("P") 'Cabecera ("P")
OutputReportData(1) = nServo 'Nº de Servo al que accedemos
If EscribirUSB = False Then Exit Function 'Escribimos la consula de la posicion
If LeerUSB(LeerPosicion) = False Then Exit Function 'Devuelve la posicion en Valor2
Exit Function
Rutina:
MsgBox "Error... al leer las posiciones", vbExclamation, "Error"
End Function
Sub EnviarPosicion()
On Error GoTo Rutina
Dim TmpC As Integer
OutputReportData(0) = Asc("T") 'cabecera (todos=T)
'Preparacion de los datos de cada servo al bufer TX del USB
For TmpC = 1 To 30
OutputReportData(TmpC) = frmMain.VS1(TmpC - 1).Value 'Preparacion del buffer
Next TmpC
'si la escritura del usb falla intentamos capturar el HID
If EscribirUSB = False Then Call DetectarUSB
Exit Sub
Rutina:
MsgBox "Error en el sub Enviarposición", vbInformation, "Error"
End Sub
Sub EnviarPosicionServo(nServo As Integer, Posicion As Byte)
On Error GoTo Rutina
OutputReportData(0) = Asc("S") 'cabecera (Servo =S)
OutputReportData(1) = nServo 'Numero del servo
OutputReportData(2) = Posicion 'Preparacion del buffer
'si la escritura del usb falla intentamos capturar el HID
If EscribirUSB = False Then Call DetectarUSB
Exit Sub
Rutina:
MsgBox "Error en la funcion EnviarPosiciónServo..."
End Sub
Sub EnviarComandoDeInicio(nServo As Integer, Posicion As Byte)
On Error GoTo Rutina
OutputReportData(0) = Asc("I") 'Cabecera (I)
OutputReportData(1) = nServo 'Nº de Servo
OutputReportData(2) = Posicion 'Preparacion del dato de la posicion
'Escribimos los datos en el puerto USB
Call EscribirUSB
Exit Sub
Rutina:
MsgBox "Error en el sub EnviarComandoInicio..."
End Sub
'Lee el parametro de Ancho del PWM
Function LeerAnchoPWM(Puerto As Integer) As Byte
On Error GoTo Rutina
OutputReportData(0) = Asc("R") 'Cabecera ("R")
OutputReportData(1) = Puerto 'Nº de puerto
If EscribirUSB = False Then Exit Function 'Escribimos la consula de la posicion
If LeerUSB(LeerAnchoPWM) = False Then Exit Function 'Devuelve el valor del ancho PWM
Exit Function
Rutina:
MsgBox Error & "...Leyendo el parametro de Ancho del PWM"
End Function
'Lee el parametro de inicio del PWM
Function LeerInicioPWM(Puerto As Integer) As Byte
On Error GoTo Rutina
OutputReportData(0) = Asc("Q") 'Cabecera ("Q")
OutputReportData(1) = Puerto 'Nº de puerto
If EscribirUSB = False Then Exit Function 'Escribimos la consula de la posicion
If LeerUSB(LeerInicioPWM) = False Then Exit Function 'Devuelve el valor del inicio PWM
Exit Function
Rutina:
MsgBox Error & "... Leyendo el parametro de inicio del PWM"
End Function
Sub EnviarInicioPWM(Puerto As Integer, valor As Byte)
On Error GoTo Rutina
OutputReportData(0) = Asc("O") 'cabecera (PWM sIni=O)
OutputReportData(1) = Puerto 'puerto
OutputReportData(2) = valor 'Valor del puerto
'si la escritura del usb falla intentamos capturar el HID
If EscribirUSB = False Then Call DetectarUSB
Exit Sub
Rutina:
MsgBox Error & "... Enviando el parametro de Inicio del PWM"
End Sub
Sub EnviarAnchoPWM(Puerto As Integer, valor As Byte)
On Error GoTo Rutina
OutputReportData(0) = Asc("N") 'cabecera (PWM sfin=N)
OutputReportData(1) = Puerto 'puerto
OutputReportData(2) = valor 'Valor del puerto
'si la escritura del usb falla intentamos capturar el HID
If EscribirUSB = False Then Call DetectarUSB
Exit Sub
Rutina:
MsgBox Error & "... Enviando el parametro de Ancho del PWM"
End Sub
Function CerrarUsb() As Boolean
'Close the open handle to the device.
Result = CloseHandle(HidDevice)
'Free memory used by SetupDiGetClassDevs
Result = SetupDiDestroyDeviceInfoList(DeviceInfoSet)
'Libera el PreparsedData
Result = HidD_FreePreparsedData(PreparsedData)
End Function