'下面的是clsCurve类模块
'===========================================================
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
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
'下面的是modGDI模块
'===========================================================
Option Explicit
Public Type POINTAPI
x
As Long
y
As Long
End Type
Public Type RECT
Left
As Long
Top
As Long
Right
As Long
Bottom
As Long
End Type
Public Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
'下面的是frmMain窗体,注意自己创建控件
'===========================================================
Option Explicit
Dim CurveDrawer
As clsCurve
Private Sub cmdDemo_Click()
Dim nY
As Long
CurveDrawer.SetView picOut.hdc, picOut.Width - 10, picOut.Height - 10, 50, 50
Timer.Enabled = True
End Sub
Private Sub Form_Load()
ScaleMode = 3
Timer.Interval = 500
Timer.Enabled = False
Set CurveDrawer = New clsCurve
End Sub
Private Sub picOut_Paint()
CurveDrawer.RedrawCurve
End Sub
Private Sub Timer_Timer()
CurveDrawer.DrawCurve CLng(Rnd * 51)
End Sub