Rainbow: Visual Basic Version

'*****************************************************************************
'                                                                            *
'  Rainbow.frm                                                               *
'                                                                            *
'  This program demonstrates color palette cycling.                          *
'                                                                            *
'*****************************************************************************
Dim hPal As Long
Dim hVB As Long
Dim cxClient As Long, cyClient As Long
Dim Start As Long
Dim RGBvalues(2 * 24 * 3) As Byte ' two sets of 24 RGB triplets
Private Sub Form_Activate()
   Call fg_realize(hPal)
   Refresh
End Sub
Private Sub Form_Load()
   Dim Color As Long
   Dim xLen As Long, yLen As Long
   ScaleMode = 3
   ' create the logical palettte
   Call fg_setdc(hDC)
   Call FillColorPalette
   hPal = fg_logpal(10, 24, RGBvalues(0))
   Call fg_realize(hPal)
   ' create a 640x480 virtual buffer
   Call fg_vbinit
   hVB = fg_vballoc(640, 480)
   Call fg_vbopen(hVB)
   Call fg_vbcolors
   ' construct a crude image of a rainbow
   Call fg_setcolor(255)
   Call fg_fillpage
   Call fg_setclip(0, 639, 0, 300)
   Call fg_move(320, 300)
   xLen = 240
   yLen = 120
   For Color = 10 To 33
      Call fg_setcolor(Color)
      Call fg_ellipsef(xLen, yLen)
      xLen = xLen - 4
      yLen = yLen - 3
   Next Color
   Call fg_setcolor(255)
   Call fg_ellipsef(xLen, yLen)
   Call fg_setclip(0, 639, 0, 479)
   ' starting index into the array of color values
   Start = 0
   ' start the 50ms timer
   Timer1.Interval = 50
End Sub
Private Sub Form_Paint()
   Call fg_vbscale(0, fg_getmaxx(), 0, fg_getmaxy(), 0, cxClient - 1, 0, cyClient - 1)
End Sub
Private Sub Form_Resize()
   cxClient = ScaleWidth
   cyClient = ScaleHeight
   Refresh
End Sub
Private Sub Form_Unload(Cancel As Integer)
   Call fg_vbclose
   Call fg_vbfree(hVB)
   Call fg_vbfin
End Sub
Private Sub Timer1_Timer()
   Start = (Start + 3) Mod 72
   Call fg_setdacs(10, 24, RGBvalues(Start))
   If fg_colors > 8 Then
      Call fg_vbscale(0, fg_getmaxx(), 0, fg_getmaxy(), 0, cxClient - 1, 0, cyClient - 1)
   End If
End Sub
'*****************************************************************************
'                                                                            *
'  FillColorPalette()                                                        *
'                                                                            *
'  Set up the colors for the application's logical palette in the RGBvalues  *
'  array. The logical palette will contain 24 non-system colors (indices 10  *
'  to 33) defining the initial RGB values for the colors being cycled.       *
'                                                                            *
'  Note that we store two identical sets of 24 RGB triplets in RGBvalues. We *
'  can then perform color cycling without having to worry about wrapping to  *
'  the start of the array because the index pointing to the starting RGB     *
'  triplet never extends beyond the first set of 24 RGB triplets.            *
'                                                                            *
'*****************************************************************************
Private Sub FillColorPalette()
   Dim I As Long
   RGBvalues(0) = 182: RGBvalues(1) = 182: RGBvalues(2) = 255
   RGBvalues(3) = 198: RGBvalues(4) = 182: RGBvalues(5) = 255
   RGBvalues(6) = 218: RGBvalues(7) = 182: RGBvalues(8) = 255
   RGBvalues(9) = 234: RGBvalues(10) = 182: RGBvalues(11) = 255
   RGBvalues(12) = 255: RGBvalues(13) = 182: RGBvalues(14) = 255
   RGBvalues(15) = 255: RGBvalues(16) = 182: RGBvalues(17) = 234
   RGBvalues(18) = 255: RGBvalues(19) = 182: RGBvalues(20) = 218
   RGBvalues(21) = 255: RGBvalues(22) = 182: RGBvalues(23) = 198
   RGBvalues(24) = 255: RGBvalues(25) = 182: RGBvalues(26) = 182
   RGBvalues(27) = 255: RGBvalues(28) = 198: RGBvalues(29) = 182
   RGBvalues(30) = 255: RGBvalues(31) = 218: RGBvalues(32) = 182
   RGBvalues(33) = 255: RGBvalues(34) = 234: RGBvalues(35) = 182
   RGBvalues(36) = 255: RGBvalues(37) = 255: RGBvalues(38) = 182
   RGBvalues(39) = 234: RGBvalues(40) = 255: RGBvalues(41) = 182
   RGBvalues(42) = 218: RGBvalues(43) = 255: RGBvalues(44) = 182
   RGBvalues(45) = 198: RGBvalues(46) = 255: RGBvalues(47) = 182
   RGBvalues(48) = 182: RGBvalues(49) = 255: RGBvalues(50) = 182
   RGBvalues(51) = 182: RGBvalues(52) = 255: RGBvalues(53) = 198
   RGBvalues(54) = 182: RGBvalues(55) = 255: RGBvalues(56) = 218
   RGBvalues(57) = 182: RGBvalues(58) = 255: RGBvalues(59) = 234
   RGBvalues(60) = 182: RGBvalues(61) = 255: RGBvalues(62) = 255
   RGBvalues(63) = 182: RGBvalues(64) = 234: RGBvalues(65) = 255
   RGBvalues(66) = 182: RGBvalues(67) = 218: RGBvalues(68) = 255
   RGBvalues(69) = 182: RGBvalues(70) = 198: RGBvalues(71) = 255
   ' set up two identical sets of the 24 colors in the RGBvalues array
   For I = 0 To 24 * 3 - 1
      RGBvalues(I + 24 * 3) = RGBvalues(I)
   Next I
End Sub