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