Category : BASIC Source Code
Archive   : VINST8.ZIP
Filename : FADE.BAS

' ========================================================
' This module courtesy of Brian Stine -- Thanks, Brian
' ========================================================

Option Explicit

' Data type used by FillRect
Type RECT
Left As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type

' API Functions used to create solid brush and draw brush on form
Declare Function CreateSolidBrush Lib "GDI" (ByVal crColor As Long) As Integer
Declare Function FillRect Lib "User" (ByVal hDC As Integer, lpRect As RECT, ByVal hBrush As Integer) As Integer
Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer

Dim hBrush%

Sub FadeForm (TheForm As Form)

Dim FormHeight%, Blue%, StepInterval%, X%, RetVal%, OldMode%
Dim FillArea As RECT

OldMode = TheForm.ScaleMode
TheForm.ScaleMode = 3 'Pixel
FormHeight = TheForm.ScaleHeight


' -----------------------------------------------------
' Divide the form into 63 regions
' -----------------------------------------------------
StepInterval = FormHeight \ 63
Blue = 255
FillArea.Left = 0
FillArea.Right = TheForm.ScaleWidth
FillArea.Top = 0
FillArea.Bottom = StepInterval
For X = 1 To 63
hBrush% = CreateSolidBrush(RGB(0, 0, Blue))
RetVal% = FillRect(TheForm.hDC, FillArea, hBrush)
RetVal% = DeleteObject(hBrush)
Blue = Blue - 4
FillArea.Top = FillArea.Bottom
FillArea.Bottom = FillArea.Bottom + StepInterval
Next


' -----------------------------------------------------
' Fill the remainder of the form with black
' -----------------------------------------------------
FillArea.Bottom = FillArea.Bottom + 63
hBrush% = CreateSolidBrush(RGB(0, 0, 0))
RetVal% = FillRect(TheForm.hDC, FillArea, hBrush)
RetVal% = DeleteObject(hBrush)
TheForm.ScaleMode = OldMode

Setup1.CurrentY = 5
Setup1.CurrentX = 5
Setup1.ForeColor = QBColor(15) ' Bright White


' -----------------------------------------------------
' To eliminate program ending if can't find
' a particular font
' -----------------------------------------------------
On Error Resume Next
Setup1.FontName = "Helv"
Setup1.FontSize = 24
Setup1.FontItalic = True
Setup1.FontBold = True
Setup1.Print gTitleName$
On Error GoTo 0


End Sub