加载中…
个人资料
微博
  • 博客等级：
  • 博客积分：
  • 博客访问：
  • 关注人气：
  • 获赠金笔：0支
  • 赠出金笔：0支
  • 荣誉徽章：
正文 字体大小：大 中 小

VB曲线绘制（自定义控件）

(2013-07-08 08:47:27)

看看这个自定义控件吧，其实人家VB没有想象得那么不堪！
代码：
Option Explicit

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

    Const DT_BOTTOM As Long = &H8
    Const DT_CALCRECT As Long = &H400
    Const DT_LEFT = &H0
    Const DT_TOP = &H0
    Const DT_VCENTER = &H4
    Const DT_CENTER As Long = &H1
    Const DT_WORDBREAK As Long = &H10
    
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type CurveData
    x As String
    y As Double
End Type


'保持属性值的局部变量
Private mvarstrTitle As String '局部复制
Private mvarXvalue As Variant  '局部复制
Private mvarYvalue As Variant '局部复制
Private mvarvalueCount As Long '局部复制
Private mvarstrXAxisName As String '局部复制
Private mvarstrYAxisName As String '局部复制

Private m_blnRefresh As Boolean

Private m_XAxisData() As Double    'X轴各点在Y轴上的值
Private m_XAxisName() As String    'X轴各点值
Private m_YAxisData() As Double    'Y轴各点值

Dim m_YScaleCount As Single

Private m_currentx As Single



Public Sub CreateChart()

On Error GoTo ErrHandle
    
    UserControl.ScaleMode = vbPixels
    PicFather.ScaleMode = vbPixels
