usb_to_serial.frm

usb serial converter

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 WriteReport()
'Send data to the device.

Dim Count As Integer
Dim NumberOfBytesRead 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 first byte is the Report ID
SendBuffer(0) = 0
'OutputReportData is used such that data can be formated elsewhere

If CY7C64013 = True Then

'Prepare the data report
SendBuffer(1) = 48  'First byte of OUTput Report = 30h (DTR and RTS = 1)
SendBuffer(2) = 1   'Second byte of OUTput Report = 01h (1 Data Byte to send)
SendBuffer(3) = Combo1.ListIndex

For Count = 4 To Capabilities.OutputReportByteLength - 1
    SendBuffer(Count) = 0
Next Count

End If

If CY7C63743 = True Then

SendBuffer(1) = 49  'First byte of OUTput Report = 30h (DTR and RTS = 1)
SendBuffer(2) = Combo1.ListIndex

For Count = 3 To Capabilities.OutputReportByteLength - 1
    SendBuffer(Count) = 0
Next Count

End If


NumberOfBytesWritten = 0

Result = WriteFile _
    (HidDevice, _
    SendBuffer(0), _
    CLng(Capabilities.OutputReportByteLength), _
    NumberOfBytesWritten, _
    0)

End Sub


Private Sub CmdWrite_Click()

    Connected = FindTheHid
    If Connected = True Then
        LEDResetFlag = True 'Allow for Reset of LEDs If they are clicked
        LEDClickWrite = 0   'Reset LEDWrite Value
        Call WriteReport
        Call LedBank(1)
    End If

End Sub

Private Sub CmdReceive_Click()

    Connected = FindTheHid
    If Connected = True Then
        LEDResetFlag = True 'Allow for Reset of LEDs If they are clicked
        LEDClickWrite = 0   'Reset LEDWrite Value
           'Read a report from the device.
           Call ReadReport
           Call LedBank(2)
    End If
End Sub

Public Sub Form_Unload(Cancel As Integer)

Result = CloseHandle(HidDevice)

Result = SetupDiDestroyDeviceInfoList(DeviceInfoSet)

Result = HidD_FreePreparsedData(PreparsedData)

End Sub

Private Sub Form_Load()

Dim Count As Integer
Dim ByteValue As String
'Create a dropdown list box for each byte to send.

'These are build options.  Since the two parts have different report definitions they need seperate
'Read and Write routines.  Select true for the part build used, and false for the other.
CY7C63743 = False
CY7C64013 = True

For Count = 0 To 255
    If Len(Hex$(Count)) < 2 Then
        ByteValue = "0" & Hex$(Count)
    Else
        ByteValue = Hex$(Count)
    End If
    Combo1.AddItem ByteValue, Count
Next Count

Connected = False
DeviceDetected = False
LEDResetFlag = True     'Allow for Reset of LEDs If they are clicked

'Select a default item for box
Combo1.ListIndex = 0

Text1.BackColor = &H80FFFF
'Automatically Look for specific VID and PID upon loading
MyVendorID = txtVID.Text
MyProductID = txtPID.Text
MyDeviceDetected = FindTheHid()

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.OutputReportByteLength - 1)
    
If CY7C64013 = True Then

Do While (ReadBuffer(2) = 0) 'ReadBuffer(2) is the Second byte of the INput Report and contains # of valid data bytes
'Pass the address of the first byte of the read buffer.
Result = ReadFile _
    (HidDevice, _
    ReadBuffer(0), _
    CLng(Capabilities.OutputReportByteLength), _
    NumberOfBytesRead, _
    0)

If ReadBuffer(2) <> 0 Then  'Again second byte of INput Report. Number of valid data bytes received
'The user will only be able to see the last byte received because of speed.  But this routine shows all.
For Count = 3 To (ReadBuffer(2) + 2) 'Valid data starts at the third byte.
    '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
    ReadValueTemp = (ReadBuffer(Count))
    txtReceived.Text = ByteValue
Next Count
End If

Loop

End If

If CY7C63743 = True Then

Do While ((Hex(ReadBuffer(1)) And Hex(7)) = 0)  'ReadBuffer(1) is the Second byte of the INput Report and contains # of valid data bytes
'Pass the address of the first byte of the read buffer.
Result = ReadFile _
    (HidDevice, _
    ReadBuffer(0), _
    CLng(Capabilities.OutputReportByteLength), _
    NumberOfBytesRead, _
    0)

