vb源码串口通讯程序.docx
《vb源码串口通讯程序.docx》由会员分享，可在线阅读，更多相关《vb源码串口通讯程序.docx（19页珍藏版）》请在冰豆网上搜索。
vb源码串口通讯程序
OptionExplicit
PrivateText1textAsString
PrivateRTUCRCAsString
'串口选择
PrivateSubCombo1_Click（）
MSComm1.CommPort=Combo1.ListIndex+1
EndSub
'数据位改变
PrivateSubCombo2_Click（）
Callsetting
EndSub
'波特率改变
PrivateSubCombo3_Click（）
Callsetting
EndSub
'奇偶校验改变
PrivateSubCombo4_Click（）
Callsetting
EndSub
'停止位改变
PrivateSubCombo5_Click（）
Callsetting
EndSub
PrivateSubsetting（）
MSComm1.Settings=CStr（Combo3.Text）&","&CStr（Combo4.Text）&","&CStr（Combo2.Text）_
&","&CStr（Combo5.Text）
EndSub
'打开关闭串口
PrivateSubCommand1_Click（）
OnErrorResumeNext
IfMSComm1.PortOpen=FalseThen
MSComm1.PortOpen=True
Else
MSComm1.PortOpen=False
EndIf
IfMSComm1.PortOpenThen'打开关闭按钮显示文字及combo1使能
Command1.Caption="关闭串口"
Combo1.Enabled=False
Else
Command1.Caption="打开串口"
Combo1.Enabled=True
EndIf
IfErrThen'打开串口失败，则显示出错信息
MsgBoxError$,48,"错误信息"
ExitSub
EndIf
EndSub
PrivateSubCommand10_Click（）
EndSub
'10转16进制
PrivateSubCommand2_Click（）
OnErrorResumeNext
Text4.Text=Hex（Text3.Text）
IfErrThen'\'则显示出错信息
MsgBoxError$,48,"错误信息"
ExitSub
EndIf
EndSub
'16转10进制
PrivateSubCommand3_Click（）‘16进制显示按钮
DimaAsLong
a=Val（"&H"&CStr（Text4.Text））
Text3.Text=a
EndSub
'手动串口发送
PrivateSubCommand4_Click（）‘手动发送按钮
IfMSComm1.PortOpen=FalseThen
MsgBox"请先打开串口",,"错误信息"
ExitSub
EndIf
Callsentsub
EndSub
'清除接收窗
PrivateSubCommand5_Click（）‘清除按钮
Text2.Text=""
EndSub
PrivateSubCommand6_Click（）‘关闭按钮
UnloadMe
EndSub
'窗口加载
PrivateSubForm_Load（）
Dimd%
Ford=1To16
Combo1.AddItem（"COM"&CStr（d））
Next
Combo1.ListIndex=0
Combo2.AddItem"6"
Combo2.AddItem"7"
Combo2.AddItem"8"
Combo2.ListIndex=2
Combo3.AddItem"110"
Combo3.AddItem"330"
Combo3.AddItem"1200"
Combo3.AddItem"2400"
Combo3.AddItem"4800"
Combo3.AddItem"9600"
Combo3.AddItem"19200"
Combo3.AddItem"38400"
Combo3.AddItem"56000"
Combo3.AddItem"57600"
Combo3.AddItem"115200"
Combo3.ListIndex=5‘默认
Combo4.AddItem"n"
Combo4.AddItem"o"
Combo4.AddItem"e"
Combo4.ListIndex=0
Combo5.AddItem"1"
Combo5.AddItem"2"
Combo5.ListIndex=0
Ford=0To254
Combo6.AddItemd
Next
Combo6.ListIndex=1
Text1.Text="010601001770"
Text2.Text=""
Text3.Text=""
Text4.Text=""
Text5.Text="1000"
Text6.Text="06"
Text7.Text="0"
Text8.Text="1"
Option1.Value=True
Option3.Value=True
IfMSComm1.PortOpen=FalseThen
Command1.Caption="打开串口"
Else
Command1.Caption="关闭串口"
EndIf
EndSub
'串口接收程序
PrivateSubMSComm1_OnComm（）
DimHexchrAsString,hexstringAsString,iAsInteger,jAsInteger,hexdispAsString
IfOption8.ValueThen
hexstring=MSComm1.Input'十六进制显示
i=Len（hexstring）
Forj=1Toi
Hexchr=Mid（hexstring,j,1）
IfHex（Asc（Hexchr））<16Then
Text2.Text=Text2.Text&"0"&Hex（Asc（Hexchr））&""
Else
Text2.Text=Text2.Text&Hex（Asc（Hexchr））&""
EndIf
Nextj
Text2.Text=Text2.Text&CStr（Chr（13））&CStr（Chr（10））
Else
Text2.Text=Text2.Text&MSComm1.Input&CStr（Chr（13））&CStr（Chr（10））'ASCII码显示
EndIf
EndSub
'手动发送选择
PrivateSubOption1_Click（）
IfOption1.Value=TrueThen
Timer1.Enabled=False
Command4.Enabled=True
Else
Timer1.Enabled=True
Command4.Enabled=False
EndIf
EndSub
'DeltaASCII发送协议
PrivateSubOption10_Click（）
Combo6.Enabled=True
Text6.Enabled=True
Text7.Enabled=True
Text8.Enabled=True
Label10.Enabled=True
Label11.Enabled=True
Label12.Enabled=True
Label13.Enabled=True
Option6.Enabled=False
Combo2.ListIndex=1
Combo5.ListIndex=1
Text1.Enabled=False
Label14.Enabled=False
EndSub
PrivateSubOption11_Click（）
EndSub
PrivateSubOption12_Click（）
EndSub
'自动发送选择
PrivateSubOption2_Click（）
IfOption2.Value=TrueThen
Timer1.Enabled=True
Command4.Enabled=False
Else
Timer1.Enabled=False
Command4.Enabled=True
EndIf
EndSub
PrivateSubOption3_Click（）'Non选项
Combo6.Enabled=False
Text6.Enabled=False
Text7.Enabled=False
Text8.Enabled=False
Label10.Enabled=False
Label11.Enabled=False
Label12.Enabled=False
Label13.Enabled=False
Combo2.ListIndex=2
Combo5.ListIndex=0
Text1.Enabled=True
Label14.Enabled=True
EndSub
PrivateSubOption4_Click（）'ASCII选项
Combo6.Enabled=True
Text6.Enabled=True
Text7.Enabled=True
Text8.Enabled=True
Label10.Enabled=True
Label11.Enabled=True
Label12.Enabled=True
Label13.Enabled=True
Option6.Enabled=False
Combo2.ListIndex=1
Combo5.ListIndex=1
Text1.Enabled=False
Label14.Enabled=False
EndSub
PrivateSubOption5_Click（）'RTU选项
Combo6.Enabled=True
Text6.Enabled=True
Text7.Enabled=True
Text8.Enabled=True
Label10.Enabled=True
Label11.Enabled=True
Label12.Enabled=True
Label13.Enabled=True
Option6.Enabled=False
Combo2.ListIndex=2
Combo5.ListIndex=1
Text1.Enabled=False
Label14.Enabled=False
EndSub
'发送时间间隔调整输入
PrivateSubText5_Change（）
DimnumberAsString
DimnumAsInteger
DimnumcycAsInteger
num=Len（Text5.Text）
Fornumcyc=1Tonum
number=Mid（Text5.Text,numcyc,1）
SelectCaseInStr（"0123456789",number）
Case0
MsgBox"输入时间间隔错误，请重新输入",,"错误信息"
ExitSub
EndSelect
Next
Timer1.Interval=Text5.Text
EndSub
'自动发送定时器
PrivateSubTimer1_Timer（）
IfMSComm1.PortOpenThen
Callsentsub
EndIf
EndSub
'状态刷新定时器
PrivateSubTimer2_Timer（）
StatusBar1.Panels
（1）.Text="串口选择：
"&CStr（Combo1.Text）
StatusBar1.Panels
（2）.Text="串口设置：
"&CStr（MSComm1.Settings）
StatusBar1.Panels（3）.Text="串口状态：
"&CStr（MSComm1.PortOpen）
EndSub
'串口发送子程序
PrivateSubsentsub（）
Dimoptioncase%
IfOption3.ValueThenoptioncase=1
IfOption4.ValueThenoptioncase=2
IfOption5.ValueThenoptioncase=3
IfOption10.ValueThenoptioncase=4
SelectCaseoptioncase
Case1‘无校验
IfOption6.ValueThen
Text1text=Text1.Text
CallHexsent‘16进制发送
Else
Text1text=Text1.Text
CallASCIIsent‘ascii发送
EndIf
Case2
Callincorporate'将输入的十进制从机地址、命令、资料地址和资料内容合并成字符串
CallASCIIcheck
CallASCIIsent‘ASCIIcheck校验
Case3
Callincorporate'将输入的十进制从机地址、命令、资料地址和资料内容合并成字符串
CallRTUcheck‘校验
CallHexsent
Case4
Callincorporate1'将输入的十进制从机地址、命令、资料地址和资料内容合并成字符串
CalldeltaASCII‘校验
CallASCIIsent
EndSelect
EndSub
'十六进制发送
PrivateSubHexsent（）
Dimhexchrlen%,HexchrAsString,hexcyc%,hexmidAsByte,hexmiddleAsString
Dimhexchrgroup（）AsByte,iAsInteger
Text1text=Text1.Text
hexchrlen=Len（Text1text）
Forhexcyc=1Tohexchrlen'检查Text1文本框内数值是否合适
Hexchr=Mid（Text1text,hexcyc,1）
IfInStr（"0123456789ABCDEFabcdef",Hexchr）=0Then
‘返回某字符串在另一字符串中第一次出现的位置。
没有找到返回0
MsgBox"无效的数值，请重新输入",,"错误信息"
ExitSub
EndIf
Nexthexcyc
ReDimhexchrgroup（1Tohexchrlen\2）AsByte
Forhexcyc=1TohexchrlenStep2'将文本框内数值分成两个、两个
i=i+1
Hexchr=Mid（Text1text,hexcyc,2）
hexmid=Val（"&H"&CStr（Hexchr））
hexchrgroup（i）=hexmid
'MSComm1.Output=CStr（hexmid）
Next
MSComm1.Output=hexchrgroup
EndSub
'ASC码发送
PrivateSubASCIIsent（）
MSComm1.Output=Text1text
EndSub
'ASC校验,此段程序计算出LRC校验值，并加上字头和字尾
PrivateSubASCIIcheck（）
Dima%,b%,chrnum%,LrcbyteAsString
Dimchecksum%,char%,AscLrc%,Lrc%
chrnum=Len（Text1text）
Fora=1TochrnumStep2
char=Val（"&H"&CStr（Mid（Text1text,a,2）））'两个两个的取字符
checksum=checksum+char'全部加起来
Next
AscLrc=checksumMod&H100'取255的余数
Lrc=（&HFF-AscLrc）+1'取二次补
IfLrc<16Then'此段程序是判断Hex（lrc）是否是一位数，
Lrcbyte="0"+CStr（Hex（Lrc））'如果是的话，前面加0；否则不加零
Else
Lrcbyte=CStr（Hex（Lrc））
EndIf
Text1text=CStr（Chr（58））&CStr（Text1text）&Lrcbyte&CStr（Chr（13））&CStr（Chr（10））
EndSub
'DeltaASCII校验,此段程序计算出LRC校验值，并加上字头和字尾
PrivateSubdeltaASCII（）
Dima%,b%,chrnum%,LrcbyteAsString
Dimchecksum%,char%,Lrc%
chrnum=Len（Text1text）
Fora=1Tochrnum
char=Asc（Mid（Text1text,a,1））'两个两个的取字符
checksum=checksum+char'全部加起来
Next
Lrc=（checksum+&H3）Mod&H100'取255的余数
IfLrc<16Then'此段程序是判断Hex（lrc）是否是一位数，
Lrcbyte="0"+CStr（Hex（Lrc））'如果是的话，前面加0；否则不加零
Else
Lrcbyte=CStr（Hex（Lrc））
EndIf
Text1text=CStr（Chr
（2））&CStr（Text1text）&CStr（Chr（3））&Lrcbyte
EndSub
'RTU校验
PrivateSubRTUcheck（）
DimCRC（）AsByte
Dimd（5）AsByte
Dimstring1AsString
DimjAsInteger,chrlengthAsInteger,tempAsString
Text1text=Text1.Text
string1=Text1text
chrlength=Len（string1）
Forj=0Tochrlength/2-1
temp=Mid（string1,j*2+1,2）
d（j）=Val（"&H"&temp）
Next
RTUCRC=CRC16（d）'调用CRC16计算函数,CRC（0）为高位,CRC
（1）为低位
Text1text=Text1text&RTUCRC
EndSub
PrivateSubincorporate（）'将输入的十进制从机地址、命令、资料地址和资料内容合并成字符串
DimwholecharAsString,wc%,wcyc%,wcharAsString
DimSIDAsString,CmdAsString,InfoAddAsString,dataAsString
DimSIDnum%,Cmdnum%,InfoAddNum%,Datanum%
OnErrorResumeNext
wholechar=CStr（Combo6.Text）&CStr（Text6.Text）&CStr（Text7.Text）&CStr（Text8.Text）
wc=Len（wholechar）
Forwcyc=1Towc
wchar=Mid（wholechar,wcyc,1）
IfInStr（"0123456789",wchar）=0Then
MsgBox"输入错误，请重新输入",,"错误提示"
ExitSub
EndIf
Next
SIDnum=Len（CStr（Hex（Combo6.Text）））
SelectCaseSIDnum
Case0
ExitSub
Case1
SID="0"&CStr（Hex（Combo6.Text））
Case2
SID=CStr（Hex（Combo6.Text））
EndSelect
Cmdnum=Len（CStr（Hex（Text6.Text）））
SelectCaseCmdnum
Case0
ExitSub
Case1
Cmd="0"&CStr（Hex（Text6.Text））
Case1
Cmd=CStr（Hex（Text6.Text））
EndSelect
InfoAddNum=Len（CStr（Hex（Text7.Text）））
SelectCaseInfoAddNum
Case0
ExitSub
Case1
InfoAdd="000"&CStr（Hex（Text7.Text））
Cas
升级会员 