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