'    PicFather.Height = 200
'    PicFather.Width = 400
    PicChild.ScaleMode = vbPixels
    
    'PicFather.Width = PicFather.ScaleX(PicFather.Width, vbTwips, vbPixels)
    'PicFather.Height = PicFather.ScaleY(PicFather.Height, vbTwips, vbPixels)

    If valueCount > 0 Then
    '绘图
        Dim CurveDatas() As CurveData
        ReDim CurveDatas(0 To valueCount - 1)
        Dim i As Long
        For i = 0 To valueCount - 1
            CurveDatas(i).x = CStr(Xvalue(i))
            CurveDatas(i).y = Yvalue(i)
        Next
        '找出Y轴最大值、最小值
        Dim MinY As Double
        Dim MaxY As Double
        
        MinY = CurveDatas(0).y
        MaxY = MinY
        
        For i = 1 To UBound(CurveDatas())
            If CurveDatas(i).y > MaxY Then
                MaxY = CurveDatas(i).y
            End If
            
            If CurveDatas(i).y < MinY Then
                MinY = CurveDatas(i).y
            End If
        Next
        
        If MaxY = MinY Then
            MaxY = MinY + 1
        End If

        ReDim m_XAxisData(0 To UBound(CurveDatas())) As Double
        ReDim m_XAxisName(0 To UBound(CurveDatas())) As String
        ReDim m_YAxisData(0 To 9) As Double
        'Dim strTitle As String        '标题
        'strTitle = "图形名"
        Dim strBottomNote As String   '底注
        strBottomNote = "制图日期：" & Format(Date, "YYYY年MM月DD日")
        'Dim strXAxisName As String    'X轴名
        'strXAxisName = "X"
        'Dim strYAxisName As String    'Y轴名
        'strYAxisName = "Y"
        
        
        For i = 0 To UBound(CurveDatas())
            m_XAxisData(i) = CurveDatas(i).y
            m_XAxisName(i) = CStr(CurveDatas(i).x)
        Next
        
        For i = 0 To UBound(m_YAxisData)
            m_YAxisData(i) = MinY + i * (MaxY - MinY) / (UBound(m_YAxisData))
        Next
        
        Const LSpace = 40 '左边距
        Const TSpace = 40 '顶边距
        Const RSpace = 40 '右边距
        Const BSpace = 40 '底边距
        
        Const XScaleWidth = 20 'X轴一格的宽度
        Const YScaleHeight = 20 'Y轴一格的高度
        
        PicChild.Cls
        PicChild.BackColor = RGB(255, 255, 255)
        
        Dim XFullWidth As Long 'X轴总宽度
        XFullWidth = LSpace + RSpace + XScaleWidth * (UBound(m_XAxisData) + 2)
        Dim YFullHeight As Long 'Y轴总高度
        YFullHeight = TSpace + BSpace + YScaleHeight * (UBound(m_YAxisData) + 2)
        
        
        If m_blnRefresh = False Then
        
            PicChild.Width = XFullWidth
            PicChild.Height = YFullHeight
            
            RefreshScroll
        
        End If
        
        
        Dim rect1 As RECT
         
        '图名
        PicChild.ForeColor = RGB(0, 0, 200)
        PicChild.Font.Size = 12
        PicChild.Font.Name = "黑体"
        PicChild.Font.Bold = False
        
       
        rect1.Left = 0
        rect1.Top = 10
        rect1.Bottom = TSpace
        rect1.Right = XFullWidth
        DrawText PicChild.hDC, strTitle, LenB(StrConv(strTitle, vbFromUnicode)), rect1, DT_CENTER

        '底注
        PicChild.ForeColor = RGB(255, 20, 20)
        PicChild.Font.Size = 10
        PicChild.Font.Name = "宋体"
        PicChild.Font.Bold = False
        
       
        rect1.Left = 10
        rect1.Top = YFullHeight - 20 'BSpace
        rect1.Bottom = YFullHeight
        rect1.Right = XFullWidth
        DrawText PicChild.hDC, strBottomNote, LenB(StrConv(strBottomNote, vbFromUnicode)), rect1, DT_LEFT
        
        'X轴线
        PicChild.ForeColor = RGB(0, 0, 0)
        PicChild.DrawStyle = vbSolid
        PicChild.Line (LSpace, YFullHeight - BSpace)-(XFullWidth - RSpace, YFullHeight - BSpace)
        
        'X轴刻度虚线
        PicChild.ForeColor = RGB(0, 0, 0)
        PicChild.DrawStyle = vbDot
        For i = 1 To UBound(m_XAxisData) + 1
            PicChild.Line (LSpace + i * XScaleWidth, YFullHeight - BSpace)-(LSpace + i * XScaleWidth, TSpace)
        Next i
        
        'X轴名
        PicChild.ForeColor = RGB(0, 0, 0)
        PicChild.Font.Size = 10
        PicChild.Font.Name = "宋体"
        PicChild.Font.Bold = True
        
        rect1.Left = XFullWidth - RSpace
        rect1.Top = YFullHeight - BSpace + 2
        rect1.Bottom = YFullHeight
        rect1.Right = XFullWidth
        DrawText PicChild.hDC, strXAxisName, LenB(StrConv(strXAxisName, vbFromUnicode)), rect1, DT_LEFT
        
        
        'X轴坐标值
        PicChild.ForeColor = RGB(0, 0, 0)
        PicChild.Font.Size = 8
        PicChild.Font.Name = "宋体"
        PicChild.Font.Bold = False
        For i = 1 To UBound(m_XAxisData) + 1
            rect1.Left = LSpace + (i - 0.5) * XScaleWidth
            rect1.Top = YFullHeight - BSpace + 2
            rect1.Bottom = YFullHeight
            rect1.Right = LSpace + (i + 0.5) * XScaleWidth
            DrawText PicChild.hDC, m_XAxisName(i - 1), LenB(StrConv(m_XAxisName(i - 1), vbFromUnicode)), rect1, DT_CENTER
        Next i
        
        'Y轴线
        PicChild.ForeColor = RGB(0, 0, 0)
        PicChild.DrawStyle = vbSolid
        PicChild.Line (LSpace, YFullHeight - BSpace)-(LSpace, TSpace)
        
        'Y轴刻度虚线
        PicChild.ForeColor = RGB(0, 0, 0)
        PicChild.DrawStyle = vbDot
        For i = 1 To UBound(m_YAxisData) + 1
            PicChild.Line (LSpace, TSpace + i * YScaleHeight)-(XFullWidth - RSpace, TSpace + i * YScaleHeight)
        Next i
          
        
        'Y轴名
        PicChild.ForeColor = RGB(0, 0, 0)
        PicChild.Font.Size = 10
        PicChild.Font.Name = "宋体"
        PicChild.Font.Bold = True
        
        rect1.Left = 10
        rect1.Top = TSpace - 15
        rect1.Bottom = TSpace
        rect1.Right = LSpace
        DrawText PicChild.hDC, strYAxisName, LenB(StrConv(strYAxisName, vbFromUnicode)), rect1, DT_LEFT
        

        'Y轴坐标值
        PicChild.ForeColor = RGB(0, 0, 0)
        PicChild.Font.Size = 8
        PicChild.Font.Name = "宋体"
        PicChild.Font.Bold = False
        For i = 1 To UBound(m_YAxisData) + 1
            rect1.Left = 0
            rect1.Top = YFullHeight - BSpace - i * YScaleHeight
            rect1.Bottom = YFullHeight - BSpace - (i - 1) * YScaleHeight
            rect1.Right = LSpace
            Dim strtemp As String
            strtemp = Format(CStr(m_YAxisData(i - 1)), "0.00")
            DrawText PicChild.hDC, strtemp, LenB(StrConv(strtemp, vbFromUnicode)), rect1, DT_CENTER
        Next i
   
        '数据
        PicChild.ForeColor = RGB(255, 0, 0)
        PicChild.DrawWidth = 2
        
        m_YScaleCount = (MaxY - MinY) / UBound(m_YAxisData)
        For i = 0 To UBound(m_XAxisData) - 1
            PicChild.Line (LSpace + (i + 1) * XScaleWidth, YFullHeight - BSpace - YScaleHeight - YScaleHeight * (m_XAxisData(i) - MinY) / m_YScaleCount) _
                         -(LSpace + (i + 2) * XScaleWidth, YFullHeight - BSpace - YScaleHeight - YScaleHeight * (m_XAxisData(i + 1) - MinY) / m_YScaleCount)
        Next
        
        PicChild.DrawWidth = 1
        
        If m_blnRefresh Then
            PicChild.ForeColor = RGB(0, 0, 255)
            PicChild.DrawStyle = vbSolid
            
            
            Dim nearestXindex
            nearestXindex = 0
            For i = 1 To UBound(m_XAxisData)
                If Abs(LSpace + (i + 1) * XScaleWidth - m_currentx) < Abs(LSpace + (nearestXindex + 1) * XScaleWidth - m_currentx) Then
                   nearestXindex = i
                End If
            Next
            PicChild.Line (LSpace + (nearestXindex + 1) * XScaleWidth, 0)-(LSpace + (nearestXindex + 1) * XScaleWidth, PicChild.Height)
            PicChild.Line (0, YFullHeight - BSpace - YScaleHeight - YScaleHeight * (m_XAxisData(nearestXindex) - MinY) / m_YScaleCount)-(PicChild.Width, YFullHeight - BSpace - YScaleHeight - YScaleHeight * (m_XAxisData(nearestXindex) - MinY) / m_YScaleCount)

            
            PicChild.ForeColor = RGB(0, 0, 0)
            PicChild.Font.Size = 8
            PicChild.Font.Name = "宋体"
            PicChild.Font.Bold = False
            rect1.Left = XFullWidth - 80
            rect1.Top = 5
            rect1.Bottom = 25
            rect1.Right = XFullWidth
            strtemp = strYAxisName & ":" & Format(CStr(CurveDatas(nearestXindex).y), "0.00")
            DrawText PicChild.hDC, strtemp, LenB(StrConv(strtemp, vbFromUnicode)), rect1, DT_LEFT
            
            rect1.Left = XFullWidth - 80
            rect1.Top = 25
            rect1.Bottom = 45
            rect1.Right = XFullWidth
            strtemp = strXAxisName & ":" & CStr(CurveDatas(nearestXindex).x)
            DrawText PicChild.hDC, strtemp, LenB(StrConv(strtemp, vbFromUnicode)), rect1, DT_LEFT
 
 
        
        End If
        
    End If

