Check out and contribute to CodePedia, the wiki for developers.

View \MANYTHNG.FRM

ManyThings 3.1 Screensaver in VB

Submitted By: Unknown
Rating: starhalf star (Rate It)


VERSION 2.00
Begin Form ManyThings
   BackColor       =   &H00000000&
   BorderStyle     =   0  'None
   ClientHeight    =   4605
   ClientLeft      =   1845
   ClientTop       =   1710
   ClientWidth     =   7995
   ControlBox      =   0   'False
   Height          =   5010
   Icon            =   MANYTHNG.FRX:0000
   Left            =   1785
   LinkTopic       =   "Form1"
   ScaleHeight     =   307
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   533
   Top             =   1365
   Width           =   8115
   Begin Timer Tick
      Enabled         =   0   'False
      Interval        =   50
      Left            =   10
      Top             =   10
   End
   Begin Label PasswordLabel
      Alignment       =   1  'Right Justify
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   1  'Fixed Single
      Caption         =   "Need Password    "
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "Times New Roman"
      FontSize        =   24.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   690
      Left            =   2430
      TabIndex        =   0
      Top             =   3510
      Visible         =   0   'False
      Width           =   4470
   End
End
' BackGround -- this form expands to fill the whole
'   screen and is used as the back drop for all the
'   drawing

Option Explicit

' variables declared here
Dim MouseX, MouseY ' Last position of the mouse moves
Dim LastX As Integer, LastY As Integer
'Dim conv2x As Single, conv2y As Single
Dim LastTime As Long
Dim CurrentTime As Long
Dim LinkTime As Long
Dim PlotType As Integer
Dim PlotInit As Integer
Dim PlotEnd As Integer
Dim RepeatIndex As Integer
Dim Pointer As Integer
Dim Mirror As Integer
Dim RunMode As Integer
Dim x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer
Dim vx1 As Single, vy1 As Single, vx2 As Single, vy2 As Single
Dim ax1 As Single, ax2 As Single, ay1 As Single, ay2 As Single
Dim l As Long
Dim m As Long
Dim MaxSpeedX As Integer, MaxSpeedY As Integer
Dim TimeInterval As Long
Dim MaxTime As Long
Dim Repeats As Integer
Dim i As Integer
Dim BoxHeight As Integer, BoxWidth As Integer
Dim DC As Integer
Dim Pattern As Long, Locked As Integer
Dim Direction As Integer
Dim Number As Integer
Dim PicWidth As Integer, PicHeight As Integer
Dim PriorityBreakPoints() As Single
Dim Priorities() As Integer
Dim TotalPriority As Single
Dim MaxPlotType As Integer

' values for GetBrightNonGray:
' minimum magnitude squared of colors
Const MinColor = 3000' was 10000
' minimum difference between colors
Const MinDiff = 30

'Allocate Memory
Dim x1a() As Integer
Dim x2a() As Integer
Dim y1a() As Integer
Dim y2a() As Integer
Dim x1da() As Integer
Dim x2da() As Integer
Dim y1da() As Integer
Dim y2da() As Integer
Dim x1sa() As Single
Dim x2sa() As Single
Dim y1sa() As Single
Dim y2sa() As Single
Dim vx1sa() As Single
Dim vx2sa() As Single
Dim vy1sa() As Single
Dim vy2sa() As Single
Dim ax1sa() As Single
Dim ax2sa() As Single
Dim ay1sa() As Single
Dim ay2sa() As Single
Dim Colors() As Long
Dim DataPts() As Integer

'for filled polygons
Dim Points() As POINTAPI

Const PI = 3.14159265358979
Const Sin45 = .707106781186547
Const Cos45 = Sin45
Const Sin22_5 = .38268343236509
Const Cos22_5 = .923879532511287
Const Sin11_25 = .195090322016128
Const Cos11_25 = .98078528040323
Const HighMirror = 10

Function CheckIfValidSaver (NeedsMuchMemory As Integer) As Integer
  'when in low memory mode the saver only runs the modules
  'that draw on the screen, not those that manipulate
  'bitmaps, savers that use more memory will pass
  'NeedsMuchMemory as a non-zero value

  If LowMemoryFlag = 0 Then 'if not low memory mode then done
    CheckIfValidSaver = 1
  Else
    If NeedsMuchMemory <> 0 Then
      LogFile ("Saver not valid in low memory: " + Str$(PlotType)), 0
      NextSelection
      CheckIfValidSaver = 0
    Else
      CheckIfValidSaver = 1
    End If

  End If

  If Priorities(PlotType) = 0 Then
    LogFile ("Saver disabled: " + Str$(PlotType)), 0
    NextSelection
    CheckIfValidSaver = 0
  End If

