home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / library / qb_pds / screen / fancycls / fancycls.bas
Encoding:
BASIC Source File  |  1991-05-22  |  2.7 KB  |  84 lines
  1. ' ***************************************************************
  2. ' ***************************************************************
  3. ' **                     QBASIC / QuickBasic                   **
  4. ' **                         FANCYCLS                          **
  5. ' **                  Fancy Clear Screen Routine               **
  6. ' **                        (c) 1990 by                        **
  7. ' **                       Thomas Jaeger                       **
  8. ' **                   1848 Andalucia Drive                    **
  9. ' **                   El Paso, Texas 79935                    **
  10. ' **                            USA                            **
  11. ' ***************************************************************
  12. ' ***************************************************************
  13. '
  14. '
  15. ' This program is distributed under the shareware concept.
  16. '
  17. ' You can put this routine in your next GW-, TURBO-, POWER-, or
  18. ' QuickBASIC routine. If you use this routine, please make a
  19. ' distribution of US $1-5 to support this shareware concept.
  20. '
  21. ' Other routines will follow.
  22. '
  23. ' ----------------------------------------------------------------------
  24. '
  25. ' How about a fancy clear screen routine to impress your friends
  26. ' in your next program?
  27. ' Immediately you called FANCYCLS with GOSUB 10000, the screen starts
  28. ' to crumble by coincidence. A great effect.
  29. ' The routine will detect, if you have a monochrome, graphics card.
  30. ' (screenseg &HB800 vs. &HB000). If you don't want the
  31. ' background color to be changed, just erase line 10090.
  32. '
  33. ' ----------------------------------------------------------------------
  34. '
  35. '
  36. ' >>>>> Your program starts hier <<<<<
  37. '
  38. ' The following code only fills the screen with asteriks to give a better
  39. ' demonstration. You can leave this code out of your program.
  40. '
  41. waiting$ = INKEY$
  42. CLS
  43. WHILE waiting$ = ""
  44.    WHILE NOT EndPrint = -1
  45.       FOR counter% = 1 TO 25
  46.          PRINT STRING$(80, "*");
  47.       NEXT counter%
  48.       EndPrint = -1
  49.       LOCATE 13, 35
  50.       PRINT " PRESS ANY KEY! "
  51.    WEND
  52.    waiting$ = INKEY$
  53. WEND
  54. LOCATE 14, 35
  55. PRINT " WAIT A SECOND "
  56. CALL FANCYCLS
  57. ' You probably want to end your program then.
  58. END ' Program
  59.  
  60. SUB FANCYCLS
  61. DIM f%(2000) ' local dimension is necessary (screen array)
  62.  
  63.   FOR counter% = 0 TO 2000
  64.     f%(counter%) = counter%
  65.   NEXT counter%
  66.  
  67.   FOR counter% = 2000 TO 0 STEP -1
  68.     SWAP f%(INT(RND(1) * counter%)), f%(counter)
  69.   NEXT counter%
  70.  
  71.   DEF SEG = &H40
  72.     IF PEEK(&H49) = 7 THEN ScrSeg% = &HB000 ELSE ScrSeg% = &HB800
  73.   DEF SEG
  74.   
  75.   DEF SEG = ScrSeg%
  76.     FOR counter% = 0 TO 2000
  77.       FOR delay% = 1 TO 100: NEXT delay%
  78.         POKE f%(counter%) * 2, 32
  79.         POKE f%(counter%) * 2 + 1, 0 ' Background = black
  80.       NEXT counter%
  81.   DEF SEG
  82. END SUB
  83.  
  84.