serial.frm

vb 串口调试助手 源代码

VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.Form SerialFrm 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "串口调试程序"
   ClientHeight    =   5265
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   9780
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   10.5
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "Serial.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5265
   ScaleWidth      =   9780
   StartUpPosition =   2  'CenterScreen
   Begin VB.TextBox chsum 
      Height          =   375
      Left            =   9120
      TabIndex        =   13
      Top             =   4800
      Width           =   615
   End
   Begin VB.Timer Timer1 
      Left            =   4800
      Top             =   3000
   End
   Begin VB.Frame Frame1 
      Height          =   700
      Left            =   120
      TabIndex        =   3
      Top             =   3960
      Width           =   9615
      Begin VB.CheckBox ckOpenClose 
         Caption         =   "开启串口"
         Height          =   375
         Left            =   120
         TabIndex        =   12
         Top             =   240
         Width           =   1215
      End
      Begin VB.TextBox KeepSec 
         Height          =   350
         Left            =   3240
         MaxLength       =   5
         TabIndex        =   10
         Top             =   220
         Width           =   1215
      End
      Begin VB.CheckBox ckAuto 
         Caption         =   "自动发送"
         Height          =   375
         Left            =   1440
         TabIndex        =   8
         Top             =   220
         Width           =   1215
      End
      Begin VB.ComboBox ComBaud 
         Height          =   330
         ItemData        =   "Serial.frx":0442
         Left            =   8040
         List            =   "Serial.frx":044C
         Style           =   2  'Dropdown List
         TabIndex        =   7
         Top             =   240
         Width           =   1335
      End
      Begin VB.ComboBox ComPort 
         Height          =   330
         ItemData        =   "Serial.frx":045D
         Left            =   6000
         List            =   "Serial.frx":047F
         Style           =   2  'Dropdown List
         TabIndex        =   5
         Top             =   240
         Width           =   1215
      End
      Begin VB.Label Label4 
         BackStyle       =   0  'Transparent
         Caption         =   "毫秒"
         Height          =   255
         Left            =   4560
         TabIndex        =   11
         Top             =   300
         Width           =   495
      End
      Begin VB.Label Label3 
         BackStyle       =   0  'Transparent
         Caption         =   "间隔"
         Height          =   255
         Left            =   2760
         TabIndex        =   9
         Top             =   300
         Width           =   495
      End
      Begin VB.Label Label2 
         BackStyle       =   0  'Transparent
         Caption         =   "波特率"
         Height          =   255
         Left            =   7320
         TabIndex        =   6
         Top             =   285
         Width           =   735
      End
      Begin VB.Label Label1 
         BackStyle       =   0  'Transparent
         Caption         =   "串  口"
         Height          =   255
         Left            =   5160
         TabIndex        =   4
         Top             =   300
         Width           =   855
      End
   End
   Begin MSCommLib.MSComm MSComm1 
      Left            =   6360
      Top             =   2400
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      DTREnable       =   -1  'True
   End
   Begin VB.CommandButton sendBtn 
      Caption         =   "发送"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   240
      TabIndex        =   2
      Top             =   4800
      Width           =   975
   End
   Begin VB.TextBox txtSend 
      Height          =   375
      Left            =   1320
      TabIndex        =   1
      Top             =   4800
      Width           =   7695
   End
   Begin VB.TextBox txtRecieve 
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   3855
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   0
      Top             =   120
      Width           =   9615
   End
End
Attribute VB_Name = "SerialFrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Dim setting As String
Dim sendByte As Byte
Dim sendStart As Boolean
Dim temStr As String
Dim firstByte(0) As Byte
Dim sendBytes() As Byte
Dim sendCount As Integer
Dim getBytes() As Byte
Dim getLen As Integer
Dim tmpi As Integer
Dim checkSum As Byte

Private Sub ckAuto_Click()
  If ckAuto.Value = 1 Then
    If KeepSec.Text = "" Then
       KeepSec.Text = 0
       Exit Sub
    End If
   Timer1.Interval = KeepSec
  Else
   Timer1.Interval = 0
  End If
End Sub

Private Sub ckOpenClose_Click()
  
