CodeItBetter Programming Another VB Programming Blog

'Forms - How to Make Gradient Forms (in two ways)

'Without using API:

Option Explicit
 
'This example will make a Form/Picture Box with dithered background
'Set the Form AutoRedraw property to True.

Sub Gradient(TheObject As Object, ByVal Redval As Long, ByVal Greenval As Long, _
    ByVal Blueval As Long, ByVal Direction As Integer)
    Dim Step As Integer, Reps As Integer, FillTop As Integer
    Dim FillLeft As Integer, FillRight As Integer, FillBottom As Integer
    If Direction < 1 Or Direction > 4 Then Direction = 1
    FillTop = 0
    FillLeft = 0
    If Direction < 3 Then
        Step = (TheObject.Height / 100)
        If Direction = 2 Then FillTop = TheObject.Height - Step
        FillBottom = FillTop + Step
        FillRight = TheObject.Width
    Else
        Step = (TheObject.Width / 100)
        If Direction = 4 Then FillLeft = TheObject.Width - Step
        FillRight = FillLeft + Step
        FillBottom = TheObject.Height
    End If
    For Reps = 1 To 100
        If Direction = 2 And Reps = 100 Then FillTop = 0
        If Direction = 4 And Reps = 100 Then FillLeft = 0
        Redval = Redval - 3
        Greenval = Greenval - 3
        Blueval = Blueval - 3
        If Redval <= 0 Then Redval = 0
        If Greenval <= 0 Then Greenval = 0
        If Blueval <= 0 Then Blueval = 0
        TheObject.Line (FillLeft, FillTop)-(FillRight, FillBottom), RGB(Redval, Greenval, Blueval), _
            BF
        If Direction < 3 Then
            If Direction = 1 Then
                FillTop = FillBottom
            Else
                FillTop = FillTop - Step
            End If
            FillBottom = FillTop + Step
        Else
            If Direction = 3 Then
                FillLeft = FillRight
            Else
                FillLeft = FillLeft - Step
            End If
            FillRight = FillLeft + Step
        End If
    Next Reps
End Sub
 
Private Sub Form_Load()
    Gradient Me, 200, 100, 300, 1
    'Here:
    '200 - the Value for red color
    '100 - the Value for Green color
    '300 - the Value for Blue color
    '1   - the Direction of Painting
           'Direction of painting should be
           '1 - from top
           '2 - from bottom,
           '3 - from left
           '4 - from right.
    'These values should be same for both load and resize event
End Sub
 
Private Sub Form_Resize()
    Gradient Me, 200, 100, 300, 1
End Sub
 
'Using API:

Option Explicit
 
'Add two command buttons to your form. The first one is to fill gradient and second one is to clear.

Public Type TRIVERTEX
    x As Long
    y As Long
    Red As Integer
    Green As Integer
    Blue As Integer
    Alpha As Integer
End Type
Public Type GRADIENT_RECT
    UpperLeft As Long
    LowerRight As Long
End Type
Public Const GRADIENT_FILL_RECT_H As Long = &H0
Public Const GRADIENT_FILL_RECT_V As Long = &H1
Declare Function GradientFillRect Lib "msimg32" Alias "GradientFill" (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 Sub Form_Load()
    Me.ScaleMode = vbPixels
End Sub
 
Private Function LongToUShort(ULong As Long) As Integer
    LongToUShort = CInt(ULong - &H10000)
End Function
 
Private Function UShortToLong(Ushort As Integer) As Long
    UShortToLong = (CLng(Ushort) And &HFFFF&)
End Function
 
Private Sub Command2_Click()
    Cls
End Sub
 
Private Sub Command1_Click()
    Dim vert(1) As TRIVERTEX
    Dim gRect As GRADIENT_RECT
    With vert(0)
        .x = 0
        .y = 0
        .Red = 0&
        .Green = &HFF&
        .Blue = 0&
        .Alpha = 0&
    End With
    With vert(1)
        .x = Me.ScaleWidth
        .y = Me.ScaleHeight
        .Red = 0&
        .Green = LongToUShort(&HFF00&)
        .Blue = LongToUShort(&HFF00&)
        .Alpha = 0&
    End With
    gRect.UpperLeft = 1
    gRect.LowerRight = 0
    'replace GRADIENT_FILL_RECT_H with GRADIENT_FILL_RECT_V  to paint
    'the form with vertically gradient, instead of horizontally gradient
    GradientFillRect Me.hdc, vert(0), 2, gRect, 1, GRADIENT_FILL_RECT_H
End Sub