'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@           Smooth Fade Bas By WILDeHACK ([[Email Removed]])
'@  Modified From Module Received from Daniel Appleman
'@  From his Book "Visual Basic Programmer's Guide to the Window's API"
'@
'@
'@ Use At your Own Risk
'@
'@ Steps to do this
'@ 1) Put a pictureBox on your form ans Call it "faded"
'@ 2) Place that picturebox in the upper-left corner of the screen, touching the sides
'@ 3) In the form_Load event, add this code: TheFormLoad me
'@ 4) In the Form_Resize Event, add this code: ResizeTheForm me
'@ 5) In the Picture_Paint Event, add this:  FillPicture Me
'@ 6) You should be set
'@
'@  Check out |
'@            |
'@            \/


'Mess with this number to determine the number of sections to be contructed
'The greater the number, the smoother the fade
Global CONST PALENTRIES = 64





TYPE POINTAPI  '4 Bytes - Synonymous with LONG
        X AS INTEGER
        y AS INTEGER
END TYPE

TYPE SIZEAPI  '4 Bytes - Synonymous with LONG
        X AS INTEGER
        y AS INTEGER
END TYPE

' ParameterBlock description structure for use with LoadModule
TYPE PARAMETERBLOCK  '14 Bytes
        wEnvSeg AS INTEGER
        lpCmdLine AS LONG
        lpCmdShow AS LONG
        dwReserved AS LONG
END TYPE


'  GDI Logical Objects:

'  Pel Array
TYPE PELARRAY  ' 10 Bytes
        paXCount AS INTEGER
        paYCount AS INTEGER
        paXExt AS INTEGER
        paYExt AS INTEGER
        paRGBs AS INTEGER
END TYPE

'  Logical Brush (or Pattern)
TYPE LOGBRUSH     '8 Bytes
        lbStyle AS INTEGER
        lbColor AS LONG
        lbHatch AS INTEGER
END TYPE

'  Logical Pen
TYPE LOGPEN    '10 Bytes
        lopnStyle AS INTEGER
        lopnWidth AS POINTAPI
        lopnColor AS LONG
END TYPE

TYPE PALETTEENTRY    '4 Bytes
        peRed AS STRING * 1
        peGreen AS STRING * 1
        peBlue AS STRING * 1
        peFlags AS STRING * 1
END TYPE

'  Logical Palette
TYPE LOGPALETTE
        palVersion AS INTEGER
        palNumEntries AS INTEGER
        palPalEntry AS STRING * 252 ' Array length is arbitrary; may be changed
END TYPE
' Project PalTest

' Module containing global contstants and general purpose
' routines.
DECLARE FUNCTION SetClipboardData Lib "User" (BYVAL wFormat AS INTEGER, BYVAL hMem AS INTEGER) AS INTEGER
DECLARE FUNCTION CloseClipboard Lib "User" () AS INTEGER
DECLARE FUNCTION OpenClipboard Lib "User" (BYVAL hWnd AS INTEGER) AS INTEGER
DECLARE SUB AnimatePalette Lib "GDI" (BYVAL hPalette%, BYVAL wStartIndex%, BYVAL wNumEntries%, lpPaletteColors AS PALETTEENTRY)
DECLARE FUNCTION SendMessageByNum& Lib "User" ALIAS "SendMessage" (BYVAL hWnd%, BYVAL wMsg%, BYVAL wParam%, BYVAL lParam&)
OPTION Explicit
Global CONST PC_RESERVED = &H1
Global CONST PC_EXPLICIT = &H2
Global CONST PC_NOCOLLAPSE = &H4
Global CONST DIB_RGB_COLORS = 0
Global CONST DIB_PAL_COLORS = 1
Global CONST SYSPAL_STATIC = 1
Global CONST SYSPAL_NOSTATIC = 2
Global CONST CF_TEXT = 1
Global CONST CF_BITMAP = 2
Global CONST CF_METAFILEPICT = 3
Global CONST CF_SYLK = 4
Global CONST CF_DIF = 5
Global CONST CF_TIFF = 6
Global CONST CF_OEMTEXT = 7
Global CONST CF_DIB = 8
Global CONST CF_PALETTE = 9
Global CONST CF_OWNERDISPLAY = &H80
Global CONST CF_DSPTEXT = &H81
Global CONST CF_DSPBITMAP = &H82
Global CONST CF_DSPMETAFILEPICT = &H83
Global CONST CF_PRIVATEFIRST = &H200
Global CONST CF_PRIVATELAST = &H2FF


