实时折线图
最近看到有好几个问 实时拆线图的,我把我写的那个折线图代码整理了一下,重新发出来.窗体代码,保存在 frm 文件里的.
程序代码：'窗体代码,窗体上,只有一个按钮 command2 ,一个定时器 timer1 , 一个Picture1 , 一个标签 Label2 ,
'其中标签 是在 Picture1 中的. 标签的设置为 自动大小=true
Option Explicit
Dim 当前数据 As Double
Dim 目标数据 As Double
Dim 工作 As Boolean
Private Sub Command2_Click()
工作 = Not 工作
End Sub
Private Sub Form_Load()
工作 = False
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'显示提示
Dim i As Long
'只判断左右移动,不判断上下
If 宽间格 > 0 Then
i = (X - 左边距) / 宽间格
If i > 0 And i < 数据个数Y + 1 Then
'这里是提示的内容,根据结构来写
'这里的,提示格式是: 编号,时间 ,下一行,值
Label2.Caption = i + 计数 - 1 & vbCrLf & 数据(i).时间 & vbCrLf & 数据(i).值
Label2.Move X - Label2.Height, Y - Label2.Width
Label2.Visible = True
Else
Label2.Visible = False
End If
Else
Label2.Visible = False
End If
End Sub
Private Sub Timer1_Timer()
'根据数据的产生
Dim 速度 As Double
If 工作 Then
速度 = Rnd()
If Abs(当前数据 - 目标数据) < 0.5 Then
目标数据 = Round(Rnd() * 11 + 3, 2)
End If
If 当前数据 > 目标数据 Then
当前数据 = 当前数据 - 速度
Else
当前数据 = 当前数据 + 速度
End If
当前数据 = Round(当前数据, 2)
If 当前数据 > 14 Then
当前数据 = 14
End If
If 当前数据 < 3.5 Then
当前数据 = 3.5
End If
Call ADD数据(Time, 当前数据)
Call 绘折线图(Picture1)
End If
End Sub
模块代码 ,保存在 BAS里的．
程序代码：'模块代码
Option Explicit
'这个结构里需要使用到的数据 为 值 , 而 X,Y 是计算出来的, 其它可以用于提示里面,也可以不要.
Public Type 数据结构类型
时间 As Date
值 As Double
X As Long '屏幕提示用的
Y As Long
End Type
'折线图 坐标个数
Public Const 数据个数Y = 30
Public Const 数据个数X = 12 '等你期望的分格数+2, ,如分为10格,那么这里就填12,下面要各空一格
Public 数据(1 To 数据个数Y) As 数据结构类型
Public Max值 As Double
Public Min值 As Double
Public 高间格 As Long, 宽间格 As Long
Public Const 坐标颜色 = 0
Public Const 网格颜色 = vbGreen
Public Const 折线颜色 = vbRed
Public Const 标注颜色 = 3
Public Const 左边距 = 400
Public 计数 As Long
Public Sub ADD数据(cs1 As String, cs2 As Double)
Dim i As Long
If IsDate(cs1) And IsNumeric(cs2) Then
For i = 2 To 数据个数Y
数据(i - 1).时间 = 数据(i).时间
数据(i - 1).值 = 数据(i).值
'数据(i - 1).X = 数据(i).X
'数据(i - 1).Y = 数据(i).Y
Next i
数据(数据个数Y).时间 = cs1
数据(数据个数Y).值 = cs2
'如果Y坐标值不需要变的话,那么下面这行就不要.
计数 = 计数 + 1
End If
'X Y需要重新计算,所以不需要移动
End Sub
Public Sub MaxMin值() '找出最大值,最小值
'根据当前数据动态调整坐标
'Dim i As Long
'Max值 = 数据(1).值
'Min值 = 数据(1).值
'For i = 2 To 50
' If Max值 < 数据(i).值 Then
' Max值 = 数据(i).值
' End If
' 'If Min值 > 数据(i).值 Then
' ' Min值 = 数据(i).值
' 'End If
'Next i
'这里是坐标大小
Max值 = 15
Min值 = 3
End Sub
Public Sub Cls数据()
Dim i As Long
For i = 1 To 数据个数Y
数据(i).值 = 0
数据(i).时间 = #12:00:00 AM#
Next i
End Sub
Public Sub 读数据(cs As String)
'例,按这个结构来的
Dim fr As Long
fr = FreeFile
Dim d As String
Dim fj() As String
Dim j As String
Open cs For Input Access Read As #fr
Do While Not EOF(fr)
Line Input #fr, j
If InStr(1, j, ";") > 0 Then
fj = Split(j, ";")
If d <> fj(0) Then
d = fj(0)
Call ADD数据(fj(0), CDbl(fj(1)))
End If
End If
Loop
Close fr
End Sub
Public Sub 绘折线图(cs As PictureBox)
Dim i As Long, 间格 As Double
Dim 总高 As Long
Dim 最低格 As Double
With cs
Call MaxMin值 '找出最大值,最小值
If Min值 = 0 Then
间格 = (Max值) / (数据个数X + 1) '分格,上下各空一格,为0时,下面不用空
最低格 = 0
Else
间格 = (Max值 - Min值) / 数据个数X '分格,
最低格 = Min值
End If
总高 = .ScaleHeight - 200
高间格 = (总高) / 数据个数X '上下各留一格
宽间格 = (.ScaleWidth - 左边距) / (数据个数Y + 1) '右边留一格
.Cls '清屏
'画坐标
Dim x1 As Long, X2 As Long, y1 As Long, y2 As Long
y1 = .ScaleHeight - 200
x1 = .ScaleWidth - 200
cs.Line (左边距, 0)-(左边距, y1), 坐标颜色
cs.Line (左边距, y1)-(.ScaleWidth, y1), 坐标颜色
'画坐标网络
.ForeColor = 标注颜色
.CurrentX = 0
.CurrentY = y1 - 90
cs.Print Round(最低格, 3)
For i = 1 To 数据个数X - 1
cs.Line (左边距, y1 - i * 高间格)-(.ScaleWidth, y1 - i * 高间格), 网格颜色
.CurrentX = 0
.CurrentY = y1 - i * 高间格 - 90
cs.Print Round(Min值 + i * 间格, 3)
Next i
For i = 1 To 数据个数Y
cs.Line (左边距 + i * 宽间格, 0)-(左边距 + i * 宽间格, y1), 网格颜色
.CurrentX = 左边距 + i * 宽间格 - 150
.CurrentY = y1 + 30
cs.Print i + 计数 - 1
Next i
'画折线图
数据(1).Y = y1 - ((数据(1).值 - 最低格) / (Max值 - 最低格)) * 总高
数据(1).X = 左边距 + 宽间格
cs.Circle (数据(1).X, 数据(1).Y), 30, 折线颜色
For i = 2 To 数据个数Y
数据(i).Y = y1 - ((数据(i).值 - 最低格) / (Max值 - 最低格)) * 总高
数据(i).X = 左边距 + (i) * 宽间格
cs.Circle (数据(i).X, 数据(i).Y), 30, 折线颜色
cs.Line (数据(i - 1).X, 数据(i - 1).Y)-(数据(i).X, 数据(i).Y)
Next i
End With
End Sub[ 本帖最后由 风吹过b 于 2013-3-27 10:48 编辑 ]
不错不错。顶一贴!!!!!!