Exit Sub
ErrHandle:

End Sub

Private Sub RefreshScroll()
    PicChild.Left = 0
    PicChild.Top = 0
    VScroll1.Min = 0
    HScroll1.Min = 0
   
    VScroll1.Max = PicChild.Height - PicFather.Height
    HScroll1.Max = PicChild.Width - PicFather.Width
    
    HScroll1.LargeChange = PicFather.Width
    VScroll1.LargeChange = PicFather.Height
    
    HScroll1.SmallChange = HScroll1.LargeChange / 10
    VScroll1.SmallChange = VScroll1.LargeChange / 10

    If HScroll1.Max <= 0 Then
        HScroll1.Visible = False
    Else
        HScroll1.Visible = True
    End If
    
    If VScroll1.Max <= 0 Then
        VScroll1.Visible = False
    Else
        VScroll1.Visible = True
    End If

End Sub

Private Sub HScroll1_Change()
    PicChild.Left = -HScroll1.Value
End Sub

Private Sub PicChild_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

If valueCount > 0 Then
    m_blnRefresh = True
    m_currentx = x
    CreateChart
    'PicChild.ForeColor = RGB(0, 0, 255)
    'PicChild.DrawStyle = vbSolid
    'PicChild.Line (x, 0)-(x, PicChild.Height)
    ''PicChild.Line (0, y)-(PicChild.Width, y)
    m_blnRefresh = False
 End If
