frmmain.frm

VB写的串口通信

      TabIndex        =   26
      Top             =   1470
      Width           =   855
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'   File:
'       frmMain.frm
'   Author:
'       Tom DeWitt
'   Description:
'       This program was designed as a utility tool to allow the user to send and recieve data from a serial com port
'while monitory the byte data. If a loopback ciruit is made on the com port(jumper send to recieve DB9 pins 2 & 3)
'a developer can also monitor the way VB interprets the data that is being sent or recieved. The port settings can be
'configured as desired and the last setting are stored in the registry under the Key 'HKEY_LOCAL_MACHINE\Software\
'Damage Inc\Com Settings'. The Input Mode Property Defaults to binary. It was not designed to poll the com port or use
'handshaking with a device, it was intended to send data to a device and then read the devices response as a simple
'tool. The code maybe modified as desired and may be freely redistributed. I hold no responsiblity for the way it is
'used. It has been tested on Windows NT 4.0 SrvPk 6a and on Windows 2000 SrvPk 2. It was developed under VB6 SrvPk 5.
'As the author of the code I may not have tested all possible user misuse and abuse, as I only know what my intentions
'for the code were, not how it could possibly be used. It was not tested as a beta release.
'-----------------------------------------------------------------------------------------------------------------------
'   Revisions:
'       Original 2/7/2002
'-----------------------------------------------------------------------------------------------------------------------
'   Functions And Subroutines:
'   1.  BitOn(Number As Long, Bit As Long) As Boolean
'           Performs Bitwise Check on 'Number', Returns True if 'Bit' is On
'   2. VerifyPorts() Checks The Registry Entries For The ComPorts On The Current System
'   3. UpdateBaud() Changes The ComPort's Baud Rate And Calls The UpdateSettings() Sub To Update The Registry
'   4. VerifySettings() Check The Registry For The ComPorts Last Settings. If There is No Registry Entry It Creates One
'       And Places The Default(Com1 38400,n,8,1) Setting in The Registry. If There Is An Entry It Sets The ComPort.
'   5.UpdateSettings() Changes The Registry Entry When The User Chages The Com Port Or Settings. It Does Not Update The
'       InputMode which Defaults To Binary.
'-----------------------------------------------------------------------------------------------------------------------
'   Properties:
'-----------------------------------------------------------------------------------------------------------------------
'   Required Functions,Subroutines,Properties,Variables,Etc.:
'
'-----------------------------------------------------------------------------------------------------------------------
'   Variables:
'       Public:
'
'-----------------------------------------------------------------------------------------------------------------------
'       Private:
Private bLoaded As Boolean  'True After Form Is Loaded --> Enables Option Button Click Events
Private sDataBits As String
Private sMode As String
Private BaudRate(12) As String
Private Ports() As Variant
Private sBaudData As String
Private sSubKey As String
Private sKeyValue As String
Private sSettings As String
Private sPortNum As String
Private hnd As Long
'-----------------------------------------------------------------------------------------------------------------------
'       Constants:
Private Const lMainKey As Long = HKEY_LOCAL_MACHINE
Private Const lLength As Long = 1024
Private Const sSettingsKey As String = "Settings"
Private Const sPortKey As String = "Port"
'-----------------------------------------------------------------------------------------------------------------------
'       Special Notes:
'           Printing Line Length is 120 Characters
'-----------------------------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------------------------
'       Enumeration Constants:
'-----------------------------------------------------------------------------------------------------------------------
'Initialize The BaudRate Array As Set Values ie Make Shift Constants
'---------------------------------------------------------START---------------------------------------------------------
Private Sub Form_Initialize()
    BaudRate(0) = "110"
    BaudRate(1) = "300"
    BaudRate(2) = "600"
    BaudRate(3) = "1200"
    BaudRate(4) = "2400"
    BaudRate(5) = "9600"
    BaudRate(6) = "14400"
    BaudRate(7) = "19200"
    BaudRate(8) = "28800"
    BaudRate(9) = "38400"
    BaudRate(10) = "56000"
    BaudRate(11) = "128000"
    BaudRate(12) = "256000"
End Sub
'----------------------------------------------------------END----------------------------------------------------------
'---------------------------------------------------------START---------------------------------------------------------
Private Sub cmbBaudRate_Click()
        sBaudData = ""
        cmdUpdateBaud.Enabled = True
End Sub
'----------------------------------------------------------END----------------------------------------------------------
'Monitor Keyboard Input While Editing Baud Rate
'---------------------------------------------------------START---------------------------------------------------------
Private Sub cmbBaudRate_KeyPress(KeyAscii As Integer)
        Select Case KeyAscii
            Case 48, 49, 50, 51, 52, 53, 54, 55, 56, 57                         'Allow Only Numbers
                sBaudData = sBaudData & Chr$(KeyAscii)
            Case 13                                                             'Enter Pressed
                sBaudData = ""
                UpdateBaud
            Case 127                                                            'Delete Key Pressed
                sBaudData = ""
            Case 8                                                              'Backspace Key Pressed
                If sBaudData <> "" Then
                    sBaudData = Left$(sBaudData, (Len(sBaudData) - 1))
                End If
            Case Else
                sBaudData = ""
        End Select
End Sub
'----------------------------------------------------------END----------------------------------------------------------
'Auto Fill Allowable Baud Rates
'---------------------------------------------------------START---------------------------------------------------------
Private Sub cmbBaudRate_Change()
    Dim iX As Long
    Dim iL As Long
    Dim sCurrent As String

        If bLoaded Then
            cmdUpdateBaud.Enabled = True
            sCurrent = sBaudData
            iL = Len(sCurrent)
                For iX = 0 To 12
                    If sCurrent = Left$(BaudRate(iX), iL) Then
                        cmbBaudRate.Text = BaudRate(iX)
                        cmbBaudRate.SelLength = Len(cmbBaudRate.Text)
                        Exit Sub
                    End If
                Next
        End If
