frmmaim.frm

vb编写的串口调试助手1.0的源码。值得大家参考和研究。

         Left            =   240
         TabIndex        =   6
         Top             =   240
         Width           =   420
      End
   End
End
Attribute VB_Name = "frmmain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub Check1_Click()
If Check1.Value = 1 Then
intTime = Val(Text3.Text)
Timer1.Interval = intTime
Timer1.Enabled = True
Else
Timer1.Enabled = False
End If
End Sub

Private Sub Combo1_Click()

If Combo1.ListIndex + 1 <> com_last_num Then            '选的端口跟上次一样就不检测了
    
    '先关闭上一个打开的端口
    If com_last_open_num <> 0 Then
    MSComm1.PortOpen = False
    End If

    If Test_COM(Combo1.ListIndex + 1) = True Then
    Command1.Caption = "关闭端口"
    Shape1.FillColor = RGB(0, 255, 0)
    If Combo3.Text = "无校验" Then
    jiaoyan = "N"
    ElseIf Combo3.Text = "奇校验" Then
    jiaoyan = "O"
    ElseIf Combo3.Text = "偶校验" Then
    jiaoyan = "E"
    End If
    com_setting = Combo2.Text + "," + jiaoyan + "," + Combo4.Text + "," + Combo5.Text
    'Text1.Text = com_setting
    initial_com (Combo1.ListIndex + 1)
    com_last_open_num = Combo1.ListIndex + 1
    Else
    Command1.Caption = "打开端口"
    Shape1.FillColor = RGB(0, 0, 0)
    com_last_open_num = 0                              '哈哈，注意此处要清零
    End If
    
    com_last_num = Combo1.ListIndex + 1
End If
End Sub

Private Sub Command1_Click()
If Command1.Caption = "关闭端口" Then
MSComm1.PortOpen = False
Command1.Caption = "打开端口"
Shape1.FillColor = RGB(0, 0, 0)
com_last_open_num = 0
Else
    If Test_COM(Combo1.ListIndex + 1) = True Then
        MSComm1.PortOpen = True
        Command1.Caption = "关闭端口"
        Shape1.FillColor = RGB(0, 255, 0)
    End If
End If
End Sub

'手动发送按钮'
Private Sub Command2_Click()
  Call Timer1_Timer
End Sub

Private Sub Command4_Click()
Text1.Text = ""
End Sub

Private Sub Form_Load()
  '界面初始化'
  Combo1.Text = "COM1"
  Combo2.Text = "9600"
  Combo3.Text = "无校验"
  Combo4.Text = "8"
  Combo5.Text = "1"
  Option2.Value = True
  Option4.Value = True
  Text3.Text = "1000"
  
  '初始化变量'
  com_last_num = 0                '上一个串口号为1
  Check1.Value = 0                '不然会自动发送

  If Test_COM(1) = True Then
    Command1.Caption = "关闭端口"
    Shape1.FillColor = RGB(0, 255, 0)
    com_setting = "9600,N,8,1"
    com_last_open_num = 1            '表示有端口1打开了
    initial_com (1)
  Else
    Command1.Caption = "打开端口"
    Shape1.FillColor = RGB(0, 0, 0)
    com_last_open_num = 0            '表示没有端口打开
  End If
  com_last_num = 1
End Sub

'检测端口号函数'
Private Function Test_COM(com_num As Integer) As Boolean

  If com_num <> com_last_num Or Command1.Caption = "打开端口" Then  '选的端口跟上次一样就不检测了
    On Error GoTo Comm_Error
    MSComm1.CommPort = com_num                                '这里接收传入的串口号
    MSComm1.PortOpen = True
    MSComm1.PortOpen = False
    Test_COM = True                                           '如果操作成功，则说明当前串口可用，返回1，表示串口可用
    Exit Function
Comm_Error:
    If Err.Number = 8002 Then
      MsgBox "串口不存在！"
    ElseIf Err.Number = 8005 Then
      MsgBox "串口已打开！"
    Else
      MsgBox "其它错误"
    End If
    Test_COM = False                                              '如果出错，则返回0
    Exit Function
    Resume Next
  End If
End Function

'端口初始化子程序'
Private Sub initial_com(com_num As Integer)

  MSComm1.CommPort = com_num
  MSComm1.OutBufferSize = 1024
  MSComm1.InBufferSize = 1024
  MSComm1.InputMode = 1
  MSComm1.InputLen = 0
  MSComm1.InBufferCount = 0
  MSComm1.SThreshold = 1
  MSComm1.RThreshold = 1
  MSComm1.Settings = com_setting
  MSComm1.PortOpen = True
End Sub

