Just create a new Module and then paste this source code into it. You should name the class basFormEffects.
'----------------------------------------------------------------------
'
' Module Name: basFormEffects
' Written By: C&D Programming Corp.
' Create Date: 1/99
' Copyright: Copyright 1999 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
Option Explicit
Option Explicit
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
' This routine works with these color selections.
' vbBlack
' vbRed
' vbGreen
' vbYellow
' vbBlue
' vbMagenta
' vbCyan
' vbWhite
Public Sub GradientFill(Obj As Form, lTopColor As Long, lBottomColor As Long)
Dim lRow As Long
Dim sngRedDiff As Single
Dim sngBlueDiff As Single
Dim sngGreenDiff As Single
Dim sngRed As Single
Dim sngBlue As Single
Dim sngGreen As Single
Dim lRet As Long
' set scale to force palette to a "nice" size.
Obj.Scale (0, 255)-(1, 0)
lRet = RealizePalette(Obj.hdc)
If lRet <> 0 Then
Err.Raise 5, "GradientFill", "Could not realize palette."
End If
sngRed = Red(lTopColor)
sngBlue = Blue(lTopColor)
sngGreen = Green(lTopColor)
sngRedDiff = ColorDivisor(Red(lTopColor) - Red(lBottomColor))
sngGreenDiff = ColorDivisor(Green(lTopColor) - Green(lBottomColor))
sngBlueDiff = ColorDivisor(Blue(lTopColor) - Blue(lBottomColor))
For lRow = 0 To 255
Obj.Line (0, lRow)-(1, lRow - 1), RGB(CInt(sngRed), CInt(sngGreen), CInt(sngBlue)), BF
sngRed = ColorShift(sngRed, sngRedDiff)
sngBlue = ColorShift(sngBlue, sngBlueDiff)
sngGreen = ColorShift(sngGreen, sngGreenDiff)
Next
End Sub
Private Function ColorDivisor(lColor As Long) As Single
ColorDivisor = IIf(lColor = 0, 0, lColor / 256)
End Function
'
' We use singles to allow for partial colors (not the extremes)
'
Private Function ColorShift(sngColor As Single, sngDiff As Single) As Single
sngColor = sngColor + sngDiff
If sngColor > 255.5 Then
ColorShift = 0
Else
If sngColor < 0 Then
ColorShift = 255
Else
ColorShift = sngColor
End If
End If
End Function
'
' An easy trick to isolate a single color into a value from 0 to 255.
'
Private Function Red(lColor As Long) As Integer
Red = CInt("&h" & Left(Hex(lColor And vbRed), 2))
End Function
Private Function Blue(lColor As Long) As Integer
Blue = CInt("&h" & Left(Hex(lColor And vbBlue), 2))
End Function
Private Function Green(lColor As Long) As Integer
Green = CInt("&h" & Left(Hex(lColor And vbGreen), 2))
End Function