'Globals '**************************************************************** 'Windows API/Global Declarations for :Creating a Gradient Form Background '**************************************************************** Public Const PLANES = 14' Number of planes Public Const BITSPIXEL = 12' Number of bits per pixel Type RECT LeftAs Long Top As Long RightAs Long Bottom As Long End Type Declare Function CreateSolidBrush Lib "gdi32" _ (ByVal crColor As Long) As Long Declare Function DeleteObject Lib "gdi32" _ (ByVal hObject As Long) As Long Declare Function GetDeviceCaps Lib "gdi32" _ (ByVal hDC As Long, ByVal nIndex As Long) As Long Declare Function FillRect Lib "user32" _ (ByVal hDC As Long, lpRect As RECT, _ ByVal hBrush As Long) As Long 'Code '**************************************************************** ' Name: Creating a Gradient Form Background ' Description:Creating a Gradient Form Backgroun. Using APIs ' , create a horizontal, vertical or diagonal gradient backgro ' und for your form. Several controls can be used on top of th ' e gradient without degrading it's look. With appropriate 16- ' bit API declarations, this code also applies to:  VB3 and  V ' B4-16. ' By: VB Net (Randy Birch) ' ' Inputs:None ' Returns:None ' Assumes:Begin a new project, adding a form and a bas module. 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.   ' Side Effects: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. ' 'Code provided by Planet Source Code(tm) 'as is', without ' warranties as to performance, fitness, merchantability, ' and any other warranty (whether expressed or implied). '**************************************************************** ' 'Add the following code to the form: Dim fadeStyle As Integer 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 hecking the windowstate before redrawing If WindowState < > 1 Then FadeForm Me, fadeStyle End If 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 cmdEnd_Click() ' 'if you added an end button, add this code Unload Me Set Form1 = Nothing End End Sub Private Sub mnuEnd_Click(Index As Integer) ' 'if you added an end menu command, add this code Unload Me Set Form1 = Nothing End 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 i As Integer Dim r As Long Dim ColorVal As Long Dim FillArea As RECT Dim hBrush As Long 'init code - performed only on the first pass through this r ' outine. 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 di ' vided o. 'This is optimized for the current display's color depth. W ' hy 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 prevScaleMode = frmIn.ScaleMode'save the current scalemode frmIn.ScaleMode = 3'set to pixel 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 i = 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 r = FillRect(frmIn.hDC, FillArea, hBrush) FillArea.Top = 0 FillArea.Left = FillArea.Right - IntervalX r = 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 r = FillRect(frmIn.hDC, FillArea, hBrush) FillArea.Bottom = FillArea.Bottom - IntervalY Else ' 'vertical gradient FillArea.Left = FillArea.Right - IntervalX r = FillRect(frmIn.hDC, FillArea, hBrush) FillArea.Right = FillArea.Right - IntervalX End If ' 'done with that brush, so delete r = 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)) r = FillRect(frmIn.hDC, FillArea, hBrush) r = DeleteObject(hBrush) Me.Refresh End Sub