form1.frm

一个简单易用的串口调试工具.全api完成.

Option Explicit
Public Scom As SerialPort
Dim ScomX As New SerialPort
Public Ret As Long
Dim cd As clsCommDlg
Private Declare Function HideCaret Lib "user32" (ByVal hWnd As Long) As Long

Private Sub Check1_Click()
Dim i As Integer
Dim strtemp As String
If Check1.Value = 1 Then
strtemp = ""
For i = 1 To Len(Text2.Text)
If Len(strtemp) > 0 Then
strtemp = strtemp & Hex(Asc(Mid(Text2.Text, i, 1))) & " "
Else
strtemp = strtemp & Hex(Asc(Mid(Text2.Text, i, 1))) & " "
End If
Next
Text2.Text = strtemp
Else
strtemp = ""
For i = 1 To Len(Text2.Text) Step 3
If Len(strtemp) > 0 Then
strtemp = strtemp & Chr(HEXtoDEC(Mid(Text2.Text, i, 2)))
Else
strtemp = strtemp & Chr(HEXtoDEC(Mid(Text2.Text, i, 2)))
End If
Next
Text2.Text = strtemp
End If
End Sub

Private Sub Check2_Click()
If Check2.Value = 1 Then
Text1.Enabled = False
Text3.Enabled = True
Else
Text1.Enabled = True
Text3.Enabled = False
End If
End Sub

Private Sub Check4_Click()
If Check4.Value = 1 Then
Timer2.Interval = Text4.Text
Timer2.Enabled = True
Else
Timer2.Enabled = False
End If
End Sub

Private Sub Command1_Click()
Dim strCommSetting As String
Dim intPortNo As Long
Dim strParity As String
Select Case Combo5.Text
  Case "NONE"
   strParity = "n"
  Case "EVEN"
   strParity = "e"
  Case "ODD"
   strParity = "o"
 End Select
strCommSetting = Combo2.Text & "," & strParity & "," & Combo3.Text & "," & Combo4.Text
intPortNo = Mid(Combo1.Text, 4, 1)
If Command1.Caption = "打开端口" Then
Ret = ScomX.OpenPort(intPortNo, strCommSetting, 1024, 512)
If Ret <> 0 Then
MsgBox "设备可能正在被占用!", , "运行提示"
ScomX.ClosePort
Else
Shape1.BackColor = vbGreen
Combo1.Enabled = False
Combo2.Enabled = False
Combo3.Enabled = False
Combo4.Enabled = False
Combo5.Enabled = False
Command1.Caption = "关闭端口"
End If
Else
Command1.Caption = "打开端口"
Command3.Caption = "接收(&R)"
ScomX.ClosePort
Shape1.BackColor = vbRed
Shape2.BackColor = vbRed
Timer1.Enabled = False
Combo1.Enabled = True
Combo2.Enabled = True
Combo3.Enabled = True
Combo4.Enabled = True
Combo5.Enabled = True
End If
End Sub

Private Sub Command2_Click()
Dim Arr(255) As Byte
Dim InSize As Long
Dim X As Long
Dim E As Long
If Command1.Caption = "打开端口" Then
 MsgBox "请先打开端口再发送数据!", , " 程序提示"
 Else
For X = 1 To Len(Text1.Text)
  Arr(X - 1) = Asc(Mid(Text1.Text, X, 1))
  Next X
InSize = Len(Text1.Text)
E = ScomX.SendData(Arr, InSize)
If Check2.Value = 0 Then
  Text6.Text = "TX:" & Val(Mid(Text6.Text, 4, Len(Text6.Text) - 3)) + Len(Text1.Text)
Else
  Text6.Text = "TX:" & Val(Mid(Text6.Text, 4, Len(Text6.Text) - 3)) + Len(Text3.Text) * 2 / 3
    End If
End If
End Sub
Private Sub Command3_Click()
If Command1.Caption = "打开端口" Then
MsgBox "请先打开端口再接收数据!", , " 程序提示"
Exit Sub
End If
If Command3.Caption = "接收(&R)" Then
Timer1.Enabled = True
Command3.Caption = "停止(&S)"
Else
Timer1.Enabled = False
Command3.Caption = "接收(&R)"
Shape2.BackColor = vbRed
End If
End Sub

Private Sub Command4_Click()
ScomX.ClosePort
Unload Me
End Sub

Private Sub Command5_Click()
Text2.Text = ""
End Sub

Private Sub Command6_Click()
Text5.Text = "RX:0"
Text6.Text = "WX:0"
End Sub

Private Sub Command7_Click()
On Error Resume Next
Set cd = New clsCommDlg
With cd
    .DialogTitle = "打开文件"
    .Style = 5
    .Filter2 = TXT + All
    .CancelError = True
    .InitDir = App.Path
    .FileName = "  文件名:(&N)"
   End With
   Text7.Text = cd.ShowOpen(Me)
End Sub
Private Sub Command8_Click()
If Shape1.BackColor = vbGreen Then
If Text7.Text = "" Or Dir(Text7.Text) = "" Then
MsgBox "请选择正确的文件名!", , " 程序提示"
Else
Call FiletoSeg(Text7.Text, 100)
End If
Else
MsgBox "请先打开串口,再发送文件!", , " 程序提示"
End If
End Sub

Private Sub Form_Load()
Windows Me
Shape1.BackColor = vbRed
Shape2.BackColor = vbRed
Combo1.AddItem "COM1"
Combo1.AddItem "COM2"
Combo1.AddItem "COM3"
Combo1.AddItem "COM4"
Combo1.ListIndex = 0
Combo2.AddItem "110"
Combo2.AddItem "300"
Combo2.AddItem "1200"
Combo2.AddItem "2400"
Combo2.AddItem "4800"
Combo2.AddItem "9600"
Combo2.AddItem "19200"
Combo2.AddItem "38400"
Combo2.AddItem "57600"
Combo2.AddItem "115200"
Combo2.AddItem "230400"
Combo2.AddItem "460800"
Combo2.AddItem "921600"
Combo3.AddItem "5"
Combo3.AddItem "6"
Combo3.AddItem "7"
Combo3.AddItem "8"
Combo4.AddItem "1"
Combo4.AddItem "1.5"
Combo4.AddItem "2"
Combo5.AddItem "NONE"
Combo5.AddItem "ODD"
Combo5.AddItem "EVEN"
Combo2.ListIndex = 5
Combo3.ListIndex = 3
Combo4.ListIndex = 0
Combo5.ListIndex = 0
Text3.Text = "77 67 6B 69 6E 67 40 31 32 36 2E 63 6F 6D "
Text3.Enabled = False
Text4.Text = 1000
Text5.Text = "RX:0"
Text6.Text = "TX:0"
HideCaret Text5.hWnd
HideCaret Text6.hWnd
HideCaret Text1.hWnd
Text1.SelStart = Len(Text1.Text)
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Shape3.Visible = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
ScomX.ClosePort
End Sub

Private Sub Frame2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Shape3.Visible = False
End Sub

Private Sub Image1_Click()
frmAbout.Show
Shape3.Visible = False
End Sub

Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Shape3.Visible = True
End Sub

Private Sub Label9_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Shape3.Visible = False
End Sub

Private Sub Text1_Change()
Dim i As Integer
Dim strtemp As String
strtemp = ""
For i = 1 To Len(Text1.Text)
If Len(strtemp) > 0 Then
strtemp = strtemp & Hex(Asc(Mid(Text1.Text, i, 1))) & " "
Else
strtemp = strtemp & Hex(Asc(Mid(Text1.Text, i, 1))) & " "
End If
Next
Text3.Text = strtemp
End Sub
Private Sub Text2_GotFocus()
HideCaret Text2.hWnd
End Sub

Private Sub Text3_Change()
Dim X As Integer
Dim strtemp As String
strtemp = ""
 If Len(Text3.Text) Mod 3 = 0 Then
For X = 1 To Len(Text3.Text) Step 3
   strtemp = strtemp & Chr(HEXtoDEC(Mid(Text3.Text, X, 2)))
Next
Text3.SelStart = Len(Text3.Text)
Text1.Text = strtemp
Else
Exit Sub
End If
End Sub

Private Sub Text3_GotFocus()
HideCaret Text3.hWnd
End Sub

Private Sub Text5_GotFocus()
HideCaret Text5.hWnd
End Sub


Private Sub Text6_GotFocus()
HideCaret Text6.hWnd
End Sub

Private Sub Timer1_Timer()
 Dim s As Long
 Timer1.Enabled = False
 Dim Arr() As Byte
 Dim OutSize As Long
 Dim i As Integer
 Dim X As Long
 Dim strtemp As String
 Dim strPath$
 strPath = Text7.Text
If strPath = "" Then
 s = 1024
 Else
 s = FileLen(Text7.Text)
 End If
 ReDim Arr(s) As Byte
  OutSize = ScomX.ReadData(Arr, s, 100)
 If Shape2.BackColor = vbRed Then
  Shape2.BackColor = vbGreen
   Else
  Shape2.BackColor = vbRed
  End If
   For X = 0 To OutSize - 1
    Debug.Print Chr(Arr(X))
    If Check1.Value = 0 Then
    Text2.Text = Text2.Text & Chr(Arr(X))
    Else
strtemp = ""
For i = 1 To Len(Chr(Arr(X)))
If Len(strtemp) > 0 Then
strtemp = strtemp & Hex(Asc(Mid(Chr(Arr(X)), i, 1))) & " "
Else
strtemp = strtemp & Hex(Asc(Mid(Chr(Arr(X)), i, 1))) & " "
End If
Next i
    
    Text2.Text = Text2.Text & strtemp
 End If
    Next X
    If OutSize > 0 Then
  Text5.Text = "RX:" & Val(Mid(Text5.Text, 4, Len(Text5.Text) - 3)) + OutSize
    End If
ScomX.ClearInBuf
ScomX.ClearOutBuf
'Erase Arr
Timer1.Enabled = True
End Sub


Private Sub Timer2_Timer()
Call Command2_Click
End Sub
Public Sub FiletoSeg(FileName As String, Optional ChunkSize As Long = 512)
          Dim fnum As Integer, bytesleft As Long, bytes As Long, Seg As Byte
          Dim tmp() As String
          Dim Buffer() As Byte
          Dim InSize As Long
          Dim X As Long
          Dim Y As Long
          Dim Count As Double
          Dim strTmp() As Byte
          Dim s As String
        If Dir$(FileName) = "" Then
          Err.Raise 53, , "文件没找到"
            Else
            Call FileLines
             InSize = FileLines
               tmp = RedTextFile(FileName, InSize)
                 For X = 1 To InSize
                    Text8.Text = tmp(X) & vbCrLf
                    Call Send
                    DoEvents
                    Next
            End If
End Sub
Public Function RedTextFile(FileName As String, MaxID As Long) As String()  '按行读取文件
            Dim FileID     As Long
            Dim InputStr     As String
            Dim LineStr     As String
            Dim i     As Long
            Dim StrArr()     As String
            On Error Resume Next
              InputStr = "":       LineStr = ""
            FileID = FreeFile()
            ReDim StrArr(MaxID)
              
            Open FileName For Input As #FileID
                      Do While Not EOF(FileID)
                            LineStr = ""
                                i = i + 1
                                If i <= MaxID Then
                                    Line Input #FileID, LineStr
                                    StrArr(i) = LineStr
                                Else
                                      GoTo EndRed
                                      End If
                      Loop
EndRed:
            Close #FileID
            RedTextFile = StrArr
            Err.Clear
  End Function
Function FileLines()
        
          Dim fso     As New FileSystemObject, fil         As File, ts       As TextStream
          Set fil = fso.GetFile(Text7.Text)
          Set ts = fil.OpenAsTextStream(ForReading)
                      
          Do While Not ts.AtEndOfStream
                ts.SkipLine
          Loop
          FileLines = ts.Line
          Debug.Print FileLines
  End Function

Public Function Send()
On Error Resume Next
Dim Arr(1024) As Byte
Dim InSize As Long
Dim X As Long
Dim E As Long
If Command1.Caption = "打开端口" Then
 MsgBox "请先打开端口再发送数据!", , " 程序提示"
 Else
For X = 1 To Len(Text8.Text)
  Arr(X - 1) = Asc(Mid(Text8.Text, X, 1))
  Next X
InSize = Len(Text8.Text)
E = ScomX.SendData(Arr, InSize)
Debug.Print E
End If
  Text6.Text = "TX:" & Val(Mid(Text6.Text, 4, Len(Text6.Text) - 3)) + Len(Text8.Text)
Erase Arr
End Function