Visual Basic Window/Form Routines
FillRect: Gradient Form Backgrounds
     
Posted:   Thursday December 26, 1996
Updated:   Monday December 26, 2011
     
Applies to:   VB4-32, VB5, VB6, and VB3, VB4-16 with appropriate declarations
Developed with:   VB4-32, Windows 95
OS restrictions:   None
Author:   VBnet - Randy Birch
     

Related:  

FillRect: Gradient Form Backgrounds
GradientFill: Gradient Form Backgrounds
GradientFill: Triangular Gradient Form Backgrounds
Pure VB: Tile an Image as a Form Background

     
 Prerequisites
None.

The code presented here uses the API to create a gradient form background. The illustration shows the form with several controls which can be used on top of the gradient without degrading its look.

This example uses blue to black fading, however with a bit of tweaking any gradient range could be used. The sample was tested at all colour depths (256, 16k, 24k, 32k) except 16 colour at a screen resolution of 1024x768, and at 16 bit and 24 bit depths at 800x600. The illustration is the 256 colour version; the higher colour depths give a smoother blue-to-black transition.
 BAS Module Code
None.

 Form Code
Add a form to the project. The form requires no controls, however a menu needs to be created. Name the menu array items using the name 'mnuStyle', and add the 4 gradient options (diagonal as index 0, horizontal as index 1, vertical as index 2 and solid as index 3). An end command is optional. Set the form's AutoRedraw and ClipControls properties to True. Add the following code:

Option Explicit
Private Const PLANES As Long = 14   'Number of planes
Private Const BITSPIXEL As Long= 12 'Number of bits per pixel