End Function

Sub Circles ()
 
  ' have a single elipse trace across the
  ' screen with multiple previous copies following
  ' it

  Dim xRadius As Integer, yRadius As Integer
  Dim HighMirror As Integer

  ' if first time then initialize
  If PlotInit = False Then

   'see if we need to reset changes made from previous init
   If PlotEnd = False Then

    'check if saver is permitted to run
    If CheckIfValidSaver(0) = 0 Then
      Exit Sub
    End If
   
    PlotInit = True
    Cls
    ForeColor = QBColor(15)

    'Set array size and clear the elements
    ReDim x1a(MaxLines) As Integer
    ReDim x2a(MaxLines) As Integer
    ReDim y1a(MaxLines) As Integer
    ReDim y2a(MaxLines) As Integer

    Pointer = 1     ' start with array element 1
   
    ' set index to count number of times to repeat color
    '   to past maxvalue so that it will be recalculated
    RepeatIndex = MaxLines + 1

    'determine initial position of line
    x1 = Rnd * ScaleWidth
    x2 = Rnd * ScaleWidth
    y1 = Rnd * ScaleHeight
    y2 = Rnd * ScaleHeight

    'set initial velocity
    vx1 = 0
    vx2 = 0
    vy1 = 0
    vy2 = 0

    'set initial acceleration
    ax1 = 0
    ax2 = 0
    ay1 = 0
    ay2 = 0
   
    'find background color
    m = QBColor(0)

    'Calculate velocity limits
    MaxSpeedX = ScaleWidth * 15! / 800
    MaxSpeedY = ScaleWidth * 15! / 600

    'select mirroring method
    HighMirror = 5
    Mirror = Rnd * HighMirror + 1: If Mirror > HighMirror Then Mirror = 1

  Else 'reset changes done by previous init

    ClearScreen

    'zero array sizes
    ReDim x1a(0) As Integer
    ReDim x2a(0) As Integer
    ReDim y1a(0) As Integer
    ReDim y2a(0) As Integer

  End If

  Else  ' put run code here

    Tick.Enabled = False' disable timer until circles completed

    ' check if time to get a new color
    If RepeatIndex > RepeatCount Then
   
        'set color
        l = GetBrightNonGray()

        RepeatIndex = 1
    Else
        RepeatIndex = RepeatIndex + 1
    End If

        'Delete original circle
        xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
        yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
        If xRadius <> 0 Then
            Circle ((x1a(Pointer) + x2a(Pointer)) / 2, (y1a(Pointer) + y2a(Pointer)) / 2), xRadius, m, , , yRadius / xRadius
        End If

        DoEvents

        Select Case Mirror
        Case 1: 'mirror on x and y axis
            
            'Delete original circle mirrored on Y axis
            xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
            yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
            If xRadius <> 0 Then
                Circle ((ScaleWidth - x1a(Pointer) + ScaleWidth - x2a(Pointer)) / 2, (y1a(Pointer) + y2a(Pointer)) / 2), xRadius, m, , , yRadius / xRadius
            End If

            DoEvents

            'Delete original circle mirrored on X axis
            xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
            yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
            If xRadius <> 0 Then
                Circle ((x1a(Pointer) + x2a(Pointer)) / 2, (ScaleHeight - y1a(Pointer) + ScaleHeight - y2a(Pointer)) / 2), xRadius, m, , , yRadius / xRadius
            End If

            DoEvents

            'Delete original circle mirrored on origin
            xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
            yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
            If xRadius <> 0 Then
                Circle ((ScaleWidth - x1a(Pointer) + ScaleWidth - x2a(Pointer)) / 2, (ScaleHeight - y1a(Pointer) + ScaleHeight - y2a(Pointer)) / 2), xRadius, m, , , yRadius / xRadius
            End If

            DoEvents

        Case 2: 'mirror on Y axis
            
            'Delete original circle mirrored on Y axis
            xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
            yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
            If xRadius <> 0 Then
                Circle ((ScaleWidth - x1a(Pointer) + ScaleWidth - x2a(Pointer)) / 2, (y1a(Pointer) + y2a(Pointer)) / 2), xRadius, m, , , yRadius / xRadius
            End If

            DoEvents

        Case 3: 'mirror around center point
       
            'Delete original circle mirrored on origin
            xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
            yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
            If xRadius <> 0 Then
                Circle ((ScaleWidth - x1a(Pointer) + ScaleWidth - x2a(Pointer)) / 2, (ScaleHeight - y1a(Pointer) + ScaleHeight - y2a(Pointer)) / 2), xRadius, m, , , yRadius / xRadius
            End If

            DoEvents

        Case Else: ' otherwise ignore (i.e. no mirror)
       
        End Select

        'Save New Circle
        x1a(Pointer) = x1
        x2a(Pointer) = x2
        y1a(Pointer) = y1
        y2a(Pointer) = y2

        Select Case Mirror
        Case 1: 'mirror on x and y axis
            
            'Delete original circle mirrored on Y axis
            xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
            yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
            If xRadius <> 0 Then
                Circle ((ScaleWidth - x1a(Pointer) + ScaleWidth - x2a(Pointer)) / 2, (y1a(Pointer) + y2a(Pointer)) / 2), xRadius, l, , , yRadius / xRadius
            End If

            DoEvents

            'Delete original circle mirrored on X axis
            xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
            yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
            If xRadius <> 0 Then
                Circle ((x1a(Pointer) + x2a(Pointer)) / 2, (ScaleHeight - y1a(Pointer) + ScaleHeight - y2a(Pointer)) / 2), xRadius, l, , , yRadius / xRadius
            End If

            DoEvents

            'Delete original circle mirrored on origin
            xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
            yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
            If xRadius <> 0 Then
                Circle ((ScaleWidth - x1a(Pointer) + ScaleWidth - x2a(Pointer)) / 2, (ScaleHeight - y1a(Pointer) + ScaleHeight - y2a(Pointer)) / 2), xRadius, l, , , yRadius / xRadius
            End If

        Case 2: 'mirror on Y axis
            
            'Delete original circle mirrored on y axis
            xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
            yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
            If xRadius <> 0 Then
                Circle ((ScaleWidth - x1a(Pointer) + ScaleWidth - x2a(Pointer)) / 2, (y1a(Pointer) + y2a(Pointer)) / 2), xRadius, l, , , yRadius / xRadius
            End If

        Case 3: 'mirror around center point
       
            'Delete original circle mirrored on origin
            xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
            yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
            If xRadius <> 0 Then
                Circle ((ScaleWidth - x1a(Pointer) + ScaleWidth - x2a(Pointer)) / 2, (ScaleHeight - y1a(Pointer) + ScaleHeight - y2a(Pointer)) / 2), xRadius, l, , , yRadius / xRadius
            End If

        Case Else: ' otherwise ignore (i.e. no mirror)
       
        End Select

        DoEvents

        Tick.Enabled = True' re-enable timer

        'Draw new Circle
        xRadius = Abs(x1a(Pointer) - x2a(Pointer)) / 2
        yRadius = Abs(y1a(Pointer) - y2a(Pointer)) / 2
        If xRadius <> 0 Then
            Circle ((x1a(Pointer) + x2a(Pointer)) / 2, (y1a(Pointer) + y2a(Pointer)) / 2), xRadius, l, , , yRadius / xRadius
        End If

        'Move pointer to next item
        Pointer = Pointer + 1
        If Pointer > MaxLines Then
            Pointer = 1
        End If

        'determine new acceleration
        ax1 = Rnd - .5
        ax2 = Rnd - .5
        ay1 = Rnd - .5
        ay2 = Rnd - .5

        'calculate new position
        x1 = x1 + vx1
        x2 = x2 + vx2
        y1 = y1 + vy1
        y2 = y2 + vy2

        'calculate new velocity
        vx1 = (vx1 + ax1): If Abs(vx1) > MaxSpeedX Then vx1 = 0: ax1 = 0
        vx2 = (vx2 + ax2): If Abs(vx2) > MaxSpeedX Then vx2 = 0: ax2 = 0
        vy1 = (vy1 + ay1): If Abs(vy1) > MaxSpeedY Then vy1 = 0: ay1 = 0
        vy2 = (vy2 + ay2): If Abs(vy2) > MaxSpeedY Then vy2 = 0: ay2 = 0

        'check if off screen
        If (x1 > ScaleWidth) Then
            'change direction
            vx1 = -Abs(vx1)
        ElseIf (x1 < 0) Then
            'change direction
            vx1 = Abs(vx1)
        End If

        If (y1 > ScaleHeight) Then
            'change direction
            vy1 = -Abs(vy1)
        ElseIf (y1 < 0) Then
            'change direction
            vy1 = Abs(vy1)
        End If

        If (x2 > ScaleWidth) Then
            'change direction
            vx2 = -Abs(vx2)
        ElseIf (x2 < 0) Then
            'change direction
            vx2 = Abs(vx2)
        End If

        If (y2 > ScaleHeight) Then
            'change direction
            vy2 = -Abs(vy2)
        ElseIf (y2 < 0) Then
            'change direction
            vy2 = Abs(vy2)
        End If


  End If

