clscurve.cls

咋老是不能够上传

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsCurve"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
  Option Explicit
    
  Private m_hMemDC     As Long
  Private m_hBakDC     As Long
  Private m_hOutDC     As Long
  Private m_hOldMemBmp     As Long
  Private m_hOldBakBmp     As Long
  Private m_hOldMemPen     As Long
  Private m_hBrush     As Long
    
  Private m_nXUnitLen     As Long
  Private m_nYUnitLen     As Long
  Private m_nPrevY     As Long
  Private R     As RECT
      
  '下面的是clsCurve类模块
  '===========================================================
    
    
  Public Sub SetView(ByVal hOutDC As Long, _
                                                  ByVal nWidth As Long, _
                                                  ByVal nHeight As Long, _
                                                  ByVal nXUnits As Long, _
                                                  ByVal nYUnits As Long)
            
          Dim hObject     As Long
          m_hOutDC = hOutDC
          R.Left = 0:       R.Top = 0
          R.Bottom = nHeight
          R.Right = nWidth
          m_nXUnitLen = nWidth \ nXUnits
          m_nYUnitLen = nHeight \ nYUnits
            
          m_hMemDC = CreateCompatibleDC(hOutDC)
          m_hBakDC = CreateCompatibleDC(hOutDC)
            
            
          hObject = CreateCompatibleBitmap(hOutDC, nWidth, nHeight)
          m_hOldMemBmp = SelectObject(m_hMemDC, hObject)
            
          hObject = CreateCompatibleBitmap(hOutDC, nWidth, nHeight)
          m_hOldBakBmp = SelectObject(m_hBakDC, hObject)
            
          hObject = CreatePen(0, 1, vbBlack)
          m_hOldMemPen = SelectObject(m_hMemDC, hObject)
            
          m_hBrush = CreateSolidBrush(vbWhite)
          FillRect m_hMemDC, R, m_hBrush
          BitBlt m_hOutDC, 0, 0, nWidth, nHeight, m_hMemDC, 0, 0, vbSrcCopy
            
  End Sub
    
    
  Public Sub DrawCurve(ByVal nY As Long)
            
          '保留原来的曲线
          Dim nWidth     As Long, nHeight       As Long
          nWidth = R.Right
          nHeight = R.Bottom
            
          BitBlt m_hBakDC, 0, 0, nWidth, nHeight, m_hMemDC, 0, 0, vbSrcCopy
          FillRect m_hMemDC, R, m_hBrush
          '向左退移1个单位
          BitBlt m_hMemDC, 0, 0, nWidth, nHeight, m_hBakDC, m_nXUnitLen, 0, vbSrcCopy
            
          '画新的曲线
          Dim PrevPoint     As POINTAPI
          nY = nHeight - CLng(nY * m_nYUnitLen)
          MoveToEx m_hMemDC, nWidth - m_nXUnitLen, m_nPrevY, PrevPoint
            
          LineTo m_hMemDC, nWidth - 1, nY
    
          m_nPrevY = nY
            
          '输出结果
    
          BitBlt m_hOutDC, 0, 0, nWidth, nHeight, m_hMemDC, 0, 0, vbSrcCopy
            
  End Sub
    
    
    
    
  Public Sub RedrawCurve()
          If m_hMemDC = 0 Then Exit Sub
          BitBlt m_hOutDC, 0, 0, R.Right, R.Bottom, m_hMemDC, 0, 0, vbSrcCopy
  End Sub
    
  Public Property Get hdc() As Long
          hdc = m_hMemDC
  End Property
    
    
  Private Sub Class_Terminate()
          Dim hMemUsedBmp     As Long, hBakUsedBmp       As Long
          Dim hMemUsedPen     As Long
            
          hMemUsedBmp = SelectObject(m_hMemDC, m_hOldMemBmp)
          hBakUsedBmp = SelectObject(m_hBakDC, m_hOldBakBmp)
          hMemUsedPen = SelectObject(m_hMemDC, m_hOldMemPen)
          
          DeleteDC m_hMemDC
          DeleteDC m_hBakDC
            
          DeleteObject hMemUsedBmp
          DeleteObject hBakUsedBmp
          DeleteObject hMemUsedPen
          DeleteObject m_hBrush
  End Sub