End Sub
'----------------------------------------------------------END----------------------------------------------------------
'---------------------------------------------------------START---------------------------------------------------------
Private Sub cmdUpdateBaud_Click()
        UpdateBaud
End Sub
'----------------------------------------------------------END----------------------------------------------------------
'Check If The Requested Bit Is 'On' In The Given Number
'---------------------------------------------------------START---------------------------------------------------------
Function BitOn(Number As Long, Bit As Long) As Boolean
    Dim iX As Long
    Dim iY As Long

        iY = 1
        For iX = 1 To Bit - 1
            iY = iY * 2
        Next
        If Number And iY Then BitOn = True Else BitOn = False
End Function
'----------------------------------------------------------END----------------------------------------------------------
'Open The Local Machine Registry And Get The Serial Ports Available On The Local Machine, Validate Selected Port
'---------------------------------------------------------START---------------------------------------------------------
Private Sub VerifyPorts()
    Dim sPort As String
    Dim iX As Long
    Dim iY As Long
    Dim lngType As Long
    Dim lngValue As Long
    Dim sName As String
    Dim sSwap As String
    ReDim varResult(0 To 1, 0 To 100) As Variant
    Const lNameLen As Long = 260
    Const lDataLen As Long = 4096

        sSubKey = "Hardware\Devicemap\SerialComm"
        If RegOpenKeyEx(lMainKey, sSubKey, 0, KEY_READ, hnd) Then Exit Sub
            For iX = 0 To 999999
                If iX > UBound(varResult, 2) Then
                    ReDim Preserve varResult(0 To 1, iX + 99)
                End If
                sName = Space$(lNameLen)
                ReDim binValue(0 To lDataLen - 1) As Byte
                If RegEnumValue(hnd, iX, sName, lNameLen, ByVal 0&, lngType, binValue(0), lDataLen) Then Exit For
                    varResult(0, iX) = Left$(sName, lNameLen)
                    
                    Select Case lngType
                        Case REG_DWORD
                            CopyMemory lngValue, binValue(0), 4
                            varResult(1, iX) = lngValue
                        Case REG_SZ
                            varResult(1, iX) = Left$(StrConv(binValue(), vbUnicode), lDataLen - 1)
                        Case Else
                            ReDim Preserve binValue(0 To lDataLen - 1) As Byte
                            varResult(1, iX) = binValue()
                    End Select
            Next
        If hnd Then RegCloseKey hnd                                             'Close The Registry Key
        ReDim Preserve varResult(0 To 1, iX - 1) As Variant
        ReDim Ports(iX - 1)
        For iX = 0 To UBound(varResult, 2)                                      'Trim 'Port' To Get Just The Number
            sPort = Mid$(varResult(1, iX), 4, 1)
            Ports(iX) = sPort
        Next

        iY = UBound(Ports)                                                       'Arrange The Ports Numbers Low To High
        For iX = 0 To (iY - 1)
            If Ports(iX + 1) < Ports(iX) Then
                sSwap = Ports(iX + 1)
                Ports(iX + 1) = Ports(iX)
                Ports(iX) = sSwap
                iX = -1
            End If
        Next

End Sub
'----------------------------------------------------------END----------------------------------------------------------
'Changes The ComPorts Baud Rate
'---------------------------------------------------------START---------------------------------------------------------
Private Sub UpdateBaud()
Attribute UpdateBaud.VB_Description = "Changes the baud rate of the serial port"
    Dim sNewBaud As String
    Dim sOldBaud As String
    Dim sTmp As String
    Dim iX As Long
    
On Error GoTo ErrTrap

        sNewBaud = cmbBaudRate.Text
        For iX = 0 To 12
            If BaudRate(iX) = sNewBaud Then
                Exit For
            Else
                If iX = 12 Then
                    MsgBox "Invalid Baud Rate, Please Try Again !", vbInformation, "Data Entry Error !"
                    sBaudData = ""
                    cmbBaudRate.Text = ""
                    cmdUpdateBaud.Enabled = False
                    Exit Sub
                End If
            End If
        Next
        sTmp = comSerial.Settings
        sOldBaud = Left$(sTmp, (InStr(1, sTmp, ",", vbBinaryCompare) - 1))
        sTmp = Replace(sTmp, sOldBaud, sNewBaud, , , vbBinaryCompare)
        comSerial.Settings = sTmp
        cmdUpdateBaud.Enabled = False
        sBaudData = ""
        UpdateSettings
    Exit Sub

ErrTrap:
        MsgBox Err.Number & " " & Err.Description & vbCr & " Error Generated By " & Err.Source, vbCritical, _
"System Error Trap !"
End Sub
'----------------------------------------------------------END----------------------------------------------------------
'---------------------------------------------------------START---------------------------------------------------------
Private Sub cmdExit_Click()
    Unload Me
    Set frmMain = Nothing
End Sub
'----------------------------------------------------------END----------------------------------------------------------
'Read Input Data Then Display In The txtRead Box
'---------------------------------------------------------START---------------------------------------------------------
Private Sub cmdRead_Click()
    Dim bytInput() As Byte
    Dim bytElement As Byte
    Dim iX As Long
    Dim iY As Long
    Dim iL As Long
    Dim iP As Long
    Dim sResult As String
    Dim sHistory As String
    Dim sData As String
    Dim sSpace As String

On Error GoTo ErrTrap

        If comSerial.PortOpen = False Then
            comSerial.PortOpen = True
        End If

        bytInput = comSerial.Input                                              'Read The Input and Get Its Size
        iX = UBound(bytInput(), 1)