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

(声明：魏滔序原创，转贴请注明出处。)
早就想亲自DIY一个类似Windwos任务管理器中的CPU和内存的曲线图，因时间关系直到现在才如愿以偿。虽然做的粗糙点，但勉强说的过去。
功能：可以设置是否显示值刻度、网格、曲线、时间刻度等，可以定义背景颜色、网格颜色、刻度颜色、曲线颜色等，可以设置网格大小、刻度间隔、曲线进展长度，最重要的是可以支持多曲线运行。

名称：Graph
VERSION 5.00
Begin VB.UserControl Graph
   AutoRedraw      =   -1  'True
   BackColor       =   &H00000000&
   ClientHeight    =   1605
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   2880
   ForeColor       =   &H8000000B&
   HitBehavior     =   0  '无
   ScaleHeight     =   1605
   ScaleWidth      =   2880
End
Attribute VB_Name = "Graph"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_Coll() As Collection
Private m_Color() As OLE_COLOR
Private m_Time As Collection

Private m_MaxValue As Single
Private m_ScaleColor As OLE_COLOR
Private m_GridColor As OLE_COLOR
Private m_CellWidth As Single
Private m_CellHeight As Single
Private m_Spaced As Single
Private m_ValueScale As Single
Private m_TimeScale As Long

Private m_ShowGraph As Boolean
Private m_ShowGrid As Boolean
Private m_ShowValueScale As Boolean
Private m_ShowTimeScale As Boolean

'背景颜色
Public Property Get BackColor() As OLE_COLOR
    BackColor = UserControl.BackColor
End Property
Public 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_ScaleColor
End Property
Public 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_GridColor
End Property
Public 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_ShowGraph
End Property
Public Property Let ShowGraph(ByVal Value As Boolean)
    m_ShowGraph = Value
    Call AddValue
    PropertyChanged "ShowGraph"
End Property

'网格是否可见
Public Property Get ShowGrid() As Boolean
    ShowGrid = m_ShowGrid
End Property
Public Property Let ShowGrid(ByVal Value As Boolean)
    m_ShowGrid = Value
    Call AddValue
    PropertyChanged "ShowGrid"
End Property

'值刻度是否可见
Public Property Get ShowValueScale() As Boolean
    ShowValueScale = m_ShowValueScale
End Property
Public Property Let ShowValueScale(ByVal Value As Boolean)
    m_ShowValueScale = Value
    Call AddValue
    PropertyChanged "ShowValueScale"
End Property

'时间刻度是否可见
Public Property Get ShowTimeScale() As Boolean
    ShowTimeScale = m_ShowTimeScale
End Property
Public Property Let ShowTimeScale(ByVal Value As Boolean)
    m_ShowTimeScale = Value
    Call AddValue
    PropertyChanged "ShowTimeScale"
End Property

'单格宽度
Public Property Get CellWidth() As Single
    CellWidth = m_CellWidth
End Property
Public Property Let CellWidth(ByVal Value As Single)
    m_CellWidth = Value
    Call AddValue
    PropertyChanged "CellWidth"
End Property

'单格宽度
Public Property Get CellHeight() As Single
    CellHeight = m_CellHeight
End Property
Public Property Let CellHeight(ByVal Value As Single)
    m_CellHeight = Value
    Call AddValue
    PropertyChanged "CellHeight"
End Property

'值间隔
Public Property Get Spaced() As Long
    Spaced = m_Spaced
End Property
Public Property Let Spaced(ByVal Value As Long)
    m_Spaced = Value
    Call AddValue
    PropertyChanged "Spaced"
End Property

'值刻度
Public Property Get ValueScale() As Long
    ValueScale = m_ValueScale
End Property
Public Property Let ValueScale(ByVal Value As Long)
    m_ValueScale = Value
    Call AddValue
    PropertyChanged "ValueScale"
End Property

'时间刻度
Public Property Get TimeScale() As Long
    TimeScale = m_TimeScale
End Property
Public Property Let TimeScale(ByVal Value As Long)
    m_TimeScale = Value
    PropertyChanged "TimeScale"
End Property

'最大比例
Public Property Get MaxValue() As Single
    MaxValue = m_MaxValue
End Property
Public 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) + 1
End Property

Private Sub UserControl_Resize()
    Call AddValue
End Sub

Private Sub UserControl_Show()
    Call AddValue
End Sub

Private Sub UserControl_Initialize()
    UserControl.ScaleMode = 3
    Set m_Time = New Collection
End Sub

Private Sub UserControl_Terminate()
    Dim i As Long
    For i = 0 To GraphCount - 1
        Set m_Coll(i) = Nothing
    Next
    Set m_Time = Nothing
End Sub

Private 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 Sub

Private 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 Sub

Public 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
    Next
End 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) = Color
End 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 If
s:
        '纵坐标
        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
    DoEvents
End Sub

 

使用方法：
设置好各项属性后：
Option Explicit
Private 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
    Loop

End Sub