On Error GoTo errStr
   If ckOpenClose.Value = 1 Then
    setting = ComBaud.Text & ",N,8,1"
    MSComm1.CommPort = ComPort.ListIndex + 1
    MSComm1.Settings = setting
    MSComm1.InputMode = comInputModeBinary
    MSComm1.Handshaking = comNone
    MSComm1.OutBufferSize = 1024
    MSComm1.InBufferSize = 512
    MSComm1.InputLen = 0
    MSComm1.SThreshold = 1
    MSComm1.RThreshold = 1
    If Not MSComm1.PortOpen Then
      MSComm1.PortOpen = True
    End If
   Else
    If MSComm1.PortOpen Then
      MSComm1.PortOpen = False
    End If
   End If
   Exit Sub
errStr:
   If Err.Number = 8002 Then
     MsgBox "串口不存在！", vbOKOnly Or vbInformation
   ElseIf Err.Number = 8005 Then
     MsgBox "串口已打开！", vbOKOnly Or vbInformation
   End If
   ckOpenClose.Value = 0
End Sub


Private Sub ComPort_Click()
 If ckOpenClose.Value = 1 Then
   If MSComm1.PortOpen Then
      MSComm1.PortOpen = False
    End If
    setting = ComBaud.Text & ",N,8,1"
    MSComm1.CommPort = ComPort.ListIndex + 1
    MSComm1.Settings = setting
    MSComm1.InputMode = comInputModeBinary
    MSComm1.Handshaking = comNone
    MSComm1.OutBufferSize = 1024
    MSComm1.InBufferSize = 512
    MSComm1.InputLen = 0
    MSComm1.SThreshold = 1
    MSComm1.RThreshold = 1
    If Not MSComm1.PortOpen Then
      MSComm1.PortOpen = True
    End If
  End If
End Sub

Private Sub Form_Load()
  ComPort.ListIndex = 0
  ComBaud.ListIndex = 0
  sendStart = True
  Me.BackColor = RGB(150, 183, 208)
  Frame1.BackColor = RGB(150, 183, 208)
  ckOpenClose.BackColor = RGB(150, 183, 208)
  ckAuto.BackColor = RGB(150, 183, 208)
End Sub

Private Sub KeepSec_Change()
   If KeepSec.Text = "" Then
     Exit Sub
   End If
   If InStr("0123456789", Right(KeepSec.Text, 1)) <= 0 Then
     KeepSec.Text = Left(KeepSec.Text, Len(KeepSec.Text) - 1)
     KeepSec.SelStart = Len(KeepSec.Text)
   End If
   If (Left(KeepSec.Text, 1) = 0) And Len(KeepSec.Text) > 1 Then
      KeepSec.Text = Right(KeepSec.Text, Len(KeepSec.Text) - 1)
      KeepSec.SelStart = Len(KeepSec.Text)
   End If
   If (ckAuto.Value = 1) And (Val(KeepSec.Text) > 0) Then
      Timer1.Interval = KeepSec
   End If
End Sub

Private Sub MSComm1_OnComm()
   Select Case MSComm1.CommEvent
   ' Handle each event or error by placing
   ' code below each case statement
' 错误
      Case comEventBreak   ' 收到 Break。
       Case comEventCDTO   ' CD (RLSD) 超时。
      Case comEventCTSTO   ' CTS Timeout。
      Case comEventDSRTO   ' DSR Timeout。
      Case comEventFrame   ' Framing Error
      Case comEventOverrun   '数据丢失。
      Case comEventRxOver '接收缓冲区溢出。
      Case comEventRxParity ' Parity 错误。
      Case comEventTxFull   '传输缓冲区已满。
      Case comEventDCB   '获取 DCB] 时意外错误
   ' 事件
      Case comEvCD   ' CD 线状态变化。
      Case comEvCTS   ' CTS 线状态变化。
      Case comEvDSR   ' DSR 线状态变化。
      Case comEvRing   ' Ring Indicator 变化。
      Case comEvReceive   ' 收到 RThreshold # ofchars.
      
             getLen = MSComm1.InBufferCount
             getBytes = MSComm1.Input
          For tmpi = 0 To getLen - 1
            txtRecieve.Text = Trim(txtRecieve.Text) & " " & IIf(Len(Hex$(getBytes(tmpi))) > 1, Hex$(getBytes(tmpi)), "0" & Hex$(getBytes(tmpi)))
          Next tmpi
      Case comEvSend   ' 传输缓冲区有 Sthreshold 个字符                         '
      Case comEvEOF   ' 输入数据流中发现 EOF 字符
    End Select

