Visual Basic Window/Form Routines
GradientFill: Gradient Form Backgrounds
     
Posted:   Monday February 17, 2003
Updated:   Monday December 26, 2011
     
Applies to:   VB4-32, VB5, VB6
Developed with:   VB6, Windows XP
OS restrictions:   Windows 98 or later, Windows 2000 or later
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.

For those using the FillRect gradient fill demo at FillRect: Gradient Form Backgrounds, here's a faster method to achieve a horizontal or vertical two-colour gradient fill. For more information about the GradientFill methods, see the GradientFill: Triangular Gradient Form Backgrounds demo. As with the Triangle demo, this code is also suitable for use in filling a picture box used as a colour-picking tool.
 BAS Module Code
None.

 Form Code
Add the following code to a form:

Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const GRADIENT_FILL_RECT_H  As Long = &H0
Private Const GRADIENT_FILL_RECT_V  As Long = &H1
Private Const GRADIENT_FILL_TRIANGLE As Long = &H2
Private GRADIENT_FILL_RECT_DIRECTION As Long

Private Const GRADIENT_COLOR1 As Long = &HFF0000
Private Const GRADIENT_COLOR2 As Long = &H0
      
Private Type TRIVERTEX
   x As Long
   Y As Long
   Red As Integer
   Green As Integer
   Blue As Integer
   Alpha As Integer
End Type

Private Type GRADIENT_RECT
   UpperLeft As Long
   LowerRight As Long
End Type
   
Private Declare Function GradientFill Lib "msimg32" _
  (ByVal hdc As Long, _
   pVertex As Any, _
   ByVal dwNumVertex As Long, _
   pMesh As Any, _
   ByVal dwNumMesh As Long, _
   ByVal dwMode As Long) As Long


Private Sub Command1_Click()
   
  'toggle the colour
   GRADIENT_FILL_RECT_DIRECTION = Not GRADIENT_FILL_RECT_DIRECTION
   Call DrawGradientFill(GRADIENT_COLOR1, GRADIENT_COLOR2)

End Sub

Private Sub Form_Load()

   Me.AutoRedraw = True
   
End Sub

Private Sub Form_Resize()

   Call DrawGradientFill(GRADIENT_COLOR1, GRADIENT_COLOR2)

End Sub


Private Sub DrawGradientFill(ByVal dwColour1 As Long, ByVal dwColour2 As Long)
    
   Dim vert(0 To 1) As TRIVERTEX
   Dim grRc As GRADIENT_RECT
  
  'Colour at upper-left corner
   With vert(0)
      .x = 0
      .Y = 0
      .Red = LongToSignedShort((dwColour1 And &HFF&) * 256)
      .Green = LongToSignedShort(((dwColour1 And &HFF00&) \ &H100&) * 256)
      .Blue = LongToSignedShort(((dwColour1 And &HFF0000) \ &H10000) * 256)
      .Alpha = 0
   End With

   
  'Colour at bottom-right corner
   With vert(1)
      .x = Me.ScaleWidth \ Screen.TwipsPerPixelX
      .Y = Me.ScaleHeight \ Screen.TwipsPerPixelY
      .Red = LongToSignedShort((dwColour2 And &HFF&) * 256)
      .Green = LongToSignedShort(((dwColour2 And &HFF00&) \ &H100&) * 256)
      .Blue = LongToSignedShort(((dwColour2 And &HFF0000) \ &H10000) * 256)
      .Alpha = 0
   End With

   With grRc
      .LowerRight = 0
      .UpperLeft = 1
   End With
   
   Me.Cls
   
  'parameters:
  'hdc - display context handle of the target window
  'vert(0) - first member of interest in the vert() array
  '2 - number of vert() array members (not ubound(vert))
  'grRc - GRADIENT_RECT info
  '1 - number of grRc structures passed
  'GRADIENT_FILL_RECT_DIRECTION - fill operation -  
  'will toggle between 0 and 1, the values of 
  'GRADIENT_FILL_RECT_H and GRADIENT_FILL_RECT_V.
   Call GradientFill(Me.hdc, vert(0), 2, grRc, 1, Abs(GRADIENT_FILL_RECT_DIRECTION))

End Sub


Private Function LongToSignedShort(dwUnsigned As Long) As Integer
    
  'convert from long to signed short
   If dwUnsigned < 32768 Then
      LongToSignedShort = CInt(dwUnsigned)
   Else
      LongToSignedShort = CInt(dwUnsigned - &H10000)
   End If
    
End Function
 Comments

 
 

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