请问vb如何画1个填充的圆？

#1

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

#2

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

#3

粘贴到文本文件中后改后缀为frm

#4

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

#5

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

#6

使用API实现的方法适合在设计控件时作图

秒客网

请问vb如何画1个填充的圆？

6 个解决方案

#1

#2

#3

#4

#5

#6

#1

#2

#3

#4

#5

#6

相关文章