End Sub

Private Sub UserControl_Initialize()
    m_blnRefresh = False
End Sub

Private Sub VScroll1_Change()
    PicChild.Top = -VScroll1.Value
End Sub


Public Property Let strYAxisName(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.strYAxisName = 5
    mvarstrYAxisName = vData
End Property


Public Property Get strYAxisName() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.strYAxisName
    strYAxisName = mvarstrYAxisName
End Property



Public Property Let strXAxisName(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.strXAxisName = 5
    mvarstrXAxisName = vData
End Property


Public Property Get strXAxisName() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.strXAxisName
    strXAxisName = mvarstrXAxisName
End Property



Public Property Let valueCount(ByVal vData As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.valueCount = 5
    mvarvalueCount = vData
End Property


Public Property Get valueCount() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.valueCount
    valueCount = mvarvalueCount
End Property

Public Property Let Yvalue(ByVal vData As Variant)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Yvalue = 5
    mvarYvalue = vData
End Property


Public Property Set Yvalue(ByVal vData As Variant)
'向属性指派对象时使用，位于 Set 语句的左边。
'Syntax: Set x.Yvalue = Form1
    Set mvarYvalue = vData
End Property


Public Property Get Yvalue() As Variant
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Yvalue
    If IsObject(mvarYvalue) Then
        Set Yvalue = mvarYvalue
    Else
        Yvalue = mvarYvalue
    End If
End Property

Public Property Let Xvalue(ByVal vData As Variant)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Xvalue = 5
    mvarXvalue = vData
End Property


Public Property Set Xvalue(ByVal vData As Variant)
'向属性指派对象时使用，位于 Set 语句的左边。
'Syntax: Set x.Xvalue = Form1
    Set mvarXvalue = vData
End Property


Public Property Get Xvalue() As Variant
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Xvalue
    If IsObject(mvarXvalue) Then
        Set Xvalue = mvarXvalue
    Else
        Xvalue = mvarXvalue
    End If
End Property


Public Property Let strTitle(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.strTitle = 5
    mvarstrTitle = vData
End Property


Public Property Get strTitle() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.strTitle
    strTitle = mvarstrTitle
End Property







喜欢

0

阅读┊ 收藏 ┊ 喜欢▼ ┊打印┊举报/Report
前一篇：2013年07月01日
  

新浪BLOG意见反馈留言板　欢迎批评指正

新浪简介 | About Sina | 广告服务 | 联系我们 | 招聘信息 | 网站律师 | SINA English | 产品答疑

Copyright © 1996 - 2022 SINA Corporation, All Rights Reserved

新浪公司 版权所有