Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/rosettes/rosettes.bas

BASIC Source File | 1995-05-08 | 5.2 KB | 189 lines

Declare Sub SetCursorPos Lib "USER" (ByVal X As Integer, ByVal Y As Integer)
Global Const KEYDOWNEXIT = -1
Global WAITING%
Global FIRSTTIME%
Global LASTX!, LASTY!

Sub DRAWROSETTES ()

' My only contribution to this program.

ReDim VX%(100), VY%(100), NUM%(99) ' Arrays for vertex co-ords and # of sides

' set internal scale

Form1.ScaleHeight = (screen.Height \ screen.TwipsPerPixelY)
Form1.ScaleWidth = (screen.Width \ screen.TwipsPerPixelX) ' use for circular shapes
'Form1.ScaleWidth = Form1.ScaleHeight   ' use to fill screen

SW% = Form1.ScaleWidth \ 2         ' locate center of form
SH% = Form1.ScaleHeight \ 2

PI# = 4 * Atn(1)
A% = 0            ' drawing starts or ends at center
B% = SH% - 5      ' drawing stops before going off screen
W% = 52           ' this gave some shapes my wife could live with.
Z% = 1            ' used to change drawing direction

For P% = 0 To 99                   ' load # of sides array
   DRAWNUM% = P%
   Select Case DRAWNUM%            ' some numbers give dreadful results
      Case 0, 8, 16, 28, 65        ' according to my wife
         DRAWNUM% = 42
      Case 1, 9, 20, 29, 78
         DRAWNUM% = 45
      Case 2, 10, 22, 30, 79
         DRAWNUM% = 46
      Case 3, 11, 23, 32, 91
         DRAWNUM% = 47
      Case 4, 12, 24, 33, 93
         DRAWNUM% = 49
      Case 5, 13, 25, 34, 95
         DRAWNUM% = 50
      Case 6, 14, 26, 39
         DRAWNUM% = 51
      Case 7, 15, 27, 52
         DRAWNUM% = 54
   End Select
   NUM%(P%) = DRAWNUM%
Next P%

Randomize

Do
   Todraw% = NUM%(Int(Rnd * 100))   ' how many sides

   If Todraw% Mod 22 = 0 Then        ' every so often make backcolor black
      RRR% = 0
      GGG% = 0
      BBB% = 0
   Else                             ' else select random backcolor
      RRR% = Int(Rnd * 256)
      GGG% = Int(Rnd * 256)
      BBB% = Int(Rnd * 256)
   End If

   Form1.BackColor = RGB(RRR%, GGG%, BBB%)

   D% = Z% * (Int(Rnd * 6) + 5)         ' determine step size

   For LOOPINGNUM% = A% To B% Step D%   ' start drawing process

      ' Determine vertex co-ords of a regular polygon of ToDraw% sides

      For LOOPNUM% = 0 To Todraw%       ' load co-ord arrays
         VX%(LOOPNUM%) = SW% + LOOPINGNUM% * Cos(W% * PI# * LOOPNUM% / Todraw%)
         VY%(LOOPNUM%) = SH% + LOOPINGNUM% * Sin(W% * PI# * LOOPNUM% / Todraw%)
      Next LOOPNUM%
      VX%(Todraw% + 1) = VX%(0)         ' last vertex same as first vertex
      VY%(Todraw% + 1) = VY%(0)

      C% = C% + Int(6 * Rnd) + 1       ' select line drawing color
      If C% > 15 Then C% = C% - 15

      For LOOPNUM% = 0 To Todraw%       ' connect the dots
         If LOOPNUM% Mod 10 = 0 Then DoEvents  ' cede control to other apps
         Form1.Line (VX%(LOOPNUM%), VY%(LOOPNUM%))-(VX%(LOOPNUM% + 1), VY%(LOOPNUM% + 1)), QBColor(C%)
      Next LOOPNUM%

   Next LOOPINGNUM%

   WAIT 2     ' hold on screen for 2 seconds

   F% = A%    ' interchange drawing variables
   A% = B%
   B% = F%
   Z% = -Z%   ' and reverse drawing direction

Loop

End Sub

Sub HIDECURSOR ()

    ' Move cursor off screen to bottom right.
    ' This routine is from The Cobb Group's
    ' Inside VB for Windows magazine

    XPOS% = screen.Width
    YPOS% = screen.Height
    Call SetCursorPos(XPOS%, YPOS%)
    LASTX! = XPOS%
    LASTY! = YPOS%
End Sub

Sub MAIN ()

    If APP.PrevInstance Then  ' Only allow one copy at a time to run
        End
    End If

    WAITING% = False

    Form1.Show

    If UCase$(Command$) = "/C" Then
       Result% = MsgBox("This screensaver has no setup parameters", 4144, "ROSETTES SETUP")
       End
    End If

    HIDECURSOR
    DRAWROSETTES
End Sub

Sub MONITOREVENTS (X As Single, Y As Single)

    ' Check if screensaver should end. This routine is from The Cobb Group's
    ' Inside VB for Windows magazine

    ' According to The Cobb Group Windows generates (for VB) spurious
    ' mousemove events on an interval matching the screensaver time delay
    ' set in Control Panel. The next If structure traps them.

    If X = LASTX! And Y = LASTY! Then
        Exit Sub
    Else
        LASTX! = X
        LASTY! = Y
    End If

    If (Not FIRSTTIME%) Or LASTX! = KEYDOWNEXIT Then
        QUITSCREENSAVER
    Else
        Call WAIT(1)
        FIRSTTIME% = False
    End If
End Sub

Sub QUITSCREENSAVER ()
    End
End Sub

Sub WAIT (TIMETOWAIT%)

    ' Routine to hold drawing on screen for a set number of seconds.
    ' This routine is from The Cobb Group's
    ' Inside VB for Windows magazine

    If TIMETOWAIT% <= 0 Then Exit Sub  ' check for valid parameter
    If WAITING% Then Exit Sub  ' do not allow re-entry while routine is active
    WAITING% = True
    TIMEADJ! = 24! * 60 * 60  ' Used if time goes past midnight
    STARTTIME! = Timer

    Do
        DoEvents                ' relinquish control
        CURRENTTIME! = Timer

        If CURRENTTIME! < STARTTIME! Then
            STARTTIME! = STARTTIME! - TIMEADJ!
        End If

        ELAPSEDTIME! = CURRENTTIME! - STARTTIME!
    Loop While ELAPSEDTIME! < TIMETOWAIT%

    WAITING% = False

End Sub