• Home
 · 
• Custom Controls/Forms/Menus
 · 
• Shade a form

Shade a form

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



Rate Shade a form

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

'
' 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