跪求VB 作串口实时数据采集曲线

压力火锅 2014-10-12 07:18:45

各位大侠：
小弟现在需在VB串口上位机加入将串口采集回来的数据以历史曲线显示的功能，能发个例子程序给我么，或告诉我怎么做！以下是小弟在论坛上看到的，有些不懂，不知道哪个死picture控件。各位大侠求助啊
实时曲线左移函数，定义在模块中

 Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

 

'建立一个类，作为画实时曲线

 Option Explicit

 

Public pCurveNUM                        As Integer

 Public pCurveName                       As String

 Public pCurveMax                        As Double

 Public pCurvemin                        As Double

 

Private pricCurve                       As PictureBox

 Private priCurvePoint(6)                As Integer

 Private priCurveData(6)                 As Double

 Private priDrawY0(6)                    As Double

 Private priDrawY1(6)                    As Double

 Private priDrawNMinute                  As Integer

 Private priDrawTMinute                  As Integer

 

Private WithEvents priTimerDraw         As Timer

 

Public Property Let ltDrawTimer(ByRef lTimer As Timer)

     

     Set priTimerDraw = lTimer

     

 End Property

 

Public Property Let ltGiveCurveData(ByVal lDataPoint As Variant)

     Dim i%

     For i = 1 To pCurveNUM

         priCurvePoint(i) = CInt(lDataPoint(i))

     Next

 End Property

 

Public Property Let ltGetPicture(ByRef lDrawPicBox As PictureBox)

      Set pricCurve = lDrawPicBox

 End Property

 





Private Sub sDrawTheRealTimeCurve()

 

    Dim ypixels, xpixels, i%

     Dim ShowMode As Long, ii As Long, tm As String, hBmp As Long

     pricCurve.DrawWidth = 1

     hBmp = pricCurve.hDC

     ShowMode = &HCC0020

     ii = BitBlt(hBmp, 0, 0, pricCurve.ScaleWidth - 1, pricCurve.ScaleHeight - 1, hBmp, 1, 0, ShowMode)

     Dim T As Integer

     T = Minute(Now())

     priDrawNMinute = T

     If priDrawNMinute > priDrawTMinute Then

         pricCurve.CurrentX = pricCurve.ScaleWidth - 19

         pricCurve.CurrentY = pricCurve.ScaleHeight - 11

         pricCurve.Print priDrawNMinute

     End If

     priDrawTMinute = priDrawNMinute

     pricCurve.ScaleMode = vbPixels

     ypixels = pricCurve.ScaleHeight - 1

     xpixels = pricCurve.ScaleWidth - 1

     

     'For 1 to 6 curves

     If pCurveNUM > 6 Or pCurveNUM < 1 Then pCurveNUM = 1

     For i = 1 To pCurveNUM

         priDrawY1(i) = CInt(ypixels - (priCurveData(i) - pCurvemin) / (pCurveMax - pCurvemin) * ypixels)

         If priDrawY1(i) = priDrawY0(i) Then priDrawY1(i) = priDrawY1(i) + 1

     Next

     pricCurve.Line (xpixels - 1, priDrawY0(1))-(xpixels - 1, priDrawY1(1)), vbRed

     If pCurveNUM > 1 Then pricCurve.Line (xpixels - 1, priDrawY0(2))-(xpixels - 1, priDrawY1(2)), vbWhite

     If pCurveNUM > 2 Then pricCurve.Line (xpixels - 1, priDrawY0(3))-(xpixels - 1, priDrawY1(3)), vbGreen

 '    If pCurveNUM > 3 Then pricCurve.Line (xpixels - 1, priDrawY0(4))-(xpixels - 1, priDrawY1(4)), spColor(3).FillColor

 '    If pCurveNUM > 4 Then pricCurve.Line (xpixels - 1, priDrawY0(5))-(xpixels - 1, priDrawY1(5)), spColor(4).FillColor

 '    If pCurveNUM > 5 Then pricCurve.Line (xpixels - 1, priDrawY0(6))-(xpixels - 1, priDrawY1(6)), spColor(5).FillColor

     For i = 1 To 6

         priDrawY0(i) = priDrawY1(i)

     Next

     

 End Sub

 

Public Sub clsInit()

 

    Dim i%

     

     For i = 1 To 6

         priDrawY0(i) = pricCurve.Height

         priDrawY1(i) = pricCurve.Height

     Next

 

    priTimerDraw.Interval = 1000

     priTimerDraw.Enabled = True

 End Sub

 

Private Sub priTimerDraw_Timer()

 

    Dim i%

     For i = 1 To pCurveNUM

         priCurveData(i) = gRealTimeData(priCurvePoint(i))

     Next

     Call sDrawTheRealTimeCurve

     

 End Sub

...全文

2305 2 打赏收藏转发到动态举报

写回复

用AI写文章

2 条回复

切换为时间正序

请发表友善的回复…

发表回复

赵4老师 2016-10-08

打赏
举报

qq_32816639 2016-10-06

打赏
举报

Dim j As Integer