End Sub

Sub ClearScreen ()
'goes to extreme efforts to clear the screen

  DC = CreateDC("DISPLAY", 0&, 0&, 0&)
  'clear display
  BitBlt DC, 0, 0, ScrnWidth, ScrnHeight, DC, 0, 0, &H42&
  i = DeleteDC(DC)

  picture = LoadPicture() ' clear picture
  BackColor = QBColor(0)
  Cls

End Sub

Sub Confetti ()

  'put points on screen
  'Dim i As Integer, j As Integer, k As Integer
  Dim x As Integer, y As Integer
  Dim Size As Integer
  Dim UniformBoxes As Integer

  ' if first time then initialize
  If PlotInit = False Then
   
    'see if we need to reset changes made from previous init
    If PlotEnd = False Then
   
      'check if saver is permitted to run
      If CheckIfValidSaver(0) = 0 Then
        Exit Sub
      End If

     If LowMemoryFlag = 0 Then 'if not low memory mode then done
       picture = original.Image ' start with original screen
     Else
       Cls
     End If

      PlotInit = True
      Size = Rnd * 5 + 1

    Else 'reset changes done by previous init

      Tick.Enabled = True
      picture = LoadPicture()

    End If

  Else

    Tick.Enabled = False
 
    Size = Rnd * 5 + 1  ' size to make dots

    If Rnd > .5 Then
       UniformBoxes = True
    Else
       UniformBoxes = False
    End If

    Do
      x = Int(Rnd * ScrnWidth)
      y = Int(Rnd * ScrnHeight)
      Line (x, y)-(x + Size, y + Size), GetNearestColor(hDC, RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))), BF

      If UniformBoxes = False Then
        Size = Rnd ^ 10 * 40 + 2'new size
      End If

      DoEvents
      CurrentTime = Timer
      If (CurrentTime > MaxTime) Or (LastTime > CurrentTime) Then Exit Do
    Loop

    Tick.Enabled = True
    picture = LoadPicture()

  End If

