VERSION 5.00 Begin VB.Form Frmtest Caption = "测试2种填充渐变椭圆区域的方法" ClientHeight = 4155 ClientLeft = 60 ClientTop = 345 ClientWidth = 5280 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 4155 ScaleWidth = 5280 StartUpPosition = 2 '屏幕中心 Begin VB.CommandButton Command4 Caption = "清除" Height = 375 Left = 1920 TabIndex = 11 Top = 1320 Width = 2055 End Begin VB.CommandButton Command3 Caption = "清除" Height = 375 Left = 2040 TabIndex = 10 Top = 3480 Width = 2055 End Begin VB.PictureBox Picture2 Appearance = 0 'Flat BackColor = &H80000005& ForeColor = &H80000008& Height = 1335 Left = 240 ScaleHeight = 87 ScaleMode = 3 'Pixel ScaleWidth = 95 TabIndex = 3 Top = 2520 Width = 1455 End Begin VB.CommandButton Command2 Caption = "方法二:画渐变椭圆" Height = 855 Left = 2040 TabIndex = 2 Top = 2520 Width = 2055 End Begin VB.CommandButton Command1 Caption = "方法一:画渐变椭圆" Height = 855 Left = 1920 TabIndex = 1 Top = 360 Width = 2055 End Begin VB.PictureBox Picture1 Appearance = 0 'Flat BackColor = &H80000005& ForeColor = &H000000C0& Height = 1335 Left = 240 ScaleHeight = 87 ScaleMode = 3 'Pixel ScaleWidth = 95 TabIndex = 0 Top = 360 Width = 1455 End Begin VB.Label hm2 BackColor = &H8000000A& ForeColor = &H000000FF& Height = 180 Left = 4320 TabIndex = 9 Top = 3000 Width = 360 End Begin VB.Label Label4 Caption = "毫秒" Height = 180 Left = 4320 TabIndex = 8 Top = 3360 Width = 360 End Begin VB.Label Label3 Caption = "耗时:" Height = 180 Left = 4320 TabIndex = 7 Top = 2760 Width = 540 End Begin VB.Label hm1 BackColor = &H8000000A& ForeColor = &H000000FF& Height = 180 Left = 4200 TabIndex = 6 Top = 840 Width = 360 End Begin VB.Label Label2 Caption = "毫秒" Height = 180 Left = 4200 TabIndex = 5 Top = 1200 Width = 360 End Begin VB.Label Label1 Caption = "耗时:" Height = 180 Left = 4200 TabIndex = 4 Top = 600 Width = 540 End End Attribute VB_Name = "Frmtest" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Const GRADIENT_FILL_RECT_H As Long = 0 Private Const GRADIENT_FILL_RECT_V As Long = 1 Private Type TRIVERTEX x As Long y As Long Red As Integer Green As Integer Blue As Integer alpha As Integer End TypePrivate Type GRADIENT_RECT UpperLeft As Long LowerRight As Long End TypePrivate Declare Function Arc Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long Private Declare Function GradientFill Lib "MSIMG32.dll" (ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long Private Const CLR_INVALID = -1 Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function timeGetTime Lib "winmm.dll" () As LongPrivate Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor 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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As LongPrivate 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 Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Sub Command1_Click() Dim rgn As Long Dim wid As Single Dim hgt As Single Dim Tmprect As RECT Dim t1 As Long Dim R2 As Long Dim hRPen As Long Dim hRpenSave As Long hm1.Caption = "" GetWindowRect Picture1.hwnd, Tmprect Tmprect.Right = Tmprect.Right - Tmprect.Left Tmprect.Bottom = Tmprect.Bottom - Tmprect.Top Tmprect.Left = 0 Tmprect.Top = 0 Picture1.Cls t1 = timeGetTime DrawGradient Picture1.hdc, Tmprect, &HFFFFFF, &HEABB99, True hm1.Caption = CStr(timeGetTime - t1) t1 = 0 ' Create the elliptical region. wid = ScaleX(Picture1.Width, vbTwips, vbPixels) hgt = ScaleY(Picture1.Height, vbTwips, vbPixels)
' Restrict the window to the region. SetWindowRgn Picture1.hwnd, rgn, True DeleteObject rgn
End Sub Private Sub DrawGradient( _ ByVal hdc As Long, _ ByRef rct As RECT, _ ByVal lEndColour As Long, _ ByVal lStartColour As Long, _ ByVal bVertical As Boolean _ ) 'Private Declare Function GradientFill Lib "Msimg32.dll" (ByVal hDC As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long Dim lStep As Long Dim lPos As Long, lSize As Long Dim bRGB(1 To 3) As Integer Dim bRGBStart(1 To 3) As Integer Dim dR(1 To 3) As Double Dim dPos As Double, d As Double Dim hBr As Long Dim tR As RECT
LSet tR = rct If bVertical Then lSize = (tR.Bottom - tR.Top) Else lSize = (tR.Right - tR.Left) End If lStep = lSize \ 255 If (lStep < 3) Then lStep = 3 End If
bRGB(1) = lStartColour And &HFF& bRGB(2) = (lStartColour And &HFF00&) \ &H100& bRGB(3) = (lStartColour And &HFF0000) \ &H10000 bRGBStart(1) = bRGB(1): bRGBStart(2) = bRGB(2): bRGBStart(3) = bRGB(3) dR(1) = (lEndColour And &HFF&) - bRGB(1) dR(2) = ((lEndColour And &HFF00&) \ &H100&) - bRGB(2) dR(3) = ((lEndColour And &HFF0000) \ &H10000) - bRGB(3)
For lPos = lSize To 0 Step -lStep ' Draw bar: If bVertical Then tR.Top = tR.Bottom - lStep Else tR.Left = tR.Right - lStep End If If tR.Top < rct.Top Then tR.Top = rct.Top End If If tR.Left < rct.Left Then tR.Left = rct.Left End If
End Sub Private Sub DrawGradient1( _ ByVal lHDC As Long, _ tR As RECT, _ ByVal oStartColor As OLE_COLOR, _ ByVal oEndColor As OLE_COLOR, _ ByVal bVertical As Boolean _ ) Dim hBrush As Long Dim lStartColor As Long Dim lEndColor As Long Dim lR As Long
' Use GradientFill: lStartColor = TranslateColor(oStartColor) lEndColor = TranslateColor(oEndColor)
Dim tTV(0 To 1) As TRIVERTEX Dim tGR As GRADIENT_RECT
End SubPrivate Sub setTriVertexColor(tTV As TRIVERTEX, lColor As Long) Dim lRed As Long Dim lGreen As Long Dim lBlue As Long lRed = (lColor And &HFF&) * &H100& lGreen = (lColor And &HFF00&) lBlue = (lColor And &HFF0000) \ &H100& setTriVertexColorComponent tTV.Red, lRed setTriVertexColorComponent tTV.Green, lGreen setTriVertexColorComponent tTV.Blue, lBlue End SubPrivate Sub setTriVertexColorComponent(ByRef iColor As Integer, ByVal lComponent As Long) If (lComponent And &H8000&) = &H8000& Then iColor = (lComponent And &H7F00&) iColor = iColor Or &H8000 Else iColor = lComponent End If End SubPrivate Function TranslateColor(ByVal oClr As OLE_COLOR, _ Optional hPal As Long = 0) As Long ' Convert Automation color to Windows color If OleTranslateColor(oClr, hPal, TranslateColor) Then TranslateColor = CLR_INVALID End If End Function Private Sub Command2_Click() Dim rgn As Long Dim wid As Single Dim hgt As Single Dim Tmprect As RECT Dim t2 As Long Dim R2 As Long Dim hRPen As Long Dim hRpenSave As Long hm2.Caption = "" GetWindowRect Picture2.hwnd, Tmprect Tmprect.Right = Tmprect.Right - Tmprect.Left Tmprect.Bottom = Tmprect.Bottom - Tmprect.Top Tmprect.Left = 0 Tmprect.Top = 0 Picture2.Cls t2 = timeGetTime DrawGradient1 Picture2.hdc, Tmprect, &HFFFFFF, &HEABB99, True hm2.Caption = CStr(timeGetTime - t2) t2 = 0 ' Create the elliptical region. wid = ScaleX(Picture2.Width, vbTwips, vbPixels) hgt = ScaleY(Picture2.Height, vbTwips, vbPixels)
' Restrict the window to the region. SetWindowRgn Picture2.hwnd, rgn, True DeleteObject rgn
End SubPrivate Sub Command3_Click() Picture2.Cls hm2.Caption = "" End SubPrivate Sub Command4_Click() Picture1.Cls hm1.Caption = "" End Sub
粘贴到文本文件中后改后缀为frm
Private Sub Form_Load() Me.AutoRedraw = True Me.FillStyle = 0 Me.FillColor = vbRed Me.Scale (0, 0)-(4, 4) Me.Circle (2, 2), 1, vbBlue End Sub
Option Explicit 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 FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) 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 Const RGN_AND = 1 Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Sub Form_Paint() Dim hRgn1 As Long, hRgn2 As Long, RetVal As Long, hBrush As Long Dim usew As Long, useh As Long Dim StepSize As Long Dim myColor As Integer Dim FillArea As RECT Dim X As Integer Me.Cls Me.ScaleMode = vbPixels usew = 200 useh = 200 Const StepCount = 200 StepSize = 1 myColor = 255 FillArea.Left = 0 FillArea.Right = 200 FillArea.Top = 0 FillArea.Bottom = StepSize For X = 1 To StepCount hBrush = CreateSolidBrush(RGB(myColor, 126, 255)) hRgn1 = CreateEllipticRgn(0, 0, usew, useh) hRgn2 = CreateRectRgnIndirect(FillArea) CombineRgn hRgn1, hRgn1, hRgn2, RGN_AND If hRgn1 Then FillRgn Me.hdc, hRgn1, hBrush DeleteObject hRgn1 DeleteObject hRgn2 RetVal = DeleteObject(hBrush) myColor = myColor - (255 / StepCount) If myColor < 0 Then myColor = 0 FillArea.Top = FillArea.Bottom FillArea.Bottom = FillArea.Bottom + StepSize Next '画边框 hBrush = CreateSolidBrush(RGB(0, 0, 0)) '画笔颜色 Ellipse Me.hdc, 0, 0, 200, 200 RetVal = DeleteObject(hBrush)End Sub Private Sub Form_Resize() Form_Paint End Sub
Begin VB.Form Frmtest
Caption = "测试2种填充渐变椭圆区域的方法"
ClientHeight = 4155
ClientLeft = 60
ClientTop = 345
ClientWidth = 5280
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 4155
ScaleWidth = 5280
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Command4
Caption = "清除"
Height = 375
Left = 1920
TabIndex = 11
Top = 1320
Width = 2055
End
Begin VB.CommandButton Command3
Caption = "清除"
Height = 375
Left = 2040
TabIndex = 10
Top = 3480
Width = 2055
End
Begin VB.PictureBox Picture2
Appearance = 0 'Flat
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 1335
Left = 240
ScaleHeight = 87
ScaleMode = 3 'Pixel
ScaleWidth = 95
TabIndex = 3
Top = 2520
Width = 1455
End
Begin VB.CommandButton Command2
Caption = "方法二:画渐变椭圆"
Height = 855
Left = 2040
TabIndex = 2
Top = 2520
Width = 2055
End
Begin VB.CommandButton Command1
Caption = "方法一:画渐变椭圆"
Height = 855
Left = 1920
TabIndex = 1
Top = 360
Width = 2055
End
Begin VB.PictureBox Picture1
Appearance = 0 'Flat
BackColor = &H80000005&
ForeColor = &H000000C0&
Height = 1335
Left = 240
ScaleHeight = 87
ScaleMode = 3 'Pixel
ScaleWidth = 95
TabIndex = 0
Top = 360
Width = 1455
End
Begin VB.Label hm2
BackColor = &H8000000A&
ForeColor = &H000000FF&
Height = 180
Left = 4320
TabIndex = 9
Top = 3000
Width = 360
End
Begin VB.Label Label4
Caption = "毫秒"
Height = 180
Left = 4320
TabIndex = 8
Top = 3360
Width = 360
End
Begin VB.Label Label3
Caption = "耗时:"
Height = 180
Left = 4320
TabIndex = 7
Top = 2760
Width = 540
End
Begin VB.Label hm1
BackColor = &H8000000A&
ForeColor = &H000000FF&
Height = 180
Left = 4200
TabIndex = 6
Top = 840
Width = 360
End
Begin VB.Label Label2
Caption = "毫秒"
Height = 180
Left = 4200
TabIndex = 5
Top = 1200
Width = 360
End
Begin VB.Label Label1
Caption = "耗时:"
Height = 180
Left = 4200
TabIndex = 4
Top = 600
Width = 540
End
End
Attribute VB_Name = "Frmtest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Const GRADIENT_FILL_RECT_H As Long = 0
Private Const GRADIENT_FILL_RECT_V As Long = 1
Private Type TRIVERTEX
x As Long
y As Long
Red As Integer
Green As Integer
Blue As Integer
alpha As Integer
End TypePrivate Type GRADIENT_RECT
UpperLeft As Long
LowerRight As Long
End TypePrivate Declare Function Arc Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
Private Declare Function GradientFill Lib "MSIMG32.dll" (ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As LongPrivate Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor 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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As LongPrivate 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 Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Sub Command1_Click()
Dim rgn As Long
Dim wid As Single
Dim hgt As Single
Dim Tmprect As RECT
Dim t1 As Long
Dim R2 As Long
Dim hRPen As Long
Dim hRpenSave As Long
hm1.Caption = ""
GetWindowRect Picture1.hwnd, Tmprect
Tmprect.Right = Tmprect.Right - Tmprect.Left
Tmprect.Bottom = Tmprect.Bottom - Tmprect.Top
Tmprect.Left = 0
Tmprect.Top = 0
Picture1.Cls
t1 = timeGetTime
DrawGradient Picture1.hdc, Tmprect, &HFFFFFF, &HEABB99, True
hm1.Caption = CStr(timeGetTime - t1)
t1 = 0
' Create the elliptical region.
wid = ScaleX(Picture1.Width, vbTwips, vbPixels)
hgt = ScaleY(Picture1.Height, vbTwips, vbPixels)
R2 = IIf(wid > hgt, hgt, wid)
rgn = CreateEllipticRgn(1, 1, R2, R2)
hRPen = CreatePen(0, 1, &H902D00)
hRpenSave = SelectObject(Picture1.hdc, hRPen)
Arc Picture1.hdc, 0, 0, R2 - 2, R2 - 2, 1, 1, 1, 1
SelectObject Picture1.hdc, hRpenSave
DeleteObject hRPen
' Restrict the window to the region.
SetWindowRgn Picture1.hwnd, rgn, True
DeleteObject rgn
End Sub
Private Sub DrawGradient( _
ByVal hdc As Long, _
ByRef rct As RECT, _
ByVal lEndColour As Long, _
ByVal lStartColour As Long, _
ByVal bVertical As Boolean _
)
'Private Declare Function GradientFill Lib "Msimg32.dll" (ByVal hDC As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
Dim lStep As Long
Dim lPos As Long, lSize As Long
Dim bRGB(1 To 3) As Integer
Dim bRGBStart(1 To 3) As Integer
Dim dR(1 To 3) As Double
Dim dPos As Double, d As Double
Dim hBr As Long
Dim tR As RECT
LSet tR = rct
If bVertical Then
lSize = (tR.Bottom - tR.Top)
Else
lSize = (tR.Right - tR.Left)
End If
lStep = lSize \ 255
If (lStep < 3) Then
lStep = 3
End If
bRGB(1) = lStartColour And &HFF&
bRGB(2) = (lStartColour And &HFF00&) \ &H100&
bRGB(3) = (lStartColour And &HFF0000) \ &H10000
bRGBStart(1) = bRGB(1): bRGBStart(2) = bRGB(2): bRGBStart(3) = bRGB(3)
dR(1) = (lEndColour And &HFF&) - bRGB(1)
dR(2) = ((lEndColour And &HFF00&) \ &H100&) - bRGB(2)
dR(3) = ((lEndColour And &HFF0000) \ &H10000) - bRGB(3)
For lPos = lSize To 0 Step -lStep
' Draw bar:
If bVertical Then
tR.Top = tR.Bottom - lStep
Else
tR.Left = tR.Right - lStep
End If
If tR.Top < rct.Top Then
tR.Top = rct.Top
End If
If tR.Left < rct.Left Then
tR.Left = rct.Left
End If
'Debug.Print tR.Right, tR.left, (bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1))
hBr = CreateSolidBrush((bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1)))
FillRect hdc, tR, hBr
DeleteObject hBr
' Adjust colour:
dPos = ((lSize - lPos) / lSize)
If bVertical Then
tR.Bottom = tR.Top
bRGB(1) = bRGBStart(1) + dR(1) * dPos
bRGB(2) = bRGBStart(2) + dR(2) * dPos
bRGB(3) = bRGBStart(3) + dR(3) * dPos
Else
tR.Right = tR.Left
bRGB(1) = bRGBStart(1) + dR(1) * dPos
bRGB(2) = bRGBStart(2) + dR(2) * dPos
bRGB(3) = bRGBStart(3) + dR(3) * dPos
End If
Next lPos
End Sub
Private Sub DrawGradient1( _
ByVal lHDC As Long, _
tR As RECT, _
ByVal oStartColor As OLE_COLOR, _
ByVal oEndColor As OLE_COLOR, _
ByVal bVertical As Boolean _
)
Dim hBrush As Long
Dim lStartColor As Long
Dim lEndColor As Long
Dim lR As Long
' Use GradientFill:
lStartColor = TranslateColor(oStartColor)
lEndColor = TranslateColor(oEndColor)
Dim tTV(0 To 1) As TRIVERTEX
Dim tGR As GRADIENT_RECT
setTriVertexColor tTV(0), lStartColor
tTV(0).x = tR.Left
tTV(0).y = tR.Top
setTriVertexColor tTV(1), lEndColor
tTV(1).x = tR.Right
tTV(1).y = tR.Bottom
tGR.UpperLeft = 0
tGR.LowerRight = 1
GradientFill lHDC, tTV(0), 2, tGR, 1, IIf(Not bVertical, GRADIENT_FILL_RECT_H, GRADIENT_FILL_RECT_V)
End SubPrivate Sub setTriVertexColor(tTV As TRIVERTEX, lColor As Long)
Dim lRed As Long
Dim lGreen As Long
Dim lBlue As Long
lRed = (lColor And &HFF&) * &H100&
lGreen = (lColor And &HFF00&)
lBlue = (lColor And &HFF0000) \ &H100&
setTriVertexColorComponent tTV.Red, lRed
setTriVertexColorComponent tTV.Green, lGreen
setTriVertexColorComponent tTV.Blue, lBlue
End SubPrivate Sub setTriVertexColorComponent(ByRef iColor As Integer, ByVal lComponent As Long)
If (lComponent And &H8000&) = &H8000& Then
iColor = (lComponent And &H7F00&)
iColor = iColor Or &H8000
Else
iColor = lComponent
End If
End SubPrivate Function TranslateColor(ByVal oClr As OLE_COLOR, _
Optional hPal As Long = 0) As Long
' Convert Automation color to Windows color
If OleTranslateColor(oClr, hPal, TranslateColor) Then
TranslateColor = CLR_INVALID
End If
End Function
Private Sub Command2_Click()
Dim rgn As Long
Dim wid As Single
Dim hgt As Single
Dim Tmprect As RECT
Dim t2 As Long
Dim R2 As Long
Dim hRPen As Long
Dim hRpenSave As Long
hm2.Caption = ""
GetWindowRect Picture2.hwnd, Tmprect
Tmprect.Right = Tmprect.Right - Tmprect.Left
Tmprect.Bottom = Tmprect.Bottom - Tmprect.Top
Tmprect.Left = 0
Tmprect.Top = 0
Picture2.Cls
t2 = timeGetTime
DrawGradient1 Picture2.hdc, Tmprect, &HFFFFFF, &HEABB99, True
hm2.Caption = CStr(timeGetTime - t2)
t2 = 0
' Create the elliptical region.
wid = ScaleX(Picture2.Width, vbTwips, vbPixels)
hgt = ScaleY(Picture2.Height, vbTwips, vbPixels)
R2 = IIf(wid > hgt, hgt, wid)
rgn = CreateEllipticRgn(1, 1, R2, R2)
hRPen = CreatePen(0, 1, &H902D00)
hRpenSave = SelectObject(Picture2.hdc, hRPen)
Arc Picture2.hdc, 0, 0, R2 - 2, R2 - 2, 1, 1, 1, 1
SelectObject Picture2.hdc, hRpenSave
DeleteObject hRPen
' Restrict the window to the region.
SetWindowRgn Picture2.hwnd, rgn, True
DeleteObject rgn
End SubPrivate Sub Command3_Click()
Picture2.Cls
hm2.Caption = ""
End SubPrivate Sub Command4_Click()
Picture1.Cls
hm1.Caption = ""
End Sub
Me.AutoRedraw = True
Me.FillStyle = 0
Me.FillColor = vbRed
Me.Scale (0, 0)-(4, 4)
Me.Circle (2, 2), 1, vbBlue
End Sub
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 FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) 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 Const RGN_AND = 1
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Sub Form_Paint()
Dim hRgn1 As Long, hRgn2 As Long, RetVal As Long, hBrush As Long
Dim usew As Long, useh As Long
Dim StepSize As Long
Dim myColor As Integer
Dim FillArea As RECT
Dim X As Integer
Me.Cls
Me.ScaleMode = vbPixels
usew = 200
useh = 200
Const StepCount = 200
StepSize = 1
myColor = 255
FillArea.Left = 0
FillArea.Right = 200
FillArea.Top = 0
FillArea.Bottom = StepSize
For X = 1 To StepCount
hBrush = CreateSolidBrush(RGB(myColor, 126, 255))
hRgn1 = CreateEllipticRgn(0, 0, usew, useh)
hRgn2 = CreateRectRgnIndirect(FillArea)
CombineRgn hRgn1, hRgn1, hRgn2, RGN_AND
If hRgn1 Then FillRgn Me.hdc, hRgn1, hBrush
DeleteObject hRgn1
DeleteObject hRgn2
RetVal = DeleteObject(hBrush)
myColor = myColor - (255 / StepCount)
If myColor < 0 Then myColor = 0
FillArea.Top = FillArea.Bottom
FillArea.Bottom = FillArea.Bottom + StepSize
Next
'画边框
hBrush = CreateSolidBrush(RGB(0, 0, 0)) '画笔颜色
Ellipse Me.hdc, 0, 0, 200, 200
RetVal = DeleteObject(hBrush)End Sub
Private Sub Form_Resize()
Form_Paint
End Sub