form1.frm

数据采集系统上位机设计。包括串口通信、文本显示、曲线实时显示、数据保存、监测报警等功能。

'数据保存
'**************************************

Private Sub cmdsavepic_Click()
'comdialog.DefaultExt = ".BMP"
comdialog.Filter = "Bitmap Image (*.bmp)|*.bmp"
comdialog.ShowSave
If comdialog.FileName <> "" Then
SavePicture picshow.Image, comdialog.FileName
End If
'SavePicture picshow.Image
End Sub

Private Sub cmdsavetxt_Click()
comdialog.Filter = "文本文件(*.txt)|*.txt|全部文件(*.*)|*.*"
comdialog.DialogTitle = "保存文件"
comdialog.ShowSave
If Len(comdialog.FileName) = 0 Then Exit Sub
Open comdialog.FileName For Append As #1
Write #1, strdec, strhex1
Close #1
End Sub

'设置参数
'**************************************
Private Sub cmdsetting_Click()

dlgsetting.Show
dlgsetting.txtport.Text = Str(intport)
dlgsetting.txtsetting.Text = strset
dlgsetting.txttime.Text = Str(inttime)

End Sub



'检测CommEvent，从串行口接收数据
'**************************************
Private Sub MSComm2_OnComm()
Dim bytinput() As Byte    '用于接收数据的字节数组
Dim intinputlen As Integer

Select Case frmmain.MSComm2.CommEvent
    Case comEvReceive
           If Not frmmain.MSComm2.PortOpen Then
              frmmain.MSComm2.CommPort = intport
              frmmain.MSComm2.Settings = strset
              frmmain.MSComm2.PortOpen = True
           End If
           
           '此处是处理接收的代码
           frmmain.MSComm2.InputMode = comInputModeBinary
           intinputlen = frmmain.MSComm2.InBufferCount
           ReDim bytinput(intinputlen)
           bytinput = frmmain.MSComm2.Input
          
           Call inputmanage(bytinput, intinputlen)
           Call getdisplaytext

           txtreceiveascii.Text = strascii
           txtreceivehex.Text = strhex1
           txtreceivedec.Text = strdec
           flagshow = True
           
           drwtimer.Interval = 1000
           'drwtimer.Enabled = True
           'If Not blnautosendflag And Not blnreceiveflag Then
             ' frmmain.MSComm2.PortOpen = False
         '  End If
    End Select
           
End Sub

'输入处理
'处理接收到的字节流，并保存到全局变量 bytreceivebyte()

Public Sub inputmanage(bytinput() As Byte, intinputlenth As Integer)
Dim n As Integer   '定义变量及初始化

If (intreceivelen + intinputlenth) < 1024 Then
    ReDim Preserve bytreceivebyte(intreceivelen + intinputlenth)
Else
    ReDim bytreceivebyte(intinputlenth)
    intreceivelen = 0
End If

For n = 1 To intinputlenth Step 1
    bytreceivebyte(intreceivelen + n - 1) = bytinput(n - 1)
Next n

intreceivelen = intreceivelen + intinputlenth

End Sub

'为输出准备文本
'保存在全局变量
'strtext
'strhex
'straddress
'总行数保存在intline
Public Sub getdisplaytext()
   Dim n As Integer
   Dim intvalue As Integer
   Dim inthighhex As Integer
   Dim intlowhex As Integer
   Dim strsinglechr As String * 1
   
   Dim inthexwidth As Integer
   inthexwidth = 50
   strascii = "" '设置初值
   strhex1 = ""
   strdec = ""
    
     '获得十六进制码、十进制码和ASCII码的字符串
     For n = 1 To intreceivelen
     intvalue = bytreceivebyte(n - 1)
     
     If intvalue < 32 Or intvalue > 127 Then   '处理非法字符
         strsinglechr = Chr(46)                '对于不能显示的ASCII码用“.”表示
     Else
         strsinglechr = Chr(intvalue)
     End If
     strascii = strascii + strsinglechr '获得ASCII码的字符串
     
     strdec = strdec + Str(intvalue)     '获得十进制编码的字符串
     
     
     inthighhex = intvalue \ 16     '获得高位值
     intlowhex = intvalue - inthighhex * 16         '获得低位值
     
     If inthighhex < 10 Then
        inthighhex = inthighhex + 48
     Else
        inthighhex = inthighhex + 55
    End If
    
    If intlowhex < 10 Then
       intlowhex = intlowhex + 48
    Else
       intlowhex = intlowhex + 55
    End If
    
    strhex1 = strhex1 + " " + Chr$(inthighhex) + Chr$(intlowhex) + " " '获得十六进制码的字符串
    
   If (n Mod inthexwidth) = 0 Then          '设置换行
       strascii = strascii + Chr$(13) + Chr$(10)
        strhex1 = strhex1 + Chr$(13) + Chr$(10)
        strdec = strdec + Chr$(13) + Chr$(10)
    Else
    
    End If