End Sub

Sub CyclePalette ()

  Dim Header As Long, DataBits As Long, i As Integer, j As Integer
  Dim l As Long
  Dim Paint As PAINTSTRUCT
  Static Xoffset As Integer, Yoffset As Integer, red As Integer, green As Integer, blue As Integer
  Static Wdth As Integer, Hght As Integer
  Static FastPalRunFlag As Integer, PassFlag As Integer
  Dim FileName As String, File As String
  Static PaletteFlag As Integer

  ' if first time then initialize
  If PlotInit = False Then
   
    'see if we need to reset changes made from previous init
    If PlotEnd = False Then
   
    'check if saver is permitted to run
    If CheckIfValidSaver(1) = 0 Then
      Exit Sub
    End If

     'we only allow to run once since it has problems:
     'if started more than once durring before program stops
     'then resources can disappear drastically, there must
     'be something about the animatepalette function or
     'sendmessage that requires resources to be cleared?
     If FastPalRunFlag Then
       LogFile "Already ran Fast pallete cycle " + File, 1
       NextSelection 'jump to next since there are no bitmap files in directory
       Exit Sub
     End If

      '*****************************************************
      'initialization code here:
      File = GetNextFile(CycleBitmapsDir, 1, "dib", "gif", "")

      If File = "" Then 'check if could not load
        NextSelection 'jump to next since there are no bitmap files in directory
        Exit Sub
      End If

      ' find file
      'FileSpec = RTrim$(BitmapsDir) + "\*.dib"
      j = Rnd * 50 ' pick file at random
      For i = 1 To j

        File = GetNextFile(CycleBitmapsDir, 0, "dib", "gif", "")' get next file

      Next i

      'i = LoadSlide(File, 1)
      'If i = 0 Then 'check if could not load
      '  LogFile "Could not load file " + File, 1
      '  NextSelection 'jump to next since there are no bitmap files in directory
      '  Exit Sub
      'End If

      If InStr(UCase$(File), ".GIF") = 0 Then
        l = ManyDibLoad(File, Wdth, Hght)'load dib
     
        If l <= 0 Then 'check if could not load
          LogFile "Could not read DIB file " + File, 1
          NextSelection 'jump to next since there are no bitmap files in directory
          Exit Sub
        End If
     
      Else
        l = ManyGifLoad(File, Wdth, Hght)'load gif
     
        If l <= 0 Then 'check if could not load
          LogFile "Could not read GIF file " + File, 1
          NextSelection 'jump to next since there are no bitmap files in directory
          Exit Sub
        End If

      End If

      If (TotalNumColors <= 256) And (FastPaletteCycleFlag <> 0) Then

        FastPalRunFlag = 1

        'free up all but 2 system palettes
        i = SetSystemPaletteUse(hDC, SYSPAL_NOSTATIC)

        'show the palettes
        SetWindow2DIBPalette PC_RESERVED
        LogFile "Using Fast Palette Cycling", 0
        PaletteFlag = 1

      Else 'don't mess with palettes

        'picture = LoadPicture() ' clear screen
        LogFile "Changing Palette using screen redraws", 0
        PaletteFlag = 0

      End If

      PassFlag = 2
     
      PlotInit = True
      'Cls

      'position image
      Xoffset = (ScrnWidth - Wdth) / 2
      Yoffset = (ScrnHeight - Hght) / 2

      'set tick rate
      Tick.Interval = 25

    Else 'reset changes done by previous init

      If PaletteFlag <> 0 Then

        'remove priority on palette entries
        SetWindow2DIBPalette 0

        i = SetSystemPaletteUse(hDC, SYSPAL_STATIC)'restore system palette

      End If

      'try to read last temp file for background
      i = LoadSlideAndTile(RTrim$(BitmapsDir) + "\tmprary.dib")

      'save current screen as new original
      DC = CreateDC("DISPLAY", 0&, 0&, 0&)
      BitBlt original.hDC, 0, 0, ScrnWidth, ScrnHeight, DC, 0, 0, &HCC0020
      i = DeleteDC(DC)

      ClearScreen

      i = ManyDibFree() 'free memory used for dib
      If i <> 0 Then
        LogFile "Could not free memory", 1
      End If

      'set tick rate
      Tick.Interval = 50

    End If

   
  Else  ' put run code here

    If PassFlag > 1 Then

      Header = ManyDibGet() 'get pointer to header
      DataBits = ManyDibGetData() 'get pointer to data

      If Header <> 0 Then

        i = SetStretchBltMode(hDC, 3)
        i = StretchDIBits(hDC, 0, 0, ScrnWidth, ScrnHeight, 0, 0, Wdth, Hght, DataBits, Header, 0, &HCC0020)'source copy
      Else
        LogFile "Header missing", 1
        NextSelection
        Exit Sub
      End If

      PassFlag = PassFlag - 1
    Else
     
      Header = ManyDibGet() 'get pointer to header
      DataBits = ManyDibGetData() 'get pointer to data

      If Header <> 0 Then

        If PaletteFlag <> 0 Then

          DoAnimatePalette Pal, 1, 1'shift pallete by one

        Else 'if not palette based, animate screen by
             'changing colors and redrawing
            
          'draw screen
          i = SetStretchBltMode(hDC, 3)
          ManyDibCyclePalette -1, 1, 255'cycle colors
          'i = StretchDIBits(hDC, 0, 0, ScrnWidth, ScrnHeight, 0, 0, 640, 480, DataBits, Header, 0, &HCC0020)'source copy
          i = SetDIBitsToDevice(hDC, Xoffset, Yoffset, Wdth, Hght, 0, 0, 0, Hght, DataBits, Header, 0)

        End If
       
      Else
        LogFile "Header missing", 1
        NextSelection
        Exit Sub
      End If

    End If
   
  End If

  Exit Sub