'**********************************
'字符表示的十六进制数转化为相应的整数
'错误则返回  -1
'**********************************

Function ConvertHexChr(str As String) As Integer
    
    Dim test As Integer
    
    test = Asc(str)
    If test >= Asc("0") And test <= Asc("9") Then
        test = test - Asc("0")
    ElseIf test >= Asc("a") And test <= Asc("f") Then
        test = test - Asc("a") + 10
    ElseIf test >= Asc("A") And test <= Asc("F") Then
        test = test - Asc("A") + 10
    Else
        test = -1                                       '出错信息
    End If
    ConvertHexChr = test
End Function


'**********************************
'字符串表示的十六进制数据转化为相应的字节串
'返回转化后的字节数
'**********************************

Function strHexToByteArray(strText As String, bytByte() As Byte) As Integer
    
    Dim HexData As Integer          '十六进制(二进制)数据字节对应值
    Dim hstr As String * 1          '高位字符
    Dim lstr As String * 1          '低位字符
    Dim HighHexData As Integer      '高位数值
    Dim LowHexData As Integer       '低位数值
    Dim HexDataLen As Integer       '字节数
    Dim StringLen As Integer        '字符串长度
    Dim Account As Integer          '计数
        
    strTestn = ""                   '设初值
    HexDataLen = 0
    strHexToByteArray = 0
    
    StringLen = Len(strText)
    Account = StringLen \ 2
    ReDim bytByte(Account)
    
    For n = 1 To StringLen
    
        Do                                              '清除空格
            hstr = Mid(strText, n, 1)
            n = n + 1
            If (n - 1) > StringLen Then
                HexDataLen = HexDataLen - 1
                
                Exit For
            End If
        Loop While hstr = " "
        
        Do
            lstr = Mid(strText, n, 1)
            n = n + 1
            If (n - 1) > StringLen Then
                HexDataLen = HexDataLen - 1
                
                Exit For
            End If
        Loop While lstr = " "
        n = n - 1
        If n > StringLen Then
            HexDataLen = HexDataLen - 1
            Exit For
        End If
        
        HighHexData = ConvertHexChr(hstr)
        LowHexData = ConvertHexChr(lstr)
        
        If HighHexData = -1 Or LowHexData = -1 Then     '遇到非法字符中断转化
            HexDataLen = HexDataLen - 1
            
            Exit For
        Else
            
            HexData = HighHexData * 16 + LowHexData
            bytByte(HexDataLen) = HexData
            HexDataLen = HexDataLen + 1
        End If
                        
    Next n
    
    If HexDataLen > 0 Then                              '修正最后一次循环改变的数值
        HexDataLen = HexDataLen - 1
        ReDim Preserve bytByte(HexDataLen)
    Else
        ReDim Preserve bytByte(0)
    End If
    
    If StringLen = 0 Then                               '如果是空串,则不会进入循环体
        strHexToByteArray = 0
    Else
        strHexToByteArray = HexDataLen + 1
    End If
    
End Function

Private Sub Label10_Click()
ShellExecute Me.hwnd, "open", "http://jiangping.21ic.org", "", "", 5
End Sub

Private Sub Text2_DblClick()
  Text2 = ""
End Sub

Private Sub Timer1_Timer()
  Dim longth As Integer
    
  If Option3.Value = True Then
    intOutMode = 1
  Else
    intOutMode = 0
  End If
    
  strSendText = Text2.Text
    
  If intOutMode = 0 Then
    MSComm1.Output = strSendText & vbCr
  Else
    longth = strHexToByteArray(strSendText, bytSendByte())
    If longth > 0 Then
      MSComm1.Output = bytSendByte
    End If
  End If
End Sub

Private Sub MSComm1_OnComm()
  
  Dim bytInput() As Byte
  Dim intInputLen As Integer
  Dim n As Integer
  Dim teststring As String
    
  Select Case MSComm1.CommEvent
    Case comEvReceive
      If Option1.Value = True Then
        MSComm1.InputMode = 1                    '0：文本方式，1：二进制方式
      Else
        MSComm1.InputMode = 0                    '0：文本方式，1：二进制方式
      End If
            
      intInputLen = MSComm1.InBufferCount
      bytInput = MSComm1.Input
            
      If Option1.Value = True Then
        For n = 0 To intInputLen - 1
          Text1.Text = Trim(Text1.Text) & " " & IIf(Len(Hex$(bytInput(n))) > 1, Hex$(bytInput(n)), "0" & Hex$(bytInput(n)))
        Next n
      Else
        teststring = bytInput
        Text1.Text = Text1.Text + teststring
      End If
  End Select
    
End Sub