7,763
社区成员
发帖
与我相关
我的任务
分享请问vb如何画1个填充的圆？
line后面有bf
可是circle就没有，只能circle( x,y),半径,颜色
以前basic的paint语句也没有，不知道如何实现，谢谢
可是circle就没有，只能circle( x,y),半径,颜色
以前basic的paint语句也没有，不知道如何实现，谢谢
...全文
请发表友善的回复…
发表回复
vbangle 2005-11-01
- 打赏
- 举报
使用API实现的方法适合在设计控件时作图
vbangle 2005-11-01
- 打赏
- 举报
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
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
northwolves 2005-11-01
- 打赏
- 举报
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
Me.AutoRedraw = True
Me.FillStyle = 0
Me.FillColor = vbRed
Me.Scale (0, 0)-(4, 4)
Me.Circle (2, 2), 1, vbBlue
End Sub
vbangle 2005-11-01
- 打赏
- 举报
粘贴到文本文件中后改后缀为frm
vbangle 2005-11-01
- 打赏
- 举报
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 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 Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private 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 Sub
Private 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 Sub
Private 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 Sub
Private 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 Sub
Private Sub Command3_Click()
Picture2.Cls
hm2.Caption = ""
End Sub
Private Sub Command4_Click()
Picture1.Cls
hm1.Caption = ""
End Sub
vbangle 2005-11-01
- 打赏
- 举报
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 Type
Private Type GRADIENT_RECT
UpperLeft As Long
LowerRight As Long
End Type
Private 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 Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
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 Type
Private Type GRADIENT_RECT
UpperLeft As Long
LowerRight As Long
End Type
Private 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 Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
