找来的一个例子:'used with fnWeight Const FW_DONTCARE = 0 Const FW_THIN = 100 Const FW_EXTRALIGHT = 200 Const FW_LIGHT = 300 Const FW_NORMAL = 400 Const FW_MEDIUM = 500 Const FW_SEMIBOLD = 600 Const FW_BOLD = 700 Const FW_EXTRABOLD = 800 Const FW_HEAVY = 900 Const FW_BLACK = FW_HEAVY Const FW_DEMIBOLD = FW_SEMIBOLD Const FW_REGULAR = FW_NORMAL Const FW_ULTRABOLD = FW_EXTRABOLD Const FW_ULTRALIGHT = FW_EXTRALIGHT 'used with fdwCharSet Const ANSI_CHARSET = 0 Const DEFAULT_CHARSET = 1 Const SYMBOL_CHARSET = 2 Const SHIFTJIS_CHARSET = 128 Const HANGEUL_CHARSET = 129 Const CHINESEBIG5_CHARSET = 136 Const OEM_CHARSET = 255 'used with fdwOutputPrecision Const OUT_CHARACTER_PRECIS = 2 Const OUT_DEFAULT_PRECIS = 0 Const OUT_DEVICE_PRECIS = 5 'used with fdwClipPrecision Const CLIP_DEFAULT_PRECIS = 0 Const CLIP_CHARACTER_PRECIS = 1 Const CLIP_STROKE_PRECIS = 2 'used with fdwQuality Const DEFAULT_QUALITY = 0 Const DRAFT_QUALITY = 1 Const PROOF_QUALITY = 2 'used with fdwPitchAndFamily Const DEFAULT_PITCH = 0 Const FIXED_PITCH = 1 Const VARIABLE_PITCH = 2 'used with SetBkMode Const OPAQUE = 2 Const TRANSPARENT = 1Const LOGPIXELSY = 90 Const COLOR_WINDOW = 5 Const Message = "Hello !"Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End TypePrivate Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Private 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 Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Dim mDC As Long, mBitmap As Long Private Sub Form_Click() Unload Me End Sub Private Sub Form_Load() 'KPD-Team 1999 'URL: http://www.allapi.net/ 'E-Mail: [email protected] Dim mRGN As Long, Cnt As Long, mBrush As Long, R As RECT 'Create a device context, compatible with the screen mDC = CreateCompatibleDC(GetDC(0)) 'Create a bitmap, compatible with the screen mBitmap = CreateCompatibleBitmap(GetDC(0), Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY) 'Select the bitmap nito the device context SelectObject mDC, mBitmap 'Set the bitmap's backmode to transparent SetBkMode mDC, TRANSPARENT 'Set the rectangles' values SetRect R, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY 'Fill the rect with the default window-color FillRect mDC, R, GetSysColorBrush(COLOR_WINDOW) For Cnt = 0 To 350 Step 30 'Select the new font into the form's device context and delete the old font DeleteObject SelectObject(mDC, CreateMyFont(24, Cnt)) 'Print some text TextOut mDC, (Me.Width / Screen.TwipsPerPixelX) / 2, (Me.Height / Screen.TwipsPerPixelY) / 2, Message, Len(Message) Next Cnt 'Create an elliptical region mRGN = CreateEllipticRgn(0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY) 'Set the window region SetWindowRgn Me.hWnd, mRGN, True 'delete our elliptical region DeleteObject mRGN End Sub Function CreateMyFont(nSize As Integer, nDegrees As Long) As Long 'Create a specified font CreateMyFont = CreateFont(-MulDiv(nSize, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72), 0, nDegrees * 10, 0, FW_NORMAL, False, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, "Times New Roman") End Function Private Sub Form_Paint() 'Copy the picture to the form BitBlt Me.hdc, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY, mDC, 0, 0, vbSrcCopy End Sub Private Sub Form_Unload(Cancel As Integer) 'clean up DeleteDC mDC DeleteObject mBitmap End Sub
函数说明:【VB声明】 Private Declare Function BitBlt Lib "gdi32" Alias "BitBlt" (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【说明】 将一幅位图从一个设备场景复制到另一个。源和目标DC相互间必须兼容 【返回值】 Long,非零表示成功,零表示失败。会设置GetLastError 【备注】 在NT环境下,如在一次世界传输中要求在源设备场景中进行剪切或旋转处理,这个函数的执行会失败 如目标和源DC的映射关系要求矩形中像素的大小必须在传输过程中改变,那么这个函数会根据需要自动伸缩、旋转、折叠、或切断,以便完成最终的传输过程【参数表】 hDestDC -------- Long,目标设备场景 x,y ------------ Long,对目标DC中目标矩形左上角位置进行描述的那个点。用目标DC的逻辑坐标表示 nWidth,nHeight - Long,欲传输图象的宽度和高度 hSrcDC --------- Long,源设备场景。如光栅运算未指定源,则应设为0 xSrc,ySrc ------ Long,对源DC中源矩形左上角位置进行描述的那个点。用源DC的逻辑坐标表示 dwRop ---------- Long,传输过程要执行的光栅运算
'建立标准工程,添加一个按钮,一个timer就行了 Option Explicit Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private 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 Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long Private Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private Const PS_SOLID = 0 Private Const SRCCOPY = &HCC0020 Private Const pi = 3.1415926 Private Const BS_SOLID = 0 Dim g__index As Integer Dim memdc(0 To 40) As Long Dim membmp(0 To 40) As Long Dim oldbmp(0 To 40) As Long Private Sub c_Click() If LCase(c.Caption) = "start" Then t.Enabled = True c.Caption = "stop" Else t.Enabled = False c.Caption = "start" End If End SubPrivate Sub Form_Load() c.Caption = "start" t.Enabled = False t.Interval = 50 Dim i As Integer For i = 0 To 40 memdc(i) = CreateCompatibleDC(Me.hdc) membmp(i) = CreateCompatibleBitmap(Me.hdc, 200, 200) oldbmp(i) = SelectObject(memdc(i), membmp(i)) Next i For i = 0 To 40 draw i, 200, 200 Next i End SubPrivate Sub Form_Unload(Cancel As Integer) Dim i As Integer For i = 0 To 40 SelectObject memdc(i), oldbmp(i) DeleteObject membmp(i) DeleteDC memdc(i) Next i End SubPrivate Sub draw(ByVal angle As Integer, ByVal nw As Long, ByVal nh As Long) Dim i As Double Dim j As Double Dim x As Double Dim y As Double Dim rx As Double Dim ry As Double Dim r0 As Double Dim r1 As Double Dim xx As Long Dim yy As Long rx = nw / 2 ry = nh / 2 r0 = 70 r1 = 20 Dim hpen As Long Dim oldpen As Long Dim hbrush As Long Dim oldbrush As Long Dim log As LOGBRUSH log.lbColor = CLng(RGB(0, Abs(angle - 20) * 12, 0)) log.lbStyle = BS_SOLID hbrush = CreateBrushIndirect(log) oldbrush = SelectObject(memdc(angle), hbrush) Rectangle memdc(angle), 0, 0, nw, nh SelectObject memdc(angle), oldbrush DeleteObject hbrush hpen = CreatePen(PS_SOLID, 1, CLng(RGB(Abs(angle - 20) * 12, 0, Abs(angle - 20) * 12))) oldpen = SelectObject(memdc(angle), hpen) For i = 0 To 2 * pi Step pi / 4 For j = 0 To 2 * pi Step pi / 10 x = rx + r0 * Cos(i + (angle / 40) * 2 * pi) y = ry + r0 * Sin(i + (angle / 40) * 2 * pi) xx = x + r1 * Cos(j) yy = y + r1 * Sin(j) Ellipse memdc(angle), xx - 3, yy - 3, xx + 3, yy + 3 Next j Next i SelectObject memdc(angle), oldpen DeleteObject hpen End SubPrivate Sub t_Timer() BitBlt Me.hdc, 0, 0, 200, 200, memdc(g__index), 0, 0, SRCCOPY g__index = g__index + 1 If g__index > 40 Then g__index = 1 End If End Sub
Const FW_DONTCARE = 0
Const FW_THIN = 100
Const FW_EXTRALIGHT = 200
Const FW_LIGHT = 300
Const FW_NORMAL = 400
Const FW_MEDIUM = 500
Const FW_SEMIBOLD = 600
Const FW_BOLD = 700
Const FW_EXTRABOLD = 800
Const FW_HEAVY = 900
Const FW_BLACK = FW_HEAVY
Const FW_DEMIBOLD = FW_SEMIBOLD
Const FW_REGULAR = FW_NORMAL
Const FW_ULTRABOLD = FW_EXTRABOLD
Const FW_ULTRALIGHT = FW_EXTRALIGHT
'used with fdwCharSet
Const ANSI_CHARSET = 0
Const DEFAULT_CHARSET = 1
Const SYMBOL_CHARSET = 2
Const SHIFTJIS_CHARSET = 128
Const HANGEUL_CHARSET = 129
Const CHINESEBIG5_CHARSET = 136
Const OEM_CHARSET = 255
'used with fdwOutputPrecision
Const OUT_CHARACTER_PRECIS = 2
Const OUT_DEFAULT_PRECIS = 0
Const OUT_DEVICE_PRECIS = 5
'used with fdwClipPrecision
Const CLIP_DEFAULT_PRECIS = 0
Const CLIP_CHARACTER_PRECIS = 1
Const CLIP_STROKE_PRECIS = 2
'used with fdwQuality
Const DEFAULT_QUALITY = 0
Const DRAFT_QUALITY = 1
Const PROOF_QUALITY = 2
'used with fdwPitchAndFamily
Const DEFAULT_PITCH = 0
Const FIXED_PITCH = 1
Const VARIABLE_PITCH = 2
'used with SetBkMode
Const OPAQUE = 2
Const TRANSPARENT = 1Const LOGPIXELSY = 90
Const COLOR_WINDOW = 5
Const Message = "Hello !"Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End TypePrivate Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private 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
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Dim mDC As Long, mBitmap As Long
Private Sub Form_Click()
Unload Me
End Sub
Private Sub Form_Load()
'KPD-Team 1999
'URL: http://www.allapi.net/
'E-Mail: [email protected]
Dim mRGN As Long, Cnt As Long, mBrush As Long, R As RECT
'Create a device context, compatible with the screen
mDC = CreateCompatibleDC(GetDC(0))
'Create a bitmap, compatible with the screen
mBitmap = CreateCompatibleBitmap(GetDC(0), Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY)
'Select the bitmap nito the device context
SelectObject mDC, mBitmap
'Set the bitmap's backmode to transparent
SetBkMode mDC, TRANSPARENT
'Set the rectangles' values
SetRect R, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY
'Fill the rect with the default window-color
FillRect mDC, R, GetSysColorBrush(COLOR_WINDOW) For Cnt = 0 To 350 Step 30
'Select the new font into the form's device context and delete the old font
DeleteObject SelectObject(mDC, CreateMyFont(24, Cnt))
'Print some text
TextOut mDC, (Me.Width / Screen.TwipsPerPixelX) / 2, (Me.Height / Screen.TwipsPerPixelY) / 2, Message, Len(Message)
Next Cnt 'Create an elliptical region
mRGN = CreateEllipticRgn(0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY)
'Set the window region
SetWindowRgn Me.hWnd, mRGN, True 'delete our elliptical region
DeleteObject mRGN
End Sub
Function CreateMyFont(nSize As Integer, nDegrees As Long) As Long
'Create a specified font
CreateMyFont = CreateFont(-MulDiv(nSize, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72), 0, nDegrees * 10, 0, FW_NORMAL, False, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, "Times New Roman")
End Function
Private Sub Form_Paint()
'Copy the picture to the form
BitBlt Me.hdc, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY, mDC, 0, 0, vbSrcCopy
End Sub
Private Sub Form_Unload(Cancel As Integer)
'clean up
DeleteDC mDC
DeleteObject mBitmap
End Sub
Private Declare Function BitBlt Lib "gdi32" Alias "BitBlt" (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【说明】
将一幅位图从一个设备场景复制到另一个。源和目标DC相互间必须兼容 【返回值】
Long,非零表示成功,零表示失败。会设置GetLastError 【备注】
在NT环境下,如在一次世界传输中要求在源设备场景中进行剪切或旋转处理,这个函数的执行会失败
如目标和源DC的映射关系要求矩形中像素的大小必须在传输过程中改变,那么这个函数会根据需要自动伸缩、旋转、折叠、或切断,以便完成最终的传输过程【参数表】
hDestDC -------- Long,目标设备场景 x,y ------------ Long,对目标DC中目标矩形左上角位置进行描述的那个点。用目标DC的逻辑坐标表示 nWidth,nHeight - Long,欲传输图象的宽度和高度 hSrcDC --------- Long,源设备场景。如光栅运算未指定源,则应设为0 xSrc,ySrc ------ Long,对源DC中源矩形左上角位置进行描述的那个点。用源DC的逻辑坐标表示 dwRop ---------- Long,传输过程要执行的光栅运算
Option Explicit
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private 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
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Const PS_SOLID = 0
Private Const SRCCOPY = &HCC0020
Private Const pi = 3.1415926
Private Const BS_SOLID = 0
Dim g__index As Integer
Dim memdc(0 To 40) As Long
Dim membmp(0 To 40) As Long
Dim oldbmp(0 To 40) As Long
Private Sub c_Click()
If LCase(c.Caption) = "start" Then
t.Enabled = True
c.Caption = "stop"
Else
t.Enabled = False
c.Caption = "start"
End If
End SubPrivate Sub Form_Load()
c.Caption = "start"
t.Enabled = False
t.Interval = 50
Dim i As Integer
For i = 0 To 40
memdc(i) = CreateCompatibleDC(Me.hdc)
membmp(i) = CreateCompatibleBitmap(Me.hdc, 200, 200)
oldbmp(i) = SelectObject(memdc(i), membmp(i))
Next i
For i = 0 To 40
draw i, 200, 200
Next i
End SubPrivate Sub Form_Unload(Cancel As Integer)
Dim i As Integer
For i = 0 To 40
SelectObject memdc(i), oldbmp(i)
DeleteObject membmp(i)
DeleteDC memdc(i)
Next i
End SubPrivate Sub draw(ByVal angle As Integer, ByVal nw As Long, ByVal nh As Long)
Dim i As Double
Dim j As Double
Dim x As Double
Dim y As Double
Dim rx As Double
Dim ry As Double
Dim r0 As Double
Dim r1 As Double
Dim xx As Long
Dim yy As Long
rx = nw / 2
ry = nh / 2
r0 = 70
r1 = 20
Dim hpen As Long
Dim oldpen As Long
Dim hbrush As Long
Dim oldbrush As Long
Dim log As LOGBRUSH
log.lbColor = CLng(RGB(0, Abs(angle - 20) * 12, 0))
log.lbStyle = BS_SOLID
hbrush = CreateBrushIndirect(log)
oldbrush = SelectObject(memdc(angle), hbrush)
Rectangle memdc(angle), 0, 0, nw, nh
SelectObject memdc(angle), oldbrush
DeleteObject hbrush
hpen = CreatePen(PS_SOLID, 1, CLng(RGB(Abs(angle - 20) * 12, 0, Abs(angle - 20) * 12)))
oldpen = SelectObject(memdc(angle), hpen)
For i = 0 To 2 * pi Step pi / 4
For j = 0 To 2 * pi Step pi / 10
x = rx + r0 * Cos(i + (angle / 40) * 2 * pi)
y = ry + r0 * Sin(i + (angle / 40) * 2 * pi)
xx = x + r1 * Cos(j)
yy = y + r1 * Sin(j)
Ellipse memdc(angle), xx - 3, yy - 3, xx + 3, yy + 3
Next j
Next i
SelectObject memdc(angle), oldpen
DeleteObject hpen
End SubPrivate Sub t_Timer()
BitBlt Me.hdc, 0, 0, 200, 200, memdc(g__index), 0, 0, SRCCOPY
g__index = g__index + 1
If g__index > 40 Then
g__index = 1
End If
End Sub