home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MAGAZINE / MISC / QBNWS301.ZIP / QBASIC.ZIP / DEMO.BAS next >
Encoding:
BASIC Source File  |  1991-11-12  |  8.2 KB  |  299 lines
  1. '
  2. ' DEMO.BAS - demonstrates use of BIN files from
  3. '            Brent's QBASIC toolbox
  4. '
  5. ' (C)1991 Brent Ashley
  6. '
  7. DEFINT A-Z
  8. DECLARE SUB BiosPrint (Row%, Col%, Attr%, OutStr$)
  9. DECLARE SUB BlockCopy (FromSeg%, FromOfs%, ToSeg%, ToOfs%, Count%)
  10. DECLARE SUB Explode (Top%, Lft%, Bot%, Rgt%, Attr%, Shad%, Delay)
  11. DECLARE SUB ScrnSave (SaveRestore%)
  12. DECLARE SUB ScrollArea (Top%, Lft%, Bot%, Rgt%, Attr%, Lines%)
  13. DECLARE SUB SLBox (Top%, Lft%, Bot%, Rgt%, Attr%, Shad%)
  14. DECLARE SUB TickPause (Ticks%)
  15. DECLARE FUNCTION ColorAttr% (Fore%, Back%)
  16. DECLARE FUNCTION CurDir$ (DriveNum%)
  17. DECLARE FUNCTION CurDrive% ()
  18. DECLARE FUNCTION DayOfWeek% ()
  19. DECLARE FUNCTION DosVer$ ()
  20. DECLARE FUNCTION FileExist% (Filespec$)
  21. DECLARE FUNCTION LoadBin$ (BinFileName$)
  22. DECLARE FUNCTION WeekDay$ ()
  23. TYPE RegTypeX
  24.   AX    AS INTEGER
  25.   BX    AS INTEGER
  26.   CX    AS INTEGER
  27.   DX    AS INTEGER
  28.   BP    AS INTEGER
  29.   SI    AS INTEGER
  30.   DI    AS INTEGER
  31.   Flags AS INTEGER
  32.   DS    AS INTEGER
  33.   ES    AS INTEGER
  34. END TYPE
  35. DIM SHARED Regs AS RegTypeX
  36. DECLARE SUB Interrupt (IntNum%, Regs AS RegTypeX)
  37. CLS
  38. ' fill screen with letters
  39. FOR i = 1 TO 24
  40.   PRINT STRING$(80, 64 + i);
  41. NEXT
  42. TickPause 9
  43.  
  44. ' fancy scrolling
  45. FOR i = 6 TO 15
  46.   ScrollArea 6, 25, 15, 55, ColorAttr(7, i), 1
  47.   TickPause 2
  48. NEXT
  49. TickPause 8
  50. FOR i = 2 TO 23
  51.   ScrollArea 2, 2, 23, 79, ColorAttr(7, i), -1
  52.   TickPause 1
  53. NEXT
  54. TickPause 8
  55.  
  56. ' panel and box
  57. ScrollArea 5, 10, 21, 70, ColorAttr(0, 3), 0
  58. SLBox 8, 30, 18, 47, ColorAttr(3, 0), 1
  59.  
  60. ' quick color printing via BIOS
  61. FOR i = 9 TO 17
  62.   BiosPrint i, 31, ColorAttr(23 - i, i), " Interrupt Demo "
  63. NEXT
  64. COLOR 31, 1: LOCATE 23, 32: PRINT " Press a key... ";
  65. ' save screen
  66. ScrnSave 1
  67. DO: LOOP UNTIL LEN(INKEY$)
  68. CLS
  69.  
  70. ' random boxes!
  71. RANDOMIZE TIMER
  72. FOR i = 1 TO 50
  73.   Top = 1 + RND(1) * 20
  74.   Lft = 1 + RND(1) * 70
  75.   Bot = Top + (23 - Top) * RND(1) + 1
  76.   Rgt = Lft + (77 - Lft) * RND(1) + 1
  77.   Fore = RND(1) * 15
  78.   Back = RND(1) * 8
  79.   SLBox Top, Lft, Bot, Rgt, ColorAttr(Fore, Back), 1
  80. NEXT
  81. COLOR 3, 0
  82. SLBox 8, 25, 16, 55, ColorAttr(3, 0), 1
  83. BiosPrint 10, 32, ColorAttr(19, 0), "50 Speedy Boxes!"
  84. LOCATE 12, 32: PRINT " Press a key to"
  85. LOCATE 13, 32: PRINT "see first screen"
  86. LOCATE 14, 32: PRINT "    again..."
  87. DO: LOOP UNTIL LEN(INKEY$)
  88. ' restore screen
  89. ScrnSave 0
  90. DO: LOOP UNTIL LEN(INKEY$)
  91.  
  92. ' show some system info
  93. COLOR 14, 1
  94. Attr = ColorAttr(14, 1)
  95. Explode 5, 15, 17, 65, Attr, 0, 0
  96. LOCATE 8, 23: PRINT "     Today is: "; WeekDay$
  97. LOCATE 9, 23: PRINT "Current Drive: "; CHR$(CurDrive + 64)
  98. LOCATE 10, 23: PRINT "    Directory: "; CurDir$(0)
  99. LOCATE 11, 23: PRINT "  Dos Version:"; DosVer$
  100. IF FileExist("C:\CONFIG.SYS") THEN Sys$ = "Exists" ELSE Sys$ = "Not there"
  101. LOCATE 12, 23: PRINT "C:\CONFIG.SYS: "; Sys$
  102. IF FileExist("C:\QWERTY.UIO") THEN Sys$ = "Exists" ELSE Sys$ = "Not there"
  103. LOCATE 13, 23: PRINT "C:\QWERTY.UIO: "; Sys$
  104. ScrnSave 1
  105. Explode 19, 20, 23, 60, Attr, 1, 3
  106. LOCATE 21, 26: PRINT "Wow! - Pretty neat, Huh?!?"
  107. TickPause 30
  108. ScrnSave 0
  109. DO: LOOP WHILE LEN(INKEY$) ' clear keyboard buffer
  110. DO: LOOP UNTIL LEN(INKEY$)
  111. COLOR 7, 0: CLS
  112. PRINT "...end of demo."
  113.  
  114. SUB BiosPrint (Row, Col, Attr, OutStr$)
  115.   ' print string using BIOS - only available on AT and later
  116.   Regs.AX = &H1301
  117.   Regs.BX = Attr
  118.   Regs.CX = LEN(OutStr$)
  119.   Regs.DX = (Row - 1) * 256 + (Col - 1)
  120.   Regs.ES = VARSEG(OutStr$)
  121.   Regs.BP = SADD(OutStr$)
  122.   Interrupt &H10, Regs
  123. END SUB
  124.  
  125. SUB BlockCopy (FromSeg, FromOfs, ToSeg, ToOfs, Count)
  126.   STATIC MemCopy$
  127.   IF NOT LEN(MemCopy$) THEN MemCopy$ = LoadBin("MemCopy.BIN")
  128.   DEF SEG = VARSEG(MemCopy$)
  129.   CALL Absolute(FromSeg, FromOfs, ToSeg, ToOfs, Count, SADD(MemCopy$))
  130. END SUB
  131.  
  132. FUNCTION ColorAttr (Fore, Back)
  133.   ColorAttr = (Fore AND 16) * 8 + (Back AND 7) * 16 + (Fore AND 15)
  134. END FUNCTION
  135.  
  136. FUNCTION CurDir$ (DriveNum)
  137.   ' returns current dir without leading \ or drive
  138.   ' drive number is 0 for default, 1 for a, etc
  139.   STATIC Temp$
  140.   Temp$ = SPACE$(64)
  141.   Regs.AX = &H4700
  142.   Regs.DX = DriveNum
  143.   Regs.DS = VARSEG(Temp$)
  144.   Regs.SI = SADD(Temp$)    ' use SADD for dynamic strings!
  145.   Interrupt &H21, Regs
  146.   CurDir$ = LEFT$(Temp$, INSTR(Temp$, CHR$(0)) - 1)
  147. END FUNCTION
  148.  
  149. FUNCTION CurDrive
  150.   ' returns logged drive (a=1, b=2, etc)
  151.   Regs.AX = &H1900
  152.   Interrupt &H21, Regs
  153.   CurDrive = Regs.AX MOD 256 + 1
  154. END FUNCTION
  155.  
  156. FUNCTION DosVer$
  157.   ' returns DOS version in string format
  158.   Regs.AX = &H3000
  159.   Interrupt &H21, Regs
  160.   DosVer$ = RTRIM$(STR$(Regs.AX MOD 256)) + "." + LTRIM$(STR$(Regs.AX \ 256))
  161. END FUNCTION
  162.  
  163. SUB Explode (Top, Lft, Bot, Rgt, Attr, Shad, Delay)
  164.   Wide = Rgt - Lft
  165.   High = Bot - Top
  166.   HMid = (Rgt + Lft) \ 2
  167.   VMid = (Top + Bot) \ 2
  168.   FOR i = 1 TO High \ 2
  169.     HOfs = i * (Wide / High)
  170.     IF HOfs >= 1 THEN
  171.       SLBox VMid - i, HMid - HOfs, VMid + i, HMid + HOfs, Attr, 0
  172.     END IF
  173.     TickPause Delay
  174.   NEXT
  175.   SLBox Top, Lft, Bot, Rgt, Attr, Shad
  176. END SUB
  177.  
  178. FUNCTION FileExist (Filespec$) STATIC
  179.   ' set new DOS DTA
  180.   DIM DTA AS STRING * 43
  181.   DTA = SPACE$(43)
  182.   Regs.AX = &H1A00
  183.   Regs.DS = VARSEG(DTA)
  184.   Regs.DX = VARPTR(DTA)
  185.   Interrupt &H21, Regs
  186.   ' insulate Filespec from change
  187.   Spec$ = Filespec$ + CHR$(0)
  188.   Regs.AX = &H4E00
  189.   Regs.CX = 39
  190.   Regs.DS = VARSEG(Spec$)
  191.   Regs.DX = SADD(Spec$)
  192.   Interrupt &H21, Regs
  193.   IF Regs.Flags AND 1 THEN FileExist = 0 ELSE FileExist = -1
  194. END FUNCTION
  195.  
  196. SUB Interrupt (IntNum, Regs AS RegTypeX) STATIC
  197.   STATIC FileNum, IntOffset, Loaded
  198.   ' use fixed-length string to fix its position in memory
  199.   ' and so we don't mess up string pool before routine
  200.   ' gets its pointers from caller
  201.   DIM IntCode AS STRING * 200
  202.   IF NOT Loaded THEN                        ' loaded will be 0 first time
  203.     IntCode = LoadBin("IntCode.BIN")   ' load routine and determine
  204.     IntOffset = INSTR(IntCode$, CHR$(&HCD) + CHR$(&H21)) + 1 ' int # offset
  205.     Loaded = -1
  206.   END IF
  207.   SELECT CASE IntNum
  208.     CASE &H25, &H26, IS > 255               ' ignore these interrupts
  209.     CASE ELSE
  210.       DEF SEG = VARSEG(IntCode)             ' poke interrupt number into
  211.       POKE VARPTR(IntCode) * 1& + IntOffset - 1, IntNum' code block
  212.       CALL Absolute(Regs, VARPTR(IntCode$)) ' call routine
  213.   END SELECT
  214. END SUB
  215.  
  216. FUNCTION LoadBin$ (BinFileName$)
  217.   ' Loads a binary file as a string
  218.   STATIC FileNum, Buf$
  219.   FileNum = FREEFILE
  220.   OPEN BinFileName$ FOR BINARY AS FileNum
  221.   IF LOF(FileNum) = 0 THEN
  222.     CLOSE FileNum
  223.     KILL BinFileName$
  224.     CLS : PRINT "Can't find "; BinFileName$; " - aborting."
  225.     END
  226.   END IF
  227.   Buf$ = SPACE$(LOF(FileNum)) ' size buffer
  228.   GET FileNum, , Buf$
  229.   CLOSE #FileNum
  230.   LoadBin$ = Buf$
  231. END FUNCTION
  232.  
  233. SUB ScrnSave (SaveRestore) STATIC
  234.   STATIC InitDone
  235.   IF NOT InitDone THEN
  236.     REDIM ScrnBuf(1 TO 2000) ' 4000 bytes
  237.     DEF SEG = 0
  238.     IF PEEK(&H463) = &HB4 THEN
  239.       VidSeg = &HB000 ' mono
  240.     ELSE
  241.       VidSeg = &HB800 ' color
  242.     END IF
  243.     InitDone = -1
  244.   END IF
  245.   IF SaveRestore THEN ' save
  246.     BlockCopy VidSeg, 0, VARSEG(ScrnBuf(1)), VARPTR(ScrnBuf(1)), 4000
  247.   ELSE
  248.     BlockCopy VARSEG(ScrnBuf(1)), VARPTR(ScrnBuf(1)), VidSeg, 0, 4000
  249.   END IF
  250. END SUB
  251.  
  252. SUB ScrollArea (Top, Lft, Bot, Rgt, Attr, Lines)
  253.   ' scrolls area up (or down if lines negative)
  254.   ' scrolled away area filled with Attr
  255.   ' use lines = 0 to clear entire area to Attr
  256.   IF Lines > 0 THEN
  257.     Regs.AX = &H600 + Lines
  258.   ELSE
  259.     Regs.AX = &H700 - Lines
  260.   END IF
  261.   Regs.BX = Attr * 256
  262.   Regs.CX = (Top - 1) * 256 + Lft - 1
  263.   Regs.DX = (Bot - 1) * 256 + Rgt - 1
  264.   Interrupt &H10, Regs
  265. END SUB
  266.  
  267. SUB SLBox (Top, Lft, Bot, Rgt, Attr, Shad)
  268.   STATIC SLB$, BinLoaded
  269.   IF NOT BinLoaded THEN
  270.     SLB$ = LoadBin("SLBox.BIN")
  271.     BinLoaded = -1
  272.   END IF
  273.   DEF SEG = VARSEG(SLB$)
  274.   CALL Absolute(Top, Lft, Bot, Rgt, Attr, Shad, SADD(SLB$))
  275. END SUB
  276.  
  277. SUB TickPause (Ticks)
  278.   DEF SEG = 0
  279.   FOR i = 1 TO Ticks
  280.     Now = PEEK(&H46C)
  281.     DO: LOOP WHILE PEEK(&H46C) = Now
  282.   NEXT
  283. END SUB
  284.  
  285. FUNCTION WeekDay$
  286.   Regs.AX = &H2A00
  287.   Interrupt &H21, Regs
  288.   SELECT CASE Regs.AX MOD 256 + 1
  289.     CASE 1: WeekDay$ = "Sunday"
  290.     CASE 2: WeekDay$ = "Monday"
  291.     CASE 3: WeekDay$ = "Tuesday"
  292.     CASE 4: WeekDay$ = "Wednesday"
  293.     CASE 5: WeekDay$ = "Thursday"
  294.     CASE 6: WeekDay$ = "Friday"
  295.     CASE 7: WeekDay$ = "Saturday"
  296.   END SELECT
  297. END FUNCTION
  298.  
  299.