'   This is similar to the LOGPALLETTE defined in
'   APIDECS.BAS, however instead of using a buffer, we
'   create a 64 entry palette for our use.

TYPE LOGPALETTE64
        palVersion AS INTEGER
        palNumEntries AS INTEGER
        palPalEntry(PALENTRIES) AS PALETTEENTRY
END TYPE

' And create a type safe alias to create palette that handles this structure
DECLARE FUNCTION CreatePalette64% Lib "GDI" ALIAS "CreatePalette" (lpLogPalette AS LOGPALETTE64)


' The six palettes that this program will use are defined here
Global UsePalettes%
Global logPalettes AS LOGPALETTE64

' This is a message used within Visual Basic to retrieve
' the handle of a palette
Global CONST VBM_GETPALETTE% = &H101C

'   This function creates 6 palettes that are used by
'   the PalTest program
'
SUB CreateAllPalettes ()
    DIM entrynum%
    DIM oldmouseptr%
    DIM X%

    oldmouseptr% = SCREEN.MousePointer
    SCREEN.MousePointer = 11
    ' Initialize the logical palette
   
        logPalettes.palVersion = &H300
        logPalettes.palNumEntries = PALENTRIES
   
    FOR entrynum% = 0 TO PALENTRIES - 1
        logPalettes.palPalEntry(entrynum%).peRed = CHR$(0)
        logPalettes.palPalEntry(entrynum%).peGreen = CHR$(0)
        logPalettes.palPalEntry(entrynum%).peBlue = CHR$((255 * entrynum%) / PALENTRIES)
        logPalettes.palPalEntry(entrynum%).peFlags = CHR$(PC_RESERVED)
    NEXT entrynum%


    ' And create the palettes
 
        UsePalettes = CreatePalette64(logPalettes)
    SCREEN.MousePointer = oldmouseptr%
END SUB

'   FillPicture draws a spectrum in the specified picture
'   control using the appropriate palette for that control
'
SUB FillPicture (asdf AS Form)
    DIM totwidth&, startloc&, endloc&
    DIM pic AS control
    DIM X&
    'Dim rc As RECT
    'Dim usebrush%
    'Dim t%

    Set pic = asdf.faded

    totwidth& = pic.ScaleHeight
    FOR X& = 0 TO PALENTRIES - 1
        ' We're using long arithmetic for speed. Note the
        ' ordering of operations to preserve precesion
        startloc& = (totwidth& * X&) / PALENTRIES
        endloc& = (totwidth& * (X& + 1)) / PALENTRIES
        pic.LINE (0, startloc&)-(pic.ScaleWidth, endloc&), GetPalColor(X&), BF
    NEXT X&

END SUB

'
'   Gets the Long RGB color for a palette entry
'
FUNCTION GetPalColor& (entry&)
    DIM res&
    DIM pe AS PALETTEENTRY
    LSET pe = logPalettes.palPalEntry(entry&)
    ' We build a long value using this rather awkward
    ' shifting technique.
    ' We actually could save time by performing a raw
    ' memory copy from the pe object into a long variable.
    ' since they are the same format.
    res& = ASC(pe.peRed)
    res& = res& OR (ASC(pe.peGreen) * 256&)
    res& = res& OR (ASC(pe.peBlue) * 256& * 256&)
    GetPalColor& = res&
END FUNCTION

SUB resizetheform (pop AS Form)
pop.faded.Height = pop.Height
pop.faded.WIDTH = pop.WIDTH
END SUB

SUB TheFormLoad (xyz AS Form)
    xyz.faded.Height = xyz.Height
    xyz.faded.WIDTH = xyz.WIDTH
    DIM X%, h%

    CreateAllPalettes
   
   
        h% = OpenClipboard(xyz.hWnd)
        IF h% = 0 THEN
            MsgBox "Can't open clipboard"
            END
        END IF
        h% = SetClipboardData(CF_PALETTE, UsePalettes%)
        h% = CloseClipboard()
        xyz.faded.Picture = Clipboard.GetData(CF_PALETTE)
    ' don't own them any more, so don't mess with them.

   

END SUB