vbAccelerator - Contents of code file: SSaver.frm

VERSION 5.00
Begin VB.Form frmSSaver 
   Caption         =   "Form1"
   ClientHeight    =   5190
   ClientLeft      =   3120
   ClientTop       =   2070
   ClientWidth     =   8775
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   5190
   ScaleWidth      =   8775
   Begin VB.CommandButton Command1 
      Caption         =   "Start"
      Height          =   435
      Left            =   6360
      TabIndex        =   0
      Top             =   240
      Width           =   1275
   End
End
Attribute VB_Name = "frmSSaver"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_cTile As cTile
Private m_cStage As cBitmap
Private m_cSp() As cSprite
Private m_bAnimate As Boolean
Private WithEvents m_tmr  As CTimer
Attribute m_tmr.VB_VarHelpID = -1
Private m_bStarted As Boolean
Private m_hWNdPreview As Long


Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal
 hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long,
 ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOP = 0&
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_FRAMECHANGED = &H20        '  The frame changed: send
 WM_NCCALCSIZE
Private Const SWP_SHOWWINDOW = &H40
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const WS_BORDER = &H800000
Private Const WS_CAPTION = &HC00000                  '  WS_BORDER Or WS_DLGFRAME
Private Const WS_DLGFRAME = &H400000
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_SYSMENU = &H80000
Private Const WS_THICKFRAME = &H40000
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_CHILD = &H40000000
Private Const GWL_HWNDPARENT = (-8)
Private Const GWL_STYLE = (-16)
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal
 hWndNewParent As Long) As Long

Public Property Let PreviewhWnd(ByVal lhWnd As Long)
    m_hWNdPreview = lhWnd
End Property

Private Sub Command1_Click()
Static i As Integer
Static lNewX As Long, lNewY As Long
Static lHDC As Long
Static lCell As Long
Static iAnim() As Long
Static iSpeed() As Long
Static iXSpeed() As Long
Static bSmall() As Boolean
Static lTIme As Long

    If (Command1.Caption = "Start") Then
        Command1.Caption = "Stop"
        ReDim iAnim(1 To g_iSpriteNum) As Long
        ReDim iSpeed(1 To g_iSpriteNum) As Long
        ReDim iXSpeed(1 To g_iSpriteNum) As Long
        ReDim bSmall(1 To g_iSpriteNum) As Boolean
        For i = 1 To g_iSpriteNum
            iAnim(i) = Rnd * g_iSpriteNum + 1
            iSpeed(i) = (Rnd * 17 - 8) / 2
            If Rnd * 100 >= g_iProportion Then
                bSmall(i) = True
                m_cSp(i).SpriteData = g_cSBs
                iXSpeed(i) = Rnd * 2 + 4
            Else
                iXSpeed(i) = Rnd * 2 + 1
            End If
            With m_cSp(i)
                .X = Rnd * Me.ScaleWidth \ Screen.TwipsPerPixelX
                .Y = Rnd * Me.ScaleHeight \ Screen.TwipsPerPixelY
                .Cell = Rnd * 35
            End With
        Next i
        m_bAnimate = True
    Else
        Command1.Caption = "Start"
        m_bAnimate = False
    End If
        
    ' This is a rather poor solid loop!
    lHDC = Me.hDC
    Do While m_bAnimate
    
        lTIme = timeGetTime
        
        ' ******************************************************
        ' 1) Firstly, we restore the stage bitmap to its original
        ' state:
        For i = 1 To g_iSpriteNum
            m_cSp(i).RestoreBackground m_cStage.hDC
        Next i
        ' ******************************************************
        
        ' (At this point you could modify the background in cStage)
        
        ' ******************************************************
        ' 2) Secondly, we move all the sprites to their new position
        ' and store the stage background there:
        For i = 1 To g_iSpriteNum
            With m_cSp(i)
                ' Get the next animation cell and position:
                If (iAnim(i) < g_iSpriteNum - 1) Then
                    If (.Cell < 17) Then
                        .Y = .Y + (17 - .Cell) / (2 + Abs(bSmall(i) * 2)) +
                         iSpeed(i)
                        If (iAnim(i) > 1) And (iAnim(i) < g_iSpriteNum) Then
                            .X = .X - (17 - .Cell) / iXSpeed(i) - (2 -
                             bSmall(i))
                        End If
                    Else
                        .Y = .Y + (.Cell - 17) / (2 + Abs(bSmall(i) * 2)) +
                         iSpeed(i)
                        If (iAnim(i) > 1) And (iAnim(i) < g_iSpriteNum) Then
                            .X = .X - (.Cell - 17) / iXSpeed(i) - (2 -
                             bSmall(i))
                        End If
                    End If
                Else
                    Select Case .Cell
                    Case Is < 12
                        .X = .X - (8 - .Cell \ 2)
                        .Y = .Y - (5 - .Cell \ 2)
                    Case 12 To 16
                        .X = .X - 2
                        .Y = .Y - 1
                    Case 16 To 18
                        .X = .X - 1
                    Case 18 To 20
                        .X = .X + 1
                        .Y = .Y + 1
                    Case Is > 21
                        .Y = .Y + (.Cell - 21)
                        '.X = .X + (.Cell - 21)
                    End Select
                End If
                'wrapparound:
                If (.X < -.Width) Then
                    .X = Me.ScaleWidth \ Screen.TwipsPerPixelX
                End If
                If (.Y > Me.ScaleHeight \ Screen.TwipsPerPixelY) Then
                    .Y = -.Height
                End If
                If (.Y < -.Height) Then
                    .Y = Me.ScaleHeight \ Screen.TwipsPerPixelY
                End If
                'If (iAnim(i) = 0) Then
                '    iSpeed(i) = Rnd * 17 - 8
                'End If
                
                .Cell = .Cell + 1
                If (.Cell > 35) Then
                    .Cell = 1
                    iAnim(i) = iAnim(i) + 1
                    Select Case iAnim(i)
                    Case 1
                        iSpeed(i) = Rnd * 17 - 8
                        If (bSmall(i)) Then
                            .SpriteData = g_cSBs
                        Else
                            .SpriteData = g_cSB
                        End If
                    Case g_iSpriteNum - 1
                        If (bSmall(i)) Then
                            .SpriteData = g_cSBsA
                        Else
                            .SpriteData = g_cSBA
                        End If
                    Case g_iSpriteNum
                        iAnim(i) = 0
                        iSpeed(i) = 17 / Abs(bSmall(i) - 1)
                    End Select
                End If
                ' Store the background:
                .StoreBackground m_cStage.hDC, .X, .Y
            End With
        Next i
        ' ******************************************************
        
        ' ******************************************************
        ' 3) Thirdly, draw all the sprites to their new position
        ' in the stage:
        For i = 1 To g_iSpriteNum
            With m_cSp(i)
                ' Draw the sprite onto the stage in the new position:
                .TransparentDraw m_cStage.hDC, .X, .Y, .Cell, False
            End With
        Next i
        ' ******************************************************
        
        ' ******************************************************
        ' 4) Finally we transfer the changes in the stage onto
        ' the screen, minimising the number of visible screen
        ' blits as best as we can:
        For i = 1 To g_iSpriteNum
            m_cSp(i).StageToScreen lHDC, m_cStage.hDC
        Next i
        ' ******************************************************

        Do
            DoEvents
        Loop While lTIme + 25 > timeGetTime
        m_bStarted = True
    Loop
    
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    #If Release Then
        pExitSaver
    #End If