If ((Hex(ReadBuffer(1)) And Hex(7)) <> 0) Then  'Again second byte of INput Report. Number of valid data bytes received
'The user will only be able to see the last byte received because of speed.  But this routine shows all.
For Count = 2 To ((Hex(ReadBuffer(1)) And Hex(7)) + 1) 'Valid data starts at the second byte.
    '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
    ReadValueTemp = (ReadBuffer(Count))
    txtReceived.Text = ByteValue
Next Count
End If

Loop

End If

End Sub

Private Sub lblLED_Click(Index As Integer)

    If LEDResetFlag = True Then
        Call initGraphics(2)
    End If
    
    LEDResetFlag = False 'Don't want to keep Clearing LEDs while we are setting them
    
    If ((LEDClickWrite And (2 ^ Index)) = 0) Then 'Select an LED
        lblLED(Index).BackColor = &H80FF80
        LEDClickWrite = LEDClickWrite Or 2 ^ Index
        Combo1.ListIndex = LEDClickWrite
    Else 'Allows to unselect an LED
        lblLED(Index).BackColor = &HFFFFFF
        LEDClickWrite = LEDClickWrite And Not (2 ^ Index)
        Combo1.ListIndex = LEDClickWrite
    End If
    
End Sub

Private Sub tmrDelay_Timer()
Timeout = True
tmrDelay.Enabled = False
End Sub

Public Sub LedBank(srcFlag As Integer)

Dim Ledvalue As Integer
Dim Mask As Integer
Dim Lednumber As Integer

Lednumber = 0

'This function is left long and inefficient so that
'for future use it can be called seperately for different
'sources.  Current use could be combined for one call
For Mask = 1 To 255 Step 1
If srcFlag = 1 Then     'Led Routine
    lblLED(Lednumber).BackColor = &HFFFFFF
    Ledvalue = Combo1.ListIndex And Mask
    If Ledvalue <> 0 Then
        lblLED(Lednumber).BackColor = &HFF&
    End If
End If
If srcFlag = 2 Then     'Switch Routine
    lblswitch(Lednumber).Caption = "Open"
    lblswitch(Lednumber).BackColor = &HFFFFC0
    Ledvalue = ReadValueTemp And Mask
    If Ledvalue <> 0 Then
        lblswitch(Lednumber).Caption = "Closed"
        lblswitch(Lednumber).BackColor = &HC0E0FF
    Else
        
    End If
End If
Lednumber = Lednumber + 1
Mask = 2 ^ Lednumber - 1
Next


End Sub

Public Sub initGraphics(LEDorSW As Integer)
Dim Count As Integer

LEDResetFlag = True  'Allow for Reset of LEDs If they are clicked
For Count = 0 To 7 Step 1
    lblLED(Count).BackColor = &HFFFFFF
    
    If (LEDorSW = 1) Then
        lblswitch(Count).Caption = ""
        lblswitch(Count).BackColor = &HFFFFFF
    End If
Next

End Sub

Private Sub Set_Feature_Report()

Dim Count As Integer
Dim NumberOfBytesRead As Long
Dim NumberOfBytesToSend As Long
Dim FeatureBuffer(5) As Byte
Dim FeatureResult As Long

'******************************************************************************
'Set_Feature_Report
'Sends a report to the device on endpoint0.
'Returns: success or failure.
'Requires: the handle returned by CreateFile and
'******************************************************************************

'The first byte is the Report ID
FeatureBuffer(0) = 0

'The Report format is described in the USB to Serial application note
'Sets the device up for 9600 baud, 8-N-1
FeatureBuffer(1) = 128 'Baud Rate
FeatureBuffer(2) = 37  'Baud Rate
FeatureBuffer(3) = 0   'Baud Rate
FeatureBuffer(4) = 0   'Baud Rate
FeatureBuffer(5) = 3   'Word length = 8 bits


NumberOfBytesToSend = 6
    
FeatureResult = HidD_SetFeature _
    (HidDevice, _
     FeatureBuffer(0), _
     CLng(NumberOfBytesToSend))

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)


'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)

'******************************************************************************
'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)


'******************************************************************************
'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)
   



End Sub