End Sub

Sub DoAnimatePalette (palette As LOGPALETTE, Start As Integer, StepSize As Integer)
' cycle palete entry and display

    Dim entrynum%, i As Integer
    Dim usepal As Integer
    Dim holdentry As PALETTEENTRY
    Dim temp As Long

    For i = 1 To StepSize'shift n times

      ' The following code simply loops the color values
      LSet holdentry = palette.palPalEntry(Start)
      For entrynum% = Start To PALENTRIES - 2
        LSet palette.palPalEntry(entrynum%) = palette.palPalEntry(entrynum% + 1)
      Next entrynum%
      LSet palette.palPalEntry(PALENTRIES - 1) = holdentry

    Next i

    ' Get a handle to the control's palette
    On Error GoTo DoAnimatePaletteError
    usepal = SendMessageByNum(hWnd, VBM_GETPALETTE, 0, 0)
    On Error GoTo 0
   
    AnimatePalette usepal, 0, PALENTRIES, palette.palPalEntry(0)

    Exit Sub

DoAnimatePaletteError:
  'overflow on getting palette handle
  On Error GoTo 0
  LogFile "Overflow on getting palette handle", 1
  Exit Sub
End Sub

Sub Dribble ()

  'dribbling paint on screen

  Dim i As Integer, j As Integer, k As Integer
  Static MaxHole As Integer

  ' if first time then initialize
  If PlotInit = False Then
   
    'see if we need to reset changes made from previous init
    If PlotEnd = False Then
   
    'check if saver is permitted to run
    If CheckIfValidSaver(1) = 0 Then
      Exit Sub
    End If
   
    ' start with original screen
    picture = original.Image
   
    PlotInit = True

    'determine initial position of shot
    x1 = Rnd * ScaleWidth
    y1 = Rnd * ScaleHeight
   
    'Calculate velocity limits
    MaxSpeedX = ScaleWidth * 20! / 800
    MaxSpeedY = ScaleWidth * 20! / 600

    ' zero initial velocity
    vx1 = 0: vy1 = 0

    'set maximum size of holes
    MaxHole = 4

    ForeColor = RGB(0, 0, 0)' use black box
    FillColor = RGB(0, 0, 0) 'set black fill
    FillStyle = 0 'solid fill

    RunMode = Int(Rnd * 2#)'choose black or color

    'Debug.Print RunMode

    If RunMode > 0 Then ' if random color then use larger spots
        MaxHole = 8
        i = Rnd * 255: If i > 255 Then i = 255
        j = Rnd * 255: If j > 255 Then j = 255
        k = Rnd * 255: If k > 255 Then k = 255
        ForeColor = GetNearestColor(hDC, RGB(i, j, k))
        FillColor = ForeColor
    End If

  Else 'reset changes done by previous init

    ClearScreen
    FillStyle = 1 'transparent fill

  End If

  Else  ' put run code here

        If RunMode > 0 Then ' see if need to change to random color

            If Rnd < .05 Then
                i = Rnd * 255: If i > 255 Then i = 255
                j = Rnd * 255: If j > 255 Then j = 255
                k = Rnd * 255: If k > 255 Then k = 255
                ForeColor = GetNearestColor(hDC, RGB(i, j, k))
                FillColor = ForeColor
            End If

        End If
       
        ' put random hole here
        Circle (x1 + Rnd * 20, y1 + Rnd * 20), MaxHole * Rnd + 2, , , , 1

        'determine new acceleration
        ax1 = 2 * Rnd - 1
        ay1 = 2 * Rnd - 1
            
        'calculate new position
        x1 = x1 + vx1
        y1 = y1 + vy1
            
        'calculate new velocity
        vx1 = (vx1 + ax1): If Abs(vx1) > MaxSpeedX Then vx1 = -vx1 * .9: vy1 = -vy1 * .9: ax1 = 0
        vy1 = (vy1 + ay1): If Abs(vy1) > MaxSpeedY Then vx1 = -vx1 * .9: vy1 = -vy1 * .9: ay1 = 0
            
        'check if off screen
        If (x1 > ScaleWidth) Then
            'change direction
            vx1 = -