End Sub

Private Sub Form_Load()
Dim i As Integer
Dim lW As Long, lH As Long

    Randomize Timer

    ' Create a tiling Object in order to create the background:
    Set m_cTile = New cTile
    With m_cTile
        .Initialise Me
        Dim oPic As New StdPicture
        Set oPic = LoadPicture(g_sBackdrop)
        .Picture = oPic
        
    End With
        
    ' Create g_iSpriteNum sprites, each using the same graphic source:
    If (g_eRunMode = ePreview) Then
        g_iSpriteNum = 2
    End If
    ReDim m_cSp(1 To g_iSpriteNum) As cSprite
    For i = 1 To g_iSpriteNum
        Set m_cSp(i) = New cSprite
        m_cSp(i).SpriteData = g_cSB
        m_cSp(i).Create Me.hDC
    Next i
        
    ' Create a bitmap on which to create the screen display
    ' offscreen.  This will be blitted from onto the screen
    ' to minimise flicker
    Set m_cStage = New cBitmap
    lW = Screen.Width \ Screen.TwipsPerPixelX
    lH = Screen.Height \ Screen.TwipsPerPixelY
    m_cStage.CreateAtSize lW, lH
    
    ' We tile the background bitmap into the stage bitmap
    ' to get some sort of background for the process:
    m_cTile.TileDC m_cStage.hDC, lW, lH
    
    #If Release Then
        pMakeScreenSaver
    #End If
    
    Me.Show
    
    #If Release Then
        Set m_tmr = New CTimer
        m_tmr.Interval = 100
    #End If
    
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y
 As Single)
    #If Release Then
        pExitSaver
    #End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y
 As Single)
