vb6: заполнить полигон градиентом - PullRequest
Новая
       91

vb6: заполнить полигон градиентом

1 голос
/ 18 сентября 2010

Может кто-нибудь сказать мне, возможно ли заполнить полигон градиентом под vb6?

ТНХ

Ответы [ 2 ]

1 голос
/ 18 сентября 2010

Код ниже нарисует прямоугольник с градиентом.Я немного изменил его из этой темы с vbcity.com.

Перетащите это в модуль: 

Public 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
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Sub gdiDrawGradient( _
            ByVal hdc As Long, _
            ByRef rct As RECT, _
            ByVal lEndColor As Long, _
            ByVal lStartColor As Long, _
            ByVal bVertical As Boolean)

    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) = lStartColor And &HFF&
    bRGB(2) = (lStartColor And &HFF00&) \ &H100&
    bRGB(3) = (lStartColor And &HFF0000) \ &H10000
    bRGBStart(1) = bRGB(1): bRGBStart(2) = bRGB(2): bRGBStart(3) = bRGB(3)
    dR(1) = (lEndColor And &HFF&) - bRGB(1)
    dR(2) = ((lEndColor And &HFF00&) \ &H100&) - bRGB(2)
    dR(3) = ((lEndColor 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

        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 Command1_Click()
    Dim r As RECT

    r.Left = 10
    r.Top = 10
    r.Right = 100
    r.Bottom = 150
    Call gdiDrawGradient(Me.hdc, r, vbRed, vbBlue, True)
End Sub
0 голосов
/ 20 сентября 2010
...