gistfile1.vb

'modded by sir_mud 11/2013 to run with FB 0.90.1 (differences in ThreadCreate and added extremely minimal ini config)
' tweaked by tinram 6/6/07 to run with FB 0.17b (RETURNs in CASE statements were killing it)
' 0.16 original by jofers

'Option Explicit


#include "windows.bi"

type configuration
    count as integer
end type

Type SaverInfo
    Bounds As Rect
    Bv4Header As BITMAPV4HEADER
    ClassName As String
    EndDialogPtr As INT_PTR
    hInstance As HINSTANCE
    hDC As HDC
    hMemBM As HBITMAP
    hMemDC As HDC
    hWnd As HWND
    hWndParent As HWND
    IsClosing As BOOL
    IsPreview As BOOL
    Message As MSG
    MouseLocation As POINT
    PaintStruct As PAINTSTRUCT
    ScrWidth As uInteger
    ScrHeight As uInteger
    Style As uInteger
    StyleEx As uInteger
    Timer As Double
    TimerDelay As Double
    WindowClass As WNDCLASS
    config as configuration
End Type

Dim Shared SaverInfo As SaverInfo

Declare Sub SetupScreenMode
Declare Sub StartConfigDialog
Declare Sub StartScreenSaver
Declare Sub WindowThread( byval uu as any ptr )
Declare Function AboutDialogProc(ByVal hWndDlg As HWND, ByVal Message As UINT, ByVal wParam As WPARAM, ByVal lParam As LPARAM) As BOOL
Declare Function ScreenSaverProc(ByVal hWnd As HWND, ByVal Message As UINT, ByVal wParam As WPARAM, ByVal lParam As LPARAM) As LRESULT

'''''''''''
'StartScreenSaver
'
'Do Until SaverInfo.IsClosing = TRUE
    'Pset(Rnd * SaverInfo.ScrWidth, Rnd * SaverInfo.Scrheight), Rgb(Rnd * 255, Rnd * 255, Rnd * 255)
'Loop
'''''''''''

sub loadConfig
    var cf = environ("APPDATA") & "\HMC\flyer.ini"
    open cf for input as #1
    var l = ""
    while not eof(1)
        line input #1, l
        l = trim(lcase(l))

        if left(l,5) = "count" then
            SaverInfo.config.count = valint(mid(l,instr(l,"=")+1))
            if SaverInfo.config.count = 0 then SaverInfo.config.count = 15
        end if
    wend
end sub

Sub StartScreenSaver

    if command = "" or lcase(left(command,2)) = "/c" then
        StartConfigDialog
        end
    end if

    If LCase(Left(Command, 2)) = "/s" Then

        'do nothing
    End If

    If LCase(Left(Command, 2)) = "/p" Then SaverInfo.IsPreview = TRUE
    SetupScreenMode
    loadConfig
    ThreadCreate @WindowThread
End Sub

' Sets up GFXLib to be compatible with the screen
Sub SetupScreenMode
    Dim hScreenDC As HDC

    SaverInfo.ScrWidth = GetSystemMetrics(SM_CXSCREEN)
    SaverInfo.ScrHeight = GetSystemMetrics(SM_CYSCREEN)

    ScreenRes SaverInfo.ScrWidth, SaverInfo.ScrHeight, 32, 1, -1

    ' This helps Windows convert its BMP format to GFXLib's
    With SaverInfo.Bv4Header
        .bV4Size = Len(BITMAPV4HEADER)
        .bV4Width = SaverInfo.ScrWidth
        .bV4Height = -SaverInfo.ScrHeight
        .bV4Planes = 1
        .bV4BitCount = 32
        .bV4V4Compression = BI_BITFIELDS
        .bV4SizeImage = SaverInfo.ScrWidth * SaverInfo.ScrHeight * 4
        .bV4XPelsPerMeter = 1
        .bV4YPelsPerMeter = 1
        .bV4ClrUsed = 0
        .bV4ClrImportant = 0
        .bV4RedMask = &h0F00
        .bV4GreenMask = &h00F0
        .bV4BlueMask = &h000F
        .bV4AlphaMask = &hF000
    End With

    'Set up memory DC and copy screen to it
    hScreenDC = GetWindowDC(GetDesktopWindow)
    SaverInfo.hMemDC = CreateCompatibleDC(hScreenDC)
    SaverInfo.hMemBM = CreateCompatibleBitmap(hScreenDC, SaverInfo.ScrWidth, SaverInfo.ScrHeight)
    SelectObject SaverInfo.hMemDC, SaverInfo.hMemBM
    BitBlt SaverInfo.hMemDC, 0, 0, SaverInfo.ScrWidth, SaverInfo.ScrHeight, hScreenDC, 0, 0, SRCCOPY

    'Copy memory DC (and consequentially, the screen) to ScreenPtr
    ScreenLock
    GetDIBits SaverInfo.hMemDC, SaverInfo.hMemBM, 0, SaverInfo.ScrHeight, ScreenPtr, CPtr(BitmapInfo Ptr, @SaverInfo.Bv4Header), DIB_RGB_COLORS
    ScreenUnlock
End Sub

