by Anonymous (267 Submissions)
Category: Custom Controls/Forms/Menus
Compatability: Visual Basic 4.0 (32-bit)
Difficulty: Unknown Difficulty
Originally Published: Wed 2nd June 1999
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Shade a form
API Declarations
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 DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
VBcoders
'
' Optional Arguments:
' StartColor is what color to start with.
' (Default = vbBlue)
' Fstep is the number of steps to use to fill the form.
' (Default = 64)
' Cstep is the color step (change in color per step).
' (Default = 4)
'
' Note: the effect can be reversed by calling ShadeForm with
' a StartColor near black (but not completely 0) and by
' setting a negative color step.
'
Public Sub ShadeForm(f As Form, Optional StartColor As Variant, Optional Fstep As Variant, Optional Cstep As Variant)
Dim FillStep As Single ' Not an integer because sometimes
' rounding leaves a large bottom region
Dim c As Long
Dim FillArea As RECT
Dim i As Integer
Dim oldm As Integer
Dim hBrush As Long
Dim c2(1 To 3) As Long
Dim cs2(1 To 3) As Long
Dim fs As Long
Dim cs As Integer
' Set defaults
fs = IIf(IsMissing(Fstep), 64, CLng(Fstep))
cs = IIf(IsMissing(Cstep), 4, CInt(Cstep))
c = IIf(IsMissing(StartColor), vbBlue, CLng(StartColor))
oldm = f.ScaleMode
f.ScaleMode = vbPixels
FillStep = f.ScaleHeight / fs
FillArea.Left = 0
FillArea.Right = f.ScaleWidth
FillArea.Top = 0
' Break down the color and set individual
' color steps
c2(1) = c And 255#
cs2(1) = IIf(c2(1) > 0, cs, 0)
c2(2) = (c \ 256#) And 255#
cs2(2) = IIf(c2(2) > 0, cs, 0)
c2(3) = (c \ 65536#) And 255#
cs2(3) = IIf(c2(3) > 0, cs, 0)
For i = 1 To fs
FillArea.Bottom = FillStep * i
hBrush = CreateSolidBrush(RGB(c2(1), c2(2), c2(3)))
FillRect f.hdc, FillArea, hBrush
DeleteObject hBrush
' Could do this in a loop, but it's simple
' and may be faster.
c2(1) = (c2(1) - cs2(1)) And 255#
c2(2) = (c2(2) - cs2(2)) And 255#
c2(3) = (c2(3) - cs2(3)) And 255#
FillArea.Top = FillArea.Bottom
Next i
f.ScaleMode = oldm
End Sub