Private 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 DeleteObject Lib "gdi32" _
   (ByVal hObject As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" _
   (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Declare Function FillRect Lib "user32" _
   (ByVal hDC As Long, lpRect As RECT, _
    ByVal hBrush As Long) As Long         

Private fadeStyle As Long



Private Sub Form_Load()

   fadeStyle = 0
   mnuStyle(fadeStyle).Checked = True
  
End Sub


Private Sub Form_MouseDown(Button As Integer, _
                           Shift As Integer, _
                           X As Single, Y As Single)
   
  'Substitute the name of the parent menu item below.
  'I prefer to prefix unused menus with Z to keep them 
  'at the bottom of the form object list.
   If Button = 2 Then PopupMenu zmnuStyle
  
End Sub


Private Sub Form_Resize()
   
  'avoid an error by checking the
  'windowstate before redrawing
   If WindowState <> 1 Then FadeForm Me, fadeStyle

End Sub


Private Sub mnuStyle_Click(Index As Integer)
   
  'track the current selection   
   Static prevStyle As Integer
   
  'uncheck the last selection   
   mnuStyle(prevStyle).Checked = False
   
  'set the variable indicating the style   
   fadeStyle = Index
   
  'draw the new style   
   FadeForm Me, fadeStyle
   
  'update the current selection   
   mnuStyle(fadeStyle).Checked = True
   prevStyle = fadeStyle

End Sub


Private Sub Command1_Click()
   
  'if you added an end button, add this code   
   Unload Me
   
End Sub


Private Sub mnuEnd_Click(Index As Integer)
   
  'if you added an end menu command, add this code   
   Unload Me
    
End Sub


Private Sub FadeForm(frmIn As Form, fadeStyle As Integer)
   
  'fadeStyle = 0 produces diagonal gradient
  'fadeStyle = 1 produces vertical gradient
  'fadeStyle = 2 produces horizontal gradient
  'any other value produces solid medium-blue background   
   Static ColorBits As Long
   Static RgnCnt As Integer
    
   Dim NbrPlanes As Long
   Dim BitsPerPixel As Long
   Dim AreaHeight As Long
   Dim AreaWidth As Long
   Dim BlueLevel As Long
   Dim prevScaleMode As Integer
   Dim IntervalY As Long
   Dim IntervalX As Long
   Dim cnt As Long
   Dim ColorVal As Long
   Dim FillArea As RECT
   Dim hBrush As Long
  
  'init code - performed only on the 
  'first pass through this routine.   
   If ColorBits = 0 Then
      
     'determine number of color bits supported.   
      BitsPerPixel = GetDeviceCaps(frmIn.hDC, BITSPIXEL)
      NbrPlanes = GetDeviceCaps(frmIn.hDC, PLANES)
      ColorBits = (BitsPerPixel * NbrPlanes)
     
     'Calculate the number of regions that the 
     'screen will be divided into. This is optimized 
     'for the current display's color depth.  Why 
     'waste time rendering 256 shades if you can 
     'only discern 32 or 64 of them?   
      Select Case ColorBits
         Case 32:   RgnCnt = 256   '16M colors:  8 bits for blue
         Case 24:   RgnCnt = 256   '16M colors:  8 bits for blue
         Case 16:   RgnCnt = 256   '64K colors:  5 bits for blue
         Case 15:   RgnCnt = 32    '32K colors:  5 bits for blue
         Case 8:    RgnCnt = 64    '256 colors:  64 dithered blues
         Case 4:    RgnCnt = 64    '16 colors :  64 dithered blues
         Case Else: ColorBits = 4
                    RgnCnt = 64    '16 colors assumed: 64 dithered blues
      End Select
    
   End If
  
  'if solid then set and bail out 
   If fadeStyle = 3 Then
       frmIn.BackColor = &H7F0000 'med blue
       Exit Sub
   End If
                
  'save the current ScaleMode 
  'and set to pixel
   prevScaleMode = frmIn.ScaleMode    
   frmIn.ScaleMode = 3                
   AreaHeight = frmIn.ScaleHeight     

  'calculate sizes 
   AreaWidth = frmIn.ScaleWidth
   frmIn.ScaleMode = prevScaleMode    

  'reset to saved value 
   ColorVal = 256 / RgnCnt           

  'color diff between regions 
   IntervalY = AreaHeight / RgnCnt    

  '# vert pixels per region 
   IntervalX = AreaWidth / RgnCnt     

  '# horz pixels per region 
  'fill the client area from bottom/right
  'to top/left except for top/left region 
   FillArea.Left = 0
   FillArea.Top = 0
   FillArea.Right = AreaWidth
   FillArea.Bottom = AreaHeight
   BlueLevel = 0
  
   For cnt = 0 To RgnCnt - 1
     
     'create a brush of the appropriate blue colour 
      hBrush = CreateSolidBrush(RGB(0, 0, BlueLevel))
      
      If fadeStyle = 0 Then 

        'diagonal gradient 
         FillArea.Top = FillArea.Bottom - IntervalY
         FillArea.Left = 0
         Call FillRect(frmIn.hDC, FillArea, hBrush)
          
         FillArea.Top = 0
         FillArea.Left = FillArea.Right - IntervalX
         Call FillRect(frmIn.hDC, FillArea, hBrush)
          
         FillArea.Bottom = FillArea.Bottom - IntervalY
         FillArea.Right = FillArea.Right - IntervalX
          
      ElseIf fadeStyle = 1 Then 

        'horizontal gradient 
         FillArea.Top = FillArea.Bottom - IntervalY
         Call FillRect(frmIn.hDC, FillArea, hBrush)
         FillArea.Bottom = FillArea.Bottom - IntervalY
          
      Else 

        'vertical gradient 
         FillArea.Left = FillArea.Right - IntervalX
         Call FillRect(frmIn.hDC, FillArea, hBrush)
         FillArea.Right = FillArea.Right - IntervalX

      End If

     'done with the brush, so delete
      Call DeleteObject(hBrush)
     
     'increment the value by the appropriate
     'steps for the display colour depth 
      BlueLevel = BlueLevel + ColorVal
  
   Next
  
  'Fill any the remaining top/left holes of the 
  'client area with solid blue 
   FillArea.Top = 0
   FillArea.Left = 0
  
   hBrush = CreateSolidBrush(RGB(0, 0, 255))
   Call FillRect(frmIn.hDC, FillArea, hBrush)
   Call DeleteObject(hBrush)
  
   Me.Refresh

End Sub
 Comments
Run the project. Selecting a menu item either by the dropdown or popup menu will redraw the form background appropriately.

 
 

PayPal Link
Make payments with PayPal - it's fast, free and secure!

 
 
 
 

Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy

 

Hit Counter