Static LastX As Single
Static LastY As Single
    #If Release Then
        If (LastX = 0) And (LastY = 0) Or (Abs(X - LastX) <
         Screen.TwipsPerPixelX And Abs(Y - LastY) < Screen.TwipsPerPixelY) Then
            ' do nothing (mouse move is probably a drift)
            LastX = X
            LastY = Y
        Else
            pExitSaver
        End If
    #End If
End Sub

Private Sub Form_Paint()
Dim lW As Long, lH As Long

    ' Just redraw the current stage on the screen:
    lW = Me.ScaleWidth \ Screen.TwipsPerPixelX
    lH = Me.ScaleHeight \ Screen.TwipsPerPixelY
    'BitBlt Me.hDC, 0, 0, lW, lH, m_cStage.hDC, 0, 0, SRCCOPY
    m_cStage.RenderBitmap Me.hDC, 0, 0

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim i As Integer
    ' These clear up procedures are likely to be optional.
    ' I just like being sure that's all:
    
    If (Command1.Caption = "Stop") Then
        ' Make sure the animation stops first otherwise it will
        ' try to recreate all the Objects again once the form
        ' has unloaded - not too good...
        Command1_Click
    End If
    
    ' Clear all the sprite Objects:
    For i = 1 To g_iSpriteNum
        Set m_cSp(i) = Nothing
    Next i
    ' Clear the sprite bitmap source:
    Set g_cSB = Nothing
    Set g_cSBA = Nothing
    Set g_cSBs = Nothing
    Set g_cSBsA = Nothing
    ' Clear the staging bitmap used for flicker free draw:
    Set m_cStage = Nothing
    ' Clear the tiling Object used to draw the surface of the
    ' staging bitmap:
    Set m_cTile = Nothing
    
End Sub
Private Sub pExitSaver()
    #If Release Then
        If (g_eRunMode = eScreenSave) Then
            If (m_bStarted) Then
                ' Clear topmost flag:
                SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0&, 0&, 0, 0, SWP_NOSIZE
                ' Cursor back again:
                ShowCursor 1
                ' Clear up:
                Unload Me
            End If
        End If
    #End If
    
End Sub
Private Sub pMakeScreenSaver()
Dim lStyle As Long
Dim tR As RECT

    ' Hide button
    Command1.Visible = False

    If (g_eRunMode = eScreenSave) Then
        ' Remove the border, caption, minmax button & control box:
        lStyle = GetWindowLong(Me.hwnd, GWL_STYLE)
        lStyle = lStyle And Not ( _
            WS_BORDER Or WS_CAPTION Or WS_DLGFRAME Or WS_EX_DLGMODALFRAME Or _
            WS_MAXIMIZEBOX Or WS_MINIMIZEBOX Or WS_SYSMENU Or _
            WS_SIZEBOX Or WS_THICKFRAME _
            )
        SetWindowLong Me.hwnd, GWL_STYLE, lStyle
        Me.WindowState = vbMaximized
        
        ' Make me always on top and resize for new frame:
        SetWindowPos Me.hwnd, HWND_TOPMOST, 0&, 0&, 0, 0, SWP_NOSIZE Or
         SWP_FRAMECHANGED
    
        ' Hide the mouse:
        ShowCursor 0
    Else
        GetClientRect m_hWNdPreview, tR      ' Get Display Rectangle dimentions
    
        lStyle = GetWindowLong(frmSSaver.hwnd, GWL_STYLE) ' ** Get current
         window style
        lStyle = lStyle Or WS_CHILD                        ' ** Append
         "WS_CHILD" style to the hWnd window style
        lStyle = lStyle And Not ( _
            WS_BORDER Or WS_CAPTION Or WS_DLGFRAME Or WS_EX_DLGMODALFRAME Or _
            WS_MAXIMIZEBOX Or WS_MINIMIZEBOX Or WS_SYSMENU Or _
            WS_SIZEBOX Or WS_THICKFRAME _
            )
        SetWindowLong frmSSaver.hwnd, GWL_STYLE, lStyle   ' ** Add new style to
         window
        
        SetParent frmSSaver.hwnd, m_hWNdPreview   ' ** Set preview window as
         parent window
        SetWindowLong frmSSaver.hwnd, GWL_HWNDPARENT, m_hWNdPreview ' ** Save
         the hWnd Parent in hWnd's window struct.
        
        ' ** Show screensaver in the preview window...
        SetWindowPos frmSSaver.hwnd, _
                     HWND_TOP, 0&, 0&, tR.Right, tR.Bottom, _
                     SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_SHOWWINDOW Or
                      SWP_FRAMECHANGED
    End If
    
End Sub

Private Sub m_tmr_ThatTime()
    m_tmr.Interval = 0
    Set m_tmr = Nothing
    Command1_Click
End Sub