End Sub

Private Sub sendBtn_Click()
  If Not MSComm1.PortOpen Then
    MsgBox "串口没有打开！", vbOKOnly Or vbInformation, "提示信息"
    Timer1.Interval = 0
    ckAuto.Value = 0
    Exit Sub
  End If
  If Trim(txtSend.Text) = "" Then
    Exit Sub
  End If
  checkSum = 0
  txtSend.Text = Trim(txtSend.Text)
  If Len(Trim(Right(txtSend.Text, 2))) < 2 Then
     txtSend.Text = Left(txtSend.Text, Len(txtSend.Text) - 1) & "0" & Right(txtSend.Text, 1)
  End If

  ReDim sendBytes(0 To (Len(Trim(txtSend.Text)) - 1) / 3)
  For sendCount = 0 To (Len(Trim(txtSend.Text)) - 1) / 3
     sendBytes(sendCount) = Val("&H" & Mid(txtSend.Text, sendCount * 3 + 1, 2))
  Next sendCount
    chsum.Text = Hex$(checkSum)
    MSComm1.Output = sendBytes
End Sub



Private Sub Timer1_Timer()
  Call sendBtn_Click
End Sub

Private Sub txtSend_Change()
  
   If txtSend.Text = "" Then
     Exit Sub
   End If
   If InStr("0123456789abcedfABCDEF ", Right(txtSend.Text, 1)) <= 0 Then
     txtSend.Text = Left(txtSend.Text, Len(txtSend.Text) - 1)
     txtSend.SelStart = Len(txtSend.Text)
   End If
   Select Case Right(txtSend.Text, 1)
     Case "a"
            txtSend.Text = Left(txtSend.Text, Len(txtSend.Text) - 1) & "A"
            txtSend.SelStart = Len(txtSend.Text)

     Case "b"
            txtSend.Text = Left(txtSend.Text, Len(txtSend.Text) - 1) & "B"
            txtSend.SelStart = Len(txtSend.Text)
    
     Case "c"
            txtSend.Text = Left(txtSend.Text, Len(txtSend.Text) - 1) & "C"
            txtSend.SelStart = Len(txtSend.Text)
 
     Case "d"
            txtSend.Text = Left(txtSend.Text, Len(txtSend.Text) - 1) & "D"
            txtSend.SelStart = Len(txtSend.Text)

     Case "e"
            txtSend.Text = Left(txtSend.Text, Len(txtSend.Text) - 1) & "E"
            txtSend.SelStart = Len(txtSend.Text)

     Case "f"
            txtSend.Text = Left(txtSend.Text, Len(txtSend.Text) - 1) & "F"
            txtSend.SelStart = Len(txtSend.Text)

    End Select
     
'   If (Left(txtSend.Text, 1) = 0) And Len(txtSend.Text) > 1 Then
'      txtSend.Text = Right(txtSend.Text, Len(txtSend.Text) - 1)
'      txtSend.SelStart = Len(txtSend.Text)
'   End If
   If Right(txtSend.Text, 2) = "  " Then
      txtSend.Text = Left(txtSend.Text, Len(txtSend.Text) - 1)
      txtSend.SelStart = Len(txtSend.Text)
      Exit Sub
   End If
   If Len(txtSend.Text) < 2 Then
    Exit Sub
   End If
   If Right(txtSend.Text, 1) = " " Then
     If Len(txtSend.Text) = 2 Then
        txtSend.Text = "0" & txtSend.Text
        txtSend.SelStart = Len(txtSend.Text)
        Exit Sub
     End If
     If Len(Trim(Mid(txtSend.Text, Len(txtSend.Text) - 2, 2))) < 2 Then
        temStr = "0" & Mid(txtSend.Text, Len(txtSend.Text) - 1, 1) & " "
        txtSend.Text = Left(txtSend.Text, Len(txtSend.Text) - 2) & temStr
        txtSend.SelStart = Len(txtSend.Text)
     End If
   End If
   If Len(txtSend.Text) < 3 Then
     Exit Sub
   End If
   If Len(Trim(Right(txtSend.Text, 3))) > 2 Then
     txtSend.Text = Trim(Left(txtSend.Text, Len(txtSend.Text) - 1)) & " " & Right(txtSend.Text, 1)
     txtSend.SelStart = Len(txtSend.Text)
   End If
   
End Sub