支持多曲线的历史曲线控件源码

原帖：http://blog.csdn.net/Modest/archive/2007/07/27/1711749.aspx

功能：可以设置是否显示值刻度、网格、曲线、时间刻度等，可以定义背景颜色、网格颜色、刻度颜色、曲线颜色等，可以设置网格大小、刻度间隔、曲线进展长度，最重要的是可以支持多曲线运行。

 

名称：GraphVERSION 5.00Begin VB.UserControl Graph AutoRedraw = -1 'True BackColor = &H00000000& ClientHeight = 1605 ClientLeft = 0 ClientTop = 0 ClientWidth = 2880 ForeColor = &H8000000B& HitBehavior = 0 '无 ScaleHeight = 1605 ScaleWidth = 2880EndAttribute VB_Name = "Graph"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = TrueAttribute VB_PredeclaredId = FalseAttribute VB_Exposed = FalseOption ExplicitPrivate m_Coll() As CollectionPrivate m_Color() As OLE_COLORPrivate m_Time As CollectionPrivate m_MaxValue As SinglePrivate m_ScaleColor As OLE_COLORPrivate m_GridColor As OLE_COLORPrivate m_CellWidth As SinglePrivate m_CellHeight As SinglePrivate m_Spaced As SinglePrivate m_ValueScale As SinglePrivate m_TimeScale As LongPrivate m_ShowGraph As BooleanPrivate m_ShowGrid As BooleanPrivate m_ShowValueScale As BooleanPrivate m_ShowTimeScale As Boolean'背景颜色Public Property Get BackColor() As OLE_COLOR BackColor = UserControl.BackColorEnd PropertyPublic Property Let BackColor(ByVal Value As OLE_COLOR) UserControl.BackColor = Value Call AddValue PropertyChanged "BackColor"End Property'数字颜色Public Property Get ScaleColor() As OLE_COLOR ScaleColor = m_ScaleColorEnd PropertyPublic Property Let ScaleColor(ByVal Value As OLE_COLOR) m_ScaleColor = Value Call AddValue PropertyChanged "ScaleColor"End Property'网格颜色Public Property Get GridColor() As OLE_COLOR GridColor = m_GridColorEnd PropertyPublic Property Let GridColor(ByVal Value As OLE_COLOR) m_GridColor = Value Call AddValue PropertyChanged "GridColor"End Property'曲线是否可见Public Property Get ShowGraph() As Boolean ShowGraph = m_ShowGraphEnd PropertyPublic Property Let ShowGraph(ByVal Value As Boolean) m_ShowGraph = Value Call AddValue PropertyChanged "ShowGraph"End Property'网格是否可见Public Property Get ShowGrid() As Boolean ShowGrid = m_ShowGridEnd PropertyPublic Property Let ShowGrid(ByVal Value As Boolean) m_ShowGrid = Value Call AddValue PropertyChanged "ShowGrid"End Property'值刻度是否可见Public Property Get ShowValueScale() As Boolean ShowValueScale = m_ShowValueScaleEnd PropertyPublic Property Let ShowValueScale(ByVal Value As Boolean) m_ShowValueScale = Value Call AddValue PropertyChanged "ShowValueScale"End Property'时间刻度是否可见Public Property Get ShowTimeScale() As Boolean ShowTimeScale = m_ShowTimeScaleEnd PropertyPublic Property Let ShowTimeScale(ByVal Value As Boolean) m_ShowTimeScale = Value Call AddValue PropertyChanged "ShowTimeScale"End Property'单格宽度Public Property Get CellWidth() As Single CellWidth = m_CellWidthEnd PropertyPublic Property Let CellWidth(ByVal Value As Single) m_CellWidth = Value Call AddValue PropertyChanged "CellWidth"End Property'单格宽度Public Property Get CellHeight() As Single CellHeight = m_CellHeightEnd PropertyPublic Property Let CellHeight(ByVal Value As Single) m_CellHeight = Value Call AddValue PropertyChanged "CellHeight"End Property'值间隔Public Property Get Spaced() As Long Spaced = m_SpacedEnd PropertyPublic Property Let Spaced(ByVal Value As Long) m_Spaced = Value Call AddValue PropertyChanged "Spaced"End Property'值刻度Public Property Get ValueScale() As Long ValueScale = m_ValueScaleEnd PropertyPublic Property Let ValueScale(ByVal Value As Long) m_ValueScale = Value Call AddValue PropertyChanged "ValueScale"End Property'时间刻度Public Property Get TimeScale() As Long TimeScale = m_TimeScaleEnd PropertyPublic Property Let TimeScale(ByVal Value As Long) m_TimeScale = Value PropertyChanged "TimeScale"End Property'最大比例Public Property Get MaxValue() As Single MaxValue = m_MaxValueEnd PropertyPublic Property Let MaxValue(ByVal Value As Single) m_MaxValue = Value Call AddValue PropertyChanged "MaxValue"End Property'曲线个数Public Property Get GraphCount() As Long On Error Resume Next GraphCount = UBound(m_Coll) + 1End PropertyPrivate Sub UserControl_Resize() Call AddValueEnd SubPrivate Sub UserControl_Show() Call AddValueEnd SubPrivate Sub UserControl_Initialize() UserControl.ScaleMode = 3 Set m_Time = New CollectionEnd SubPrivate Sub UserControl_Terminate() Dim i As Long For i = 0 To GraphCount - 1 Set m_Coll(i) = Nothing Next Set m_Time = NothingEnd SubPrivate Sub UserControl_ReadProperties(PropBag As PropertyBag) m_ShowGraph = PropBag.ReadProperty("ShowGraph", True) m_ShowGrid = PropBag.ReadProperty("ShowGrid", True) m_ShowValueScale = PropBag.ReadProperty("ShowValueScale", True) m_ShowTimeScale = PropBag.ReadProperty("ShowTimeScale", True) UserControl.BackColor = PropBag.ReadProperty("BackColor", &H0&) m_ScaleColor = PropBag.ReadProperty("ScaleColor", &HC0C0C0) m_GridColor = PropBag.ReadProperty("GridColor", vbGreen) m_CellWidth = PropBag.ReadProperty("CellWidth", 12) m_CellHeight = PropBag.ReadProperty("CellHeight", 12) m_Spaced = PropBag.ReadProperty("Spaced", 5) m_ValueScale = PropBag.ReadProperty("ValueScale", 25) m_TimeScale = PropBag.ReadProperty("TimeScale", 2) m_MaxValue = PropBag.ReadProperty("MaxValue", 100)End SubPrivate Sub UserControl_WriteProperties(PropBag As PropertyBag) Call PropBag.WriteProperty("ShowGraph", m_ShowGraph, True) Call PropBag.WriteProperty("ShowGrid", m_ShowGrid, True) Call PropBag.WriteProperty("ShowValueScale", m_ShowValueScale, True) Call PropBag.WriteProperty("ShowTimeScale", m_ShowTimeScale, True) Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H0&) Call PropBag.WriteProperty("ScaleColor", m_ScaleColor, &HFFFFFF) Call PropBag.WriteProperty("GridColor", m_GridColor, vbGreen) Call PropBag.WriteProperty("CellWidth", m_CellWidth, 12) Call PropBag.WriteProperty("CellHeight", m_CellHeight, 12) Call PropBag.WriteProperty("Spaced", m_Spaced, 5) Call PropBag.WriteProperty("ValueScale", m_ValueScale, 25) Call PropBag.WriteProperty("TimeScale", m_TimeScale, 2) Call PropBag.WriteProperty("MaxValue", m_MaxValue, 100)End SubPublic Sub Clear() Dim i As Long, x As Long, c As Long c = GraphCount For i = 0 To c - 1 For x = m_Coll(i).Count To 1 Step -1 m_Coll(i).Remove x Next Next For i = m_Time.Count To 1 Step -1 m_Time.Remove i NextEnd Sub'添加曲线Public Sub AddGraph(ByVal Color As OLE_COLOR) Dim i As Long i = GraphCount - 1 i = i + 1 ReDim Preserve m_Coll(i) ReDim Preserve m_Color(i) Set m_Coll(i) = New Collection m_Color(i) = ColorEnd Sub'添加值Public Sub AddValue(ParamArray Value()) Dim i As Long, YScale As Single, Index As Long Dim t As Date, Count As Long Dim x() As Single, y() As Single, NullPraram As Boolean ' On Local Error Resume Next Count = GraphCount NullPraram = UBound(Value) = -1 With UserControl .Cls ' 清除 '网格 If m_ShowGrid Then For i = 1 To .ScaleWidth / m_CellWidth UserControl.Line (0, 0)-(m_CellWidth * i, .ScaleHeight), m_GridColor, B Next For i = 1 To .ScaleHeight / m_CellHeight UserControl.Line (0, 0)-(.ScaleWidth, m_CellHeight * i), m_GridColor, B Next End If If Count = 0 Then GoTo s: ReDim x(Count - 1, 1) ReDim y(Count - 1, 1) YScale = .ScaleHeight / MaxValue For Index = 0 To Count - 1 If Index < UBound(Value) Or NullPraram Then If Not NullPraram Then '保存记录 m_Coll(Index).Add Value(Index) '删除记录 Do While m_Coll(Index).Count > .ScaleWidth / m_Spaced m_Coll(Index).Remove 1 Loop End If '画线 If m_ShowGraph Then For i = 1 To m_Coll(Index).Count ' 新点 x(Index, 1) = x(Index, 0) + m_Spaced: y(Index, 1) = m_Coll(Index)(i) * YScale ' 画线 UserControl.Line (.ScaleWidth - x(Index, 0), .ScaleHeight - y(Index, 0))-(.ScaleWidth - x(Index, 1), .ScaleHeight - y(Index, 1)), m_Color(Index) ' 旧点 x(Index, 0) = x(Index, 1): y(Index, 0) = y(Index, 1) Next End If End If Next '横坐标 If Not NullPraram Then t = Now i = Format(t, "ss") If i Mod m_TimeScale = 0 Then m_Time.Add t Else m_Time.Add 0 End If Do While m_Time.Count > .ScaleWidth / m_Spaced m_Time.Remove 1 Loop End If If m_ShowTimeScale Then For i = .ScaleWidth / m_Spaced To .ScaleWidth / m_Spaced - m_Time.Count + 1 Step -1 Index = .ScaleWidth / m_Spaced - i + 1 If Index > 0 And Index <= m_Time.Count Then If m_Time(Index) <> 0 And m_Time(Index) <> t Then .CurrentX = i * m_Spaced .CurrentY = .ScaleHeight - 15 t = m_Time(Index) UserControl.Print Format(t, "hh:nn:ss") End If End If Next End Ifs: '纵坐标 If m_ShowValueScale Then If m_ValueScale = 0 Then Exit Sub For i = 0 To MaxValue / m_ValueScale .CurrentY = Int(.ScaleHeight / (MaxValue / m_ValueScale)) * i .CurrentX = 0 UserControl.Print MaxValue - Int(MaxValue * i / (MaxValue / m_ValueScale)) Next End If End With DoEventsEnd Sub

使用方法：
设置好各项属性后：

Option ExplicitPrivate Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)Private Sub Command1() Graph.AddGraph ColorConstants.vbRed Graph.AddGraph ColorConstants.vbBlue Graph.AddGraph ColorConstants.vbGreen Dim v1, v2, v3 Do Randomize v1 = Int(Rnd * 100) Randomize v2 = Int(Rnd * 100) Randomize v3 = Int(Rnd * 100) Call Graph.AddValue(v1, v2, v3, 5) Sleep 50: DoEvents LoopEnd Sub