Sub WindowThread( byval uu as any ptr )
    With SaverInfo
        .hWndParent = cast(HWND,Valuint(Right(Command, Len(Command) - 3)))
        .hInstance = GetModuleHandle(NULL)
        .ClassName = "SCREENSAVERCLASS"

        'Set up window's class
        With .WindowClass
            .hCursor = NULL
            .hIcon = NULL
            .lpszMenuName = NULL
            .lpszClassName = StrPtr(SaverInfo.ClassName)
            .hbrBackground = NULL'GetStockObject(WHITE_BRUSH)
            .hInstance = SaverInfo.hInstance
            .style = CS_VREDRAW Or CS_HREDRAW Or CS_SAVEBITS Or CS_PARENTDC
            .lpfnWndProc = @ScreenSaverProc
            .cbWndExtra = 0
            .cbClsExtra = 0
        End With
    End With

    'Register the window class
    If RegisterClass(@SaverInfo.WindowClass) = 0 Then
        MessageBox 0, "ScreenSaver Failed To Initialize", "Error!", MB_ICONERROR
        End
    End If

    'Change some settings based on whether or not it's in the preview box
    If SaverInfo.IsPreview = True Then
        SaverInfo.Style = WS_CHILD
        SaverInfo.StyleEx = 0
        GetWindowRect SaverInfo.hWndParent, @SaverInfo.Bounds
    Else
        SaverInfo.Style = CuInt(WS_POPUP Or WS_VISIBLE Or WS_MAXIMIZE)
        SaverInfo.StyleEx = WS_EX_TOPMOST
        GetWindowRect GetDesktopWindow, @SaverInfo.Bounds
        SetCursor NULL
    End If

    'Create and show the window
    SaverInfo.hWnd = CreateWindowEx( _
        SaverInfo.StyleEx, _
        StrPtr(SaverInfo.ClassName),  _
        StrPtr("SCREENSAVER"), _
        SaverInfo.Style, _
        0, _
        0, _
        SaverInfo.Bounds.Right, _
        SaverInfo.Bounds.Bottom, _
        SaverInfo.hWndParent, _
        NULL, _
        SaverInfo.hInstance, _
        NULL _
    )

    ShowWindow SaverInfo.hWnd, SW_SHOW
    UpdateWindow SaverInfo.hWnd

    'The infamous message loop
    While GetMessage(@SaverInfo.Message, NULL, 0, 0) = TRUE
        TranslateMessage @SaverInfo.Message
        DispatchMessage @SaverInfo.Message
    Wend
End Sub

Function ScreenSaverProc(ByVal hWnd As HWND, ByVal Message As UINT, ByVal wParam As WPARAM, ByVal lParam As LPARAM) As LRESULT
    Dim TempMouseLocation As POINT
    Dim Bounds As RECT

    'If the screensaver is not a preview, then close it in the event of a mouse click
    If SaverInfo.IsPreview = FALSE Then
        Select Case Message
            Case WM_LBUTTONDOWN
            PostMessage hWnd, WM_CLOSE, 0, 0

            Case WM_RBUTTONDOWN
            PostMessage hWnd, WM_CLOSE, 0, 0

            Case WM_MBUTTONDOWN
            PostMessage hWnd, WM_CLOSE, 0, 0

            Case WM_KEYDOWN
            PostMessage hWnd, WM_CLOSE, 0, 0

            Case WM_SYSKEYDOWN
            PostMessage hWnd, WM_CLOSE, 0, 0

            Case WM_MOUSEMOVE
                'WM_MOUSEMOVE actually happens all the time, so we have to compare
                GetCursorPos @TempMouseLocation
                If (TempMouseLocation.x <> SaverInfo.MouseLocation.x) Or _
                   (TempMouseLocation.y <> SaverInfo.MouseLocation.y) Then
                   PostMessage hWnd, WM_CLOSE, 0, 0

                End If
        End Select
    End If

    Select Case Message
    Case WM_CREATE
            'Store the cursor
            GetCursorPos @SaverInfo.MouseLocation

            'Create a ~60hz timer
            SetTimer hWnd, 1, 17, 0

            'Get the proper bounds, according to the screensaver size
            If SaverInfo.IsPreview Then
                GetWindowRect SaverInfo.hWndParent, @SaverInfo.Bounds
            Else
                GetWindowRect GetDesktopWindow, @SaverInfo.Bounds
            End If


        Case WM_DESTROY
            PostQuitMessage 0
            SaverInfo.IsClosing = TRUE


        Case WM_PAINT
            'Copy the GFXLib screen to the actual screen
            SaverInfo.hDC = BeginPaint(hWnd, @SaverInfo.PaintStruct)
            ScreenLock
            StretchDIBits SaverInfo.hDC, 0, 0, SaverInfo.Bounds.Right - SaverInfo.Bounds.Left, SaverInfo.Bounds.Bottom - SaverInfo.Bounds.Top, 0, 0, SaverInfo.ScrWidth, SaverInfo.ScrHeight, ScreenPtr, CPtr(BitmapInfo Ptr, @SaverInfo.Bv4Header), DIB_RGB_COLORS, SRCCOPY
            ScreenUnlock
            EndPaint hWnd, @SaverInfo.PaintStruct


        Case WM_TIMER
            'Force the window to update every timer tick
            InvalidateRect hWnd, NULL, 0
            UpdateWindow hWnd


        Case Else
            'Let windows handle the messages we don't care about
            Return DefWindowProc(hWnd, Message, wParam, lParam)
    End Select
End Function

#include once "vbcompat.bi"

Sub StartConfigDialog
    var configfile = environ("APPDATA") & "\HMC\flyer.ini"

    if not fileexists(configfile) then
        mkdir environ("APPDATA") & "\HMC"
        open configfile for output as #1
        print #1, "[ToasterCommand]"
        print #1, "count = 15"
        close #1
        shell "start notepad " & configfile
    else
        shell "start notepad " & configfile
    end if

End Sub

Function AboutDialogProc(ByVal hWndDlg As HWND, ByVal Message As UINT, ByVal wParam As WPARAM, ByVal lParam As LPARAM) As BOOL
    'Display some info until the user clicks "OK" or closes the box
    Select Case Message
        Case WM_COMMAND
            Select Case LOWORD(wParam)
                Case IDOK:
                    EndDialog hWndDlg, wParam
                    Return TRUE
            End Select
    End Select
End Function