Next n

End Sub

'Timer触发的事件，所有的发送都在这里执行
'**************************************
Private Sub ctrtimer_Timer()
Dim strsendtext As String
strsendtext = frmmain.txtsend.Text
 If intoutmode = 0 Then
   frmmain.txtmessage.Text = "正在发送数据"
   frmmain.ctrmscomm.Output = strsendtext  '发送文本
 Else
   strsendtext2 = asctohex(strsendtext)
   frmmain.ctrmscomm.Output = strsendtext2
 End If

End Sub
'把ASCII码转换为十六进制码
Public Function asctohex(strorign As String)
Dim i As Integer
Dim j As Integer
Dim t As Integer
Dim s As Integer
Dim strlen As Integer
Dim bytstr() As String
Dim temp1() As String
Dim intvalue As Integer
Dim inthighhex As Integer
Dim intlowhex As Integer
Dim strhex2 As String


i = 0
j = 0
strlen = Len(strorign)
ReDim bytstr(strlen)
ReDim temp1(strlen)     ''''
For t = 0 To strlen - 1
    bytstr(t) = Mid(strorign, t + 1, 1)
Next

Do While i < strlen

    Do
      intvalue = Asc(bytstr(i))
      temp1(j) = temp1(j) & bytstr(i)
      i = i + 1
      
    Loop While intvalue <> 32 And i < strlen
    j = j + 1
Loop
For s = 0 To j - 1
     intvalue = Val(temp1(s))
     inthighhex = intvalue \ 16     '获得高位值
     intlowhex = intvalue - inthighhex * 16         '获得低位值
     
     If inthighhex < 10 Then
        inthighhex = inthighhex + 48
     Else
        inthighhex = inthighhex + 55
    End If
    
    If intlowhex < 10 Then
       intlowhex = intlowhex + 48
    Else
       intlowhex = intlowhex + 55
    End If
    
    strhex2 = strhex2 + " " + Chr$(inthighhex) + Chr$(intlowhex) + " " '获得十六进制码的字符串
    
   asctohex = strhex2
Next s
End Function

Private Sub drwtimer_Timer()
Dim i, j, t, s, m, n As Integer
Dim temp1 As Variant
Dim temp2() As String
Dim bytstr() As Integer
Dim receivednum As String
Dim strlen As Integer
Dim strvalue As String
Dim intvalue2 As Double
Dim tempASC As String
Dim IntR As Integer


If MSComm3.InBufferCount > 0 Then
    temp1 = MSComm3.Input
    i = Int(Rnd * (UBound(temp1) - LBound(temp1) + 1) + LBound(temp1)) '取接收缓冲区的随机下标
    If UBound(alltemper) = 0 Then
        ReDim Preserve alltemper(UBound(alltemper) + 1)
        alltemper(0) = temp1(i)
        alltemper(1) = temp1(i)
        If alltemper(1) > Val(cbotemper.Text) Then
           IntR = MsgBox("温度超过阈值，是否继续接收数据？", vbYesNo, "报警提示")
           If IntR = vbYes Then
       
           Else
               drwtimer.Enabled = False
               Exit Sub
           End If
       End If
    Else
        ReDim Preserve alltemper(UBound(alltemper) + 1)
        alltemper(UBound(alltemper)) = temp1(i)
        If alltemper(UBound(alltemper)) > Val(cbotemper.Text) Then
           IntR = MsgBox("温度超过阈值，继续接收数据吗？", vbYesNo, "报警提示")
           If IntR = vbYes Then
       
           Else
               drwtimer.Enabled = False
               Exit Sub
           End If
       End If
        
    End If

    If UBound(alltemper) < picwidth Then
        picshow.Cls
        Call paintXY(LBound(alltemper))
        Call paintP(LBound(alltemper), UBound(alltemper))
    Else
        hscroll1.Max = UBound(alltemper) - picwidth
        hscroll1.Value = hscroll1.Max
        picshow.Cls
        Call paintXY(UBound(alltemper) - picwidth + 1)
        Call paintP(UBound(alltemper) - picwidth + 1, UBound(alltemper))
    End If
End If
End Sub

'初始化
'**************************************

Private Sub Form_Load()

cbohexascii.AddItem "按ASCII码发送"
cbohexascii.AddItem "按十六进制发送"

cbotemper.AddItem "25"
cbotemper.AddItem "30"
cbotemper.AddItem "35"
'设置默认发送接收开启状态
'blnautosendflag = True
'blnreceiveflag = True

'接收初始化
intreceivelen = 0

'默认发送方式位ASCII
intoutmode = 0
frmmain.cbohexascii.Text = "按ASCII码"


'初始化串行口
intport = 1
inttime = 1000
strset = "9600,n,8,1"
    frmmain.ctrmscomm.InBufferSize = 1024
    frmmain.ctrmscomm.OutBufferSize = 512
    frmmain.ctrmscomm.InputLen = 0
    frmmain.ctrmscomm.SThreshold = 0
    frmmain.ctrmscomm.RThreshold = 1
    frmmain.ctrmscomm.InBufferCount = 0
    frmmain.ctrmscomm.OutBufferCount = 0
    frmmain.ctrmscomm.InputMode = comInputModeBinary
    If frmmain.ctrmscomm.PortOpen Then
       frmmain.ctrmscomm.PortOpen = False
    End If
    
    frmmain.MSComm2.InBufferSize = 1024
    frmmain.MSComm2.OutBufferSize = 512
    frmmain.MSComm2.InputLen = 0
    frmmain.MSComm2.SThreshold = 0
    frmmain.MSComm2.RThreshold = 1
    frmmain.MSComm2.InBufferCount = 0
    frmmain.MSComm2.OutBufferCount = 0
    frmmain.MSComm2.InputMode = comInputModeText   '以文本方式接收数据
    If frmmain.MSComm2.PortOpen Then
       frmmain.MSComm2.PortOpen = False
    End If
    frmmain.MSComm3.InBufferSize = 1024
    frmmain.MSComm3.OutBufferSize = 512
    frmmain.MSComm3.InputLen = 0
    frmmain.MSComm3.SThreshold = 0
    frmmain.MSComm3.RThreshold = 1
    frmmain.MSComm3.InBufferCount = 0
    frmmain.MSComm3.OutBufferCount = 0
    frmmain.MSComm3.InputMode = comInputModeBinary   '以二进制方式接收数据
    If frmmain.MSComm3.PortOpen Then
       frmmain.MSComm3.PortOpen = False
    End If

'初始化图象显示
Call paintXY(0)
picshow.Visible = False
drwtimer.Enabled = False

x1 = 0
y1 = 20
     hscroll1.Value = 0
     hscroll1.Max = 0
ReDim alltemper(0)
ReDim bytreceivebyte(0)

End Sub
'********************************
'画坐标系函数
'********************************
Sub paintXY(pC As Integer)
Dim i As Integer
Dim k As Single
frmmain.picshow.DrawWidth = 1

'画出坐标系
frmmain.picshow.Scale (0, 200)-(400, 0)
frmmain.picshow.Line (0, 20)-(400, 20), vbBlack
frmmain.picshow.Line (0, 20)-(0, 200), vbBlack
'画箭头
frmmain.picshow.Line (3, 198)-(0, 200), vbBlack
frmmain.picshow.Line (398, 23)-(400, 20), vbBlack
frmmain.picshow.Line (398, 17)-(400, 20), vbBlack
'写出坐标值
frmmain.picshow.CurrentX = 0
frmmain.picshow.CurrentY = 17
frmmain.picshow.Print 0
For i = xstep To 400 Step xstep
    frmmain.picshow.Line (i, 20)-(i, 197), vbRed
Next
For i = 20 + ystep To 200 Step ystep
    frmmain.picshow.Line (0, i)-(400, i), vbRed
Next


For k = 10 To 40 Step 3
    frmmain.picshow.CurrentX = 0
    frmmain.picshow.CurrentY = 23 + (k - 9) * ystep
    frmmain.picshow.Print k
Next

For k = 1 To 60 Step 1
  frmmain.picshow.CurrentX = k * 20
frmmain.picshow.CurrentY = 17
frmmain.picshow.Print k + pC
Next

End Sub
'********************************
'画一个屏幕的图形，实现屏幕刷新
'********************************
Sub paintP(pA As Integer, pB As Integer)
    picshow.DrawWidth = 2
    For i = pA To pB
        picshow.Circle ((i - pA) * xstep, (alltemper(i) - 9) * ystep + 20), 1, vbGreen
        picshow.Print Str(alltemper(i))
        If i = 0 Then
        
        ElseIf i = pA And i <> 0 Then
            picshow.Line (0, (alltemper(i - 1) - 9) * ystep + 20)-((i - pA + 1) * xstep, (alltemper(i) - 9) * ystep + 20), vbBlack
        
        Else
            picshow.Line ((i - pA - 1) * xstep, (alltemper(i - 1) - 9) * ystep + 20)-((i - pA) * xstep, (alltemper(i) - 9) * ystep + 20), vbBlack
        End If
    Next
End Sub

Private Sub hscroll1_Change()
    Dim page_now As Integer
    page_now = hscroll1.Value + picwidth - 1
    picshow.Cls
    If hscroll1.Value = hscroll1.Min And hscroll1.Max <> 0 Then
        Call paintXY(0)
        Call paintP(0, picwidth - 1)
    ElseIf hscroll1.Max <> 0 Then
        Call paintXY(hscroll1.Value)
        Call paintP(hscroll1.Value, page_now)
    End If
End Sub