Dim i As Integer

Dim tem As Variant

Dim cnt As Integer

Dim saved As Integer

Dim darwed As Integer

Dim csbuf(155) As Variant

Dim zqlsbuf(155) As Variant

Dim yqlsbuf(155) As Variant

Dim zhlsbuf(155) As Variant

Dim yhlsbuf(155) As Variant

Dim hylbuf(155) As Variant

Dim zdjl(2) As Variant

Dim cstmp As Variant

Dim zctmp As Variant

Dim a As Integer

Dim b As String

Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)





Private Sub Check2_Click() '显示实际采集电流值曲线图



picture1show               '显示电流曲线图表

Picture1.DrawWidth = 1

j = 0

    For i = 0 To 900 Step 20

    Picture1.Line (i, csbuf(j) * 10)-(i + 20, csbuf(j + 1) * 10), vbGreen

    Sleep 1000

    

    j = j + 1

    Next i



End Sub



Private Sub Command2_Click(Index As Integer)





MSComm1.Output = "FF001160000C4"

  Sleep 300

MSComm1.Output = "FF00111FF"

  Sleep 300

MSComm1.Output = "FF0011605DCF0"

  Sleep 300

MSComm1.Output = "1000123D7"

picture1show               '显示电流曲线图表

Picture1.DrawWidth = 1

For i = 0 To 900 Step 20

   

    Picture1.Line (i, Text1.Text)-(i + 20, Text1.Text), vbGreen

    Sleep 1000

    

    j = j + 1

    Next i



MSComm1.Output = "FF0011603F8E5"

For d = 0 To 10

MSComm1.Output = "1000123D7"

d = d + 1

'需要延时500ms

Next d



MSComm1.Output = "FF0011280"

For e = 0 To 10

MSComm1.Output = "1000123D7"

e = e + 1

'需要延时500ms

Next e

End Sub



Private Sub Command4_Click()

On Error Resume Next

 If Shape1.FillColor = &H4000& Then  '如果没有启动，按下此按键，代表用户想启动

    MSComm1.CommPort = Combo1.ListIndex + 1

    MSComm1.Settings = "38400,n,8,1"        '设置波特率

    MSComm1.InputLen = 0

    MSComm1.InBufferSize = 1024             '设置缓冲区接收字节数

    MSComm1.OutBufferSize = 1024            '设置缓冲区发送字节数

    MSComm1.RThreshold = 1                  '设置接收1个字节就产生OnComm事件

    MSComm1.InBufferCount = 0               '清空输入缓冲区

    MSComm1.OutBufferCount = 0              '清空输出缓冲区

    MSComm1.SThreshold = 0

    MSComm1.RTSEnable = True                '接收数据使能

    MSComm1.InputMode = comInputModeText    '以字符串方式发送与接收

    MSComm1.InputLen = 0

    MSComm1.Handshaking = comNone '无握手协议

    MSComm1.PortOpen = True

    If Err Then

   ' MSComm1.PortOpen = False

    MsgBox "通讯端口选择错误！" + vbCrLf + "正确的串口号在这里看：" + vbCrLf + "桌面->我的电脑->属性->硬件->设备管理器->端口->COM"

    Else

    Shape1.FillColor = &HFF00& '把启动指示灯打开

    Command4.Caption = "关闭"

    Combo1.Enabled = False

    End If

    

    

 Else '如果启动了，按下此按键，代表用户想关闭

  

  MSComm1.PortOpen = False '关闭串口

  Shape1.FillColor = &H4000& '关闭启动指示灯

  Command4.Caption = "开启"

  Combo1.Enabled = True

  

 End If



End Sub



Private Sub Form_Load()

   Call InitRs232

   Call picture1show

   Combo1.Text = "COM1"

End Sub

Sub InitRs232() '初始化串口副程序

 '  On Error Resume Next

 '  MSComm1.CommPort = Combo1.ListIndex + 1 '设置com端口

 '  If MSComm1.PortOpen Then MSComm1.PortOpen = False '如果串口为打开状态则关闭它

  ' With MSComm1 '宣告MsComm控件的结构体

    '  .Settings = "38400,n,8,1" '设定通讯协议 9600波特率,无奇偶校验,8位数据,一个停止位

    '   .InBufferSize = 1024 '设置缓冲区接收数据为1字节

    '  .OutBufferSize = 1024

    '  .RThreshold = 1 '设置接收1个字节就产生OnComm事件

    '  .InBufferCount = 0 '清空缓冲区

    '  .OutBufferCount = 0

    '  .SThreshold = 0

    '  .RTSEnable = True

    '  .InputMode = comInputModeText

    ' .InputLen = 0

     

    ' End With

  

    ' Text1 = ""

End Sub

Private Sub Command1_Click(Index As Integer)

         

          Select Case Index

          Case 0

             MSComm1.Output = "1000100D2"

          Case 1

            MSComm1.Output = "@?WHERE" & vbCrLf

          Case 2

         MSComm1.Output = "@READ PGM" & vbCrLf

        End Select

        End Sub

  Private Sub MSComm1_OnComm()

  Dim bytInput() As Byte

  Dim intInputLen As Integer

  Dim teststring As String

    

  Select Case MSComm1.CommEvent

    Case comEvReceive

      

        MSComm1.InputMode = 0                    '0：文本方式，1：二进制方式

            

      intInputLen = MSComm1.InBufferCount

      bytInput = MSComm1.Input

            

     

      teststring = bytInput

        Text1.Text = teststring



teststring = ""



Dim b As String

Dim HexA As String

b = Mid(teststring, 9, 4)

HexA = b



Text1.Text = Val("&H" & HexA)

  End Select

  End Sub

Private Sub Form_Unload(Cancel As Integer)

    If MsgBox("确定要退出程序吗？", vbYesNo, "提示") = vbNo Then Cancel = True

    MSComm1.PortOpen = False

End Sub

'横坐标范围都是0~900，表示0~40s,5S间隔显示曲线，一共有75个点（900/12=75,12个像素点表示间隔5S）

'纵坐标范围0~900，表示0~2A，45个像素表示1mA

Sub picture1show()

 cnt = 0

 darwed = 0 '标志还没有画曲线

 Picture1.Cls

 Picture1.Scale (-100, 1100)-(1100, -100) '定义Picture1的坐标范围

 Picture1.DrawWidth = 2 '定义线宽

 

  

 Picture1.Line (0, 0)-(1000, 0), vbWhite '绘制横坐标线

 Picture1.Line (0, 0)-(0, 1000), vbWhite   '绘制纵坐标线

 

 

 Picture1.Line (0, 1000)-(-5, 980), vbWhite '绘制纵坐标箭头

 Picture1.Line -(5, 980), vbWhite

 Picture1.Line -(0, 1000), vbWhite

 

 Picture1.Line (1000, 0)-(990, -10), vbWhite  '绘制横坐标箭头

 Picture1.Line -(990, 10), vbWhite

 Picture1.Line -(1000, 0), vbWhite

 '绘制纵坐标间隔（间隔0.1mA）

 For i = 45 To 900 Step 45

 Picture1.Line (0, i)-(-10, i), vbWhite

 Next i

 '绘制横坐标间隔（间隔时间5s）

 For i = 100 To 900 Step 100

 Picture1.Line (i, 0)-(i, -20), vbWhite

 Next i

 '绘制网格

  Picture1.DrawWidth = 1

  For i = 100 To 900 Step 100

  Picture1.Line (i, 5)-(i, 900), RGB(0, 0, 99)

  Next i



  For i = 45 To 900 Step 45

  Picture1.Line (5, i)-(900, i), RGB(0, 0, 99)

  Next i

 

 '显示图表名称

 Picture1.ForeColor = vbRed

 Picture1.FontSize = 12

 Picture1.CurrentX = 350

 Picture1.CurrentY = 1050

 Picture1.Print "电流实时采集曲线"

 

 '显示横纵坐标名称

 Picture1.FontSize = 12

 Picture1.DrawWidth = 2

 Picture1.ForeColor = RGB(153, 255, 255)

 Picture1.CurrentX = 1020

 Picture1.CurrentY = 0

 Picture1.Print "时间:S"

 Picture1.CurrentX = -70

 Picture1.CurrentY = 1050

 Picture1.Print "电流:A"

 '显示纵坐标刻度值

 Dim j As Variant

 Picture1.FontSize = 10

 Picture1.DrawWidth = 1

 Picture1.ForeColor = vbGreen

 For j = 45 To 900 Step 45

 Picture1.CurrentX = -50

 Picture1.CurrentY = j + 15

 Picture1.Print Format(j / 450, "0.0")

 Next j

 



 '显示横坐标刻度值

 Picture1.FontSize = 10

 Picture1.DrawWidth = 1

 Picture1.ForeColor = vbGreen

 For j = 100 To 900 Step 100

 Picture1.CurrentX = j - 10

 Picture1.CurrentY = -35

 Picture1.Print Format(Trim(Str(j / 20)), 0)

 Next j

 

 '显示曲线颜色注释

 Picture1.FontSize = 9

 Picture1.DrawWidth = 2

 Picture1.ForeColor = vbWhite

 Picture1.CurrentX = 950

 Picture1.CurrentY = 1000

 Picture1.Print "工作设定"

 Picture1.Line (1040, 990)-(1090, 990), vbWhite

 

 

 Picture1.ForeColor = vbGreen

 Picture1.CurrentX = 950

 Picture1.CurrentY = 950

 Picture1.Print "实际采集"

 Picture1.Line (1040, 940)-(1090, 940), vbGreen

 



End Sub



Private Sub 新建_Click()

 If darwed = 1 And saved = 0 Then '如果已经画了曲线还没有保存

  If MsgBox("刚测试的曲线图未保存！您确定要新建吗？", vbQuestion + vbYesNo) = vbNo Then

  Else

   Call picture1show

  

  End If

 Else

 Call picture1show

 End If

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

End

End Sub