vb串口调试源代码

现需要vb 串口调试软件 源代码，那位仁兄，大姐有，能否传个给我！




SerialPort.bas

Attribute VB_Name = "SerialPort "
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：05/05/29
'描 述：API串口读写模块
'网 站：/
'e-mail：mnd@
'OICQ : 88382850
'****************************************************************************
Option Explicit

Global ComNum As Long
Global bRead(255) As Byte

Type COMSTAT
fCtsHold As Long
fDsrHold As Long
fRlsdHold As Long
fXoffHold As Long
fXoffSent As Long
fEof As Long
fTxim As Long
fReserved As Long
cbInQue As Long
cbOutQue As Long
End Type

Type COMMTIMEOUTS
ReadIntervalTimeout As Long
ReadTotalTimeoutMultiplier As Long
ReadTotalTimeoutConstant As Long
WriteTotalTimeoutMultiplier As Long
WriteTotalTimeoutConstant As Long
End Type

Type DCB
DCBlength As Long
BaudRate As Long
fBinary As Long
fParity As Long
fOutxCtsFlow As Long
fOutxDsrFlow As Long
fDtrControl As Long
fDsrSensitivity As Long
fTXContinueOnXoff As Long
fOutX As Long
fInX As Long
fErrorChar As Long
fNull As Long
fRtsControl As Long
fAbortOnError As Long
fDummy2 As Long
wReserved As Integer
XonLim As Integer
XoffLim As Integer
ByteSize As Byte
Parity As Byte
StopBits As Byte
XonChar As Byte
XoffChar As Byte
ErrorChar As Byte
EofChar As Byte
EvtChar As Byte
End Type

Type OVERLAPPED
Internal As Long
InternalHigh As Long
offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Declare Function CloseHandle Lib "kernel32 " (ByVal hObject As Long) As Long
Declare Fun

ction GetLastError Lib "kernel32 " () As Long
Declare Function ReadFile Lib "kernel32 " (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Long) As Long
Declare Function WriteFile Lib "kernel32 " (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Long) As Long
Declare Function SetCommTimeouts Lib "kernel32 " (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function GetCommTimeouts Lib "kernel32 " (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Declare Function BuildCommDCB Lib "kernel32 " Alias "BuildCommDCBA " (ByVal lpDef As String, lpDCB As DCB) As Long
Declare Function SetCommState Lib "kernel32 " (ByVal hCommDev As Long, lpDCB As DCB) As Long
Declare Function CreateFile Lib "kernel32 " Alias "CreateFileA " (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Declare Function FlushFileBuffers Lib "kernel32 " (ByVal hFile As Long) As Long


Function fin_com()
fin_com = CloseHandle(ComNum)
End Function

'关闭端口
Function FlushComm()
FlushFileBuffers (ComNum)
End Function

'初始化端口
Function Init_Com(ComNumber As String, Comsettings As String) As Boolean
On Error GoTo handelinitcom
Dim ComSetup As DCB, Answer, Stat As COMSTAT, RetBytes As Long
Dim retval As Long
Dim CtimeOut As COMMTIMEOUTS, BarDCB As DCB
' 打开通讯口读/写(&HC0000000).
' 必须指定存在的文件 (3).
ComNum = CreateFile(ComNumber, &HC0000000, 0, 0&, &H3, 0, 0)
If ComNum = -1 Then
MsgBox "端口 " & ComNumber & "无效. 请设置正确. ", 48
Init_Com = False
Exit Function
End If
'超时
CtimeOut.ReadIntervalTimeout = 20
CtimeOut.ReadTotalTimeoutConstant = 1
CtimeOut.ReadTotalTimeoutMultiplier = 1
CtimeOut.WriteTotalTimeoutConstant = 10
CtimeOut.WriteTotalTimeoutMultiplier = 1
retval = SetCommTimeouts(ComNum, CtimeOut)
If retval = -1 Then
retval = GetLastError()
MsgBox "端口超时设定无效 " & ComNumber & " 错误: " & ret

val
retval = CloseHandle(ComNum)
Init_Com = False
Exit Function
End If
retval = BuildCommDCB(Comsettings, BarDCB)
If retval = -1 Then
retval = GetLastError()
MsgBox "无效设备 DCB 块 " & Comsettings & " 错误: " & retval
retval = CloseHandle(ComNum)
Init_Com = False
Exit Function
End If
retval = SetCommState(ComNum, BarDCB)
If retval = -1 Then
retval = GetLastError()
MsgBox "无效设备 DCB 块 " & Comsettings & " 错误: " & retval
retval = CloseHandle(ComNum)
Init_Com = False
Exit Function
End If

Init_Com = True
handelinitcom:
Exit Function
End Function

'从串口读取数据
Function ReadCommPure() As String
On Error GoTo handelpurecom
Dim RetBytes As Long, i As Integer, ReadStr As String, retval As Long
Dim CheckTotal As Integer, CheckDigitLC As Integer
retval = ReadFile(ComNum, bRead(0), 255, RetBytes, 0)
ReadStr = " "
If (RetBytes > 0) Then
For i = 0 To RetBytes - 1
ReadStr = ReadStr & Chr(bRead(i))
Next i
Else
FlushComm
End If
ReadCommPure = ReadStr
handelpurecom:
Exit Function
End Function

'向串口写数据
Function WriteCOM32(COMString As String) As Integer
On Error GoTo handelwritelpt
Dim RetBytes As Long, LenVal As Long
Dim retval As Long

If Len(COMString) > 255 Then
WriteCOM32 Left$(COMString, 255)
WriteCOM32 Right$(COMString, Len(COMString) - 255)
Exit Function
End If

For LenVal = 0 To Len(COMString) - 1
bRead(LenVal) = Asc(Mid$(COMString, LenVal + 1, 1))
Next LenVal
' bRead(LenVal) = 0
retval = WriteFile(ComNum, bRead(0), Len(COMString), RetBytes, 0)
' FlushComm
WriteCOM32 = RetBytes

handelwritelpt:
Exit Function
End Function



对我有用[0] 丢个板砖[0] 引用 举报 管理 TOP 精华推荐：讨论：浅谈winsock ConnectionRequest事件

fxy_2002

(阿勇)

等　级：
2
#6楼 得分：0回复于：2005-11-17 15:41:23SerialComms.frm

***********************

VERSION 5.00
Begin VB.Form frmSerial
Bo

rderStyle = 1 'Fixed Single
Caption = "API串口通讯模块 枕善居 "
ClientHeight = 4680
ClientLeft = 45
ClientTop = 330
ClientWidth = 6540
LinkTopic = "Form1 "
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4680
ScaleWidth = 6540
StartUpPosition = 3 '窗口缺省
Begin VB.Timer TMRComm
Enabled = 0 'False
Interval = 1000
Left = 5430
Top = 4230
End
Begin VB.Frame Frame1
ForeColor = &H00C00000&
Height = 3015
Left = 90
TabIndex = 7
Top = 1440
Width = 6390
Begin VB.TextBox txtRec
Enabled = 0 'False
Height = 1395
Left = 105
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 10
Tag = "NC "
Top = 1500
Width = 6150
End
Begin mandButton BTNSend
Caption = "发送数据(&S) "
Default = -1 'True
Enabled = 0 'False
Height = 375
Left = 4815
TabIndex = 9
Tag = "NC "
Top = 990
Width = 1455
End
Begin VB.TextBox txt
Enabled = 0 'False
Height = 315
Index = 2
Left = 120
TabIndex = 8
Tag = "NC "
Top =

540
Width = 6135
End
Begin bel Label1
Caption = "接收数据: "
Height = 255
Index = 3
Left = 120
TabIndex = 12
Top = 1260
Width = 1215
End
Begin bel Label1
Caption = "发送到串口的字符: "
Height = 255
Index = 2
Left = 120
TabIndex = 11
Top = 270
Width = 3075
End
Begin VB.Shape Pic
BorderStyle = 0 'Transparent
FillColor = &H0000FFFF&
FillStyle = 0 'Solid
Height = 255
Left = 6045
Shape = 3 'Circle
Top = 180
Width = 195
End
End
Begin VB.Frame Frame2
Caption = "串口设置 "
ForeColor = &H00C00000&
Height = 1215
Left = 105
TabIndex = 0
Top = 135
Width = 6330
Begin mandButton BTNCloseCom
Cancel = -1 'True
Caption = "关闭串口 "
Enabled = 0 'False
Height = 435
Left = 4380
TabIndex = 4
Tag = "NC "
Top = 660
Width = 1035
End
Begin mandButton BTNOpenCom
Caption = "打开串口 "
Height = 435
Left = 4380
TabIndex

= 3
Tag = "NO "
Top = 180
Width = 1035
End
Begin VB.TextBox txt
Height = 315
Index = 1
Left = 1980
TabIndex = 2
Tag = "NO "
Text = "9600,n,8,1 "
Top = 570
Width = 1455
End
Begin VB.TextBox txt
Height = 315
Index = 0
Left = 1020
TabIndex = 1
Tag = "NO "
Text = "COM1: "
Top = 570
Width = 855
End
Begin bel Label1
Caption = "参数设置: "
Height = 255
Index = 1
Left = 1980
TabIndex = 6
Top = 330
Width = 1335
End
Begin bel Label1
Caption = "串口: "
Height = 255
Index = 0
Left = 1020
TabIndex = 5
Top = 330
Width = 915
End
End
End
Attribute VB_Name = "frmSerial "
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：05/05/29
'描 述：API串口读写测试
'网 站：/
'e-mail：mnd@
'OICQ : 88382850
'****************************************************************************
Private Sub BTNCloseCom_Click()
TMRComm.Enabled = False
Call fin_com

SwitchTags
End Sub

Private Sub BTNOpenCom_Click()
If Not Init_Com(txt(0).Text, txt(1).Text) Then
MsgBox txt(0).Text & " 无效! "
Exit Sub
End If
SwitchTags
TMRComm.Enabled = True
End Sub

Private Sub BTNSend_Click()
If WriteCOM32(txt(2)) & vbCr <> Len(txt(2)) Then
MsgBox "写入错误 "
Exit Sub
End If
txtRec.Text = " "
Pic.FillColor = &HFF0000
End Sub

Private Sub TMRComm_Timer()
Dim Ans As String, i As Integer, RtnStr As String
Ans = ReadCommPure()
If Pic.FillColor = &HFFFFFF Then
Pic.FillColor = &H808080
Else
Pic.FillColor = &HFFFFFF
End If
If Ans = " " Then Exit Sub
Pic.FillColor = &HFF
For i = 1 To Len(Ans)
RtnStr = RtnStr & Hex(Asc(Mid$(Ans, i, 1))) & " "
Next
RtnStr = RtnStr & vbCrLf & vbCrLf & CleanStr(Ans)
txtRec.Text = RtnStr
FlushComm
End Sub

Function CleanStr(TextLine As String) As String
Dim i As Integer, RtnStr As String
RtnStr = " "
For i = 1 To Len(TextLine)
Select Case Asc(Mid$(TextLine, i, 1))
Case &H5D
RtnStr = RtnStr & " "
Case &H5B
RtnStr = RtnStr & " "
Case Is > = &H30
RtnStr = RtnStr & Mid$(TextLine, i, 1)
Case 13
RtnStr = RtnStr & " "
Case 10
RtnStr = RtnStr & " "
Case Else
RtnStr = RtnStr & "@ "
End Select
Next i
CleanStr = RtnStr
End Function

Sub SwitchTags()
Dim xs As Control
For Each xs In Me
If xs.Tag <> " " Then
xs.Enabled = Not xs.Enabled
End If
Next
End Sub