home *** CD-ROM | disk | FTP | other *** search
/ The Business Master (3rd Edition) / The Business Master (3rd Edition).iso / files / utilfile / hardutl2 / dir2.bas < prev    next >
Encoding:
BASIC Source File  |  1983-11-27  |  20.9 KB  |  513 lines
  1. 10 '  *** DIR.BAS *** IBM Version 2.00 *** 
  2. 20 '      August 1983 
  3. 30 ' 
  4. 40 '      Written by Wes Meier (70215,1017) 
  5. 50 '      230 B Park Lake Circle 
  6. 60 '      Walnut Creek, CA 94598 
  7. 70 ' 
  8. 80 '      Will work with DOS 1.10 or 2.00 
  9. 90 ' 
  10. 100 '     Notes on Version 2.00: 
  11. 110 '     ---------------------- 
  12. 120 ' 1 - Version 2.00 requires BASICA but does NOT use any of its 
  13. 130 '     new commands, so DIR 2.00 should compile satifactorily. 
  14. 140 ' 
  15. 150 ' 2 - The List File to Lineprinter routine has been implemented. This 
  16. 160 '     routine uses only "plain vanilla" printer statements. Prints at 
  17. 170 '     10 cpi and 6 lpi. 150 files per page. Pages are numbered. 
  18. 180 ' 
  19. 190 ' 3 - Version 2.00  does NOT support paths or alternate directories. 
  20. 200 ' 
  21. 210 ' 4 - Version 2.00 will NOT allow you to "read" the directory of drive C: 
  22. 220 '     into the list file. This is due to the way I execute the FILES 
  23. 230 '     statement and then read the screen into memory. If drive C: is a 
  24. 240 '     hard disk (which it usually is) there would be too many files for 
  25. 250 '     the screen to handle without scrolling. 
  26. 260 ' 
  27. 270 ' 5 - Version 2.00 will now function on either type of monitor. 80 column 
  28. 280 '     is still required. 
  29. 290 ' 
  30. 300 ' 6 - Version 2.00 will directly compile with the /E option. 
  31. 310 ' 
  32. 320 '  **************************************************************** 
  33. 330 '  * *** For Public Domain....Private Sales Rights Reserved ! *** * 
  34. 340 '  **************************************************************** 
  35. 350 ' 
  36. 360 DEFINT B-Z:DEFSTR A 
  37. 370 AV=CHR$(34):AL=STRING$(80,196):AQ="("+AV+"*"+AV+" to QUIT) " 
  38. 380 TRUE=-1:FALSE=NOT TRUE:AFORMAT="\ \  \          \    " 
  39. 390 ' Check for monochrome monitor. 
  40. 400 DEF SEG=0 
  41. 410 IF (PEEK(&H410) AND &H30)=&H30 THEN MONOCHROME=TRUE ELSE MONOCHROME=FALSE 
  42. 420 DEF SEG 
  43. 430 DIM A(1000) 
  44. 440 KEY OFF:WIDTH 40:SCREEN 0,1:COLOR 4,3,3:CLS 
  45. 450 LOCATE 9,7,0,0,7:PRINT CHR$(201)STRING$(28,205)CHR$(187) 
  46. 460 PRINT TAB(7) CHR$(186)SPC(3)"*** Disk Directory ***   "CHR$(186) 
  47. 470 PRINT TAB(7) CHR$(186)SPC(3)" *** Version 2.00 ***    "CHR$(186) 
  48. 480 PRINT TAB(7) CHR$(186)SPC(3)" *** August  1983 ***    "CHR$(186) 
  49. 490 PRINT TAB(7) CHR$(186)SPC(3)" *** By Wes Meier ***    "CHR$(186) 
  50. 500 PRINT TAB(7)CHR$(204)STRING$(28,205)CHR$(185) 
  51. 510 PRINT TAB(7)CHR$(186)SPC(2)"Reading: "AV SPC(15)AV CHR$(186) 
  52. 520 PRINT TAB(7)CHR$(200)STRING$(28,205)CHR$(188) 
  53. 530 ' 
  54. 540 ' Check for DOS 1.10. "WINDOW=0" will cause error if 2.00. 
  55. 550 ' When compiled, version 2.00 "thinks" its under DOS 1.10. 
  56. 560 ' 
  57. 570 ON ERROR GOTO 600 
  58. 580 WINDOW=0:DOS1.1=TRUE 
  59. 590 GOTO 610 
  60. 600 IF ERL=580 THEN DOS1.1=FALSE:RESUME 610 
  61. 610 ON ERROR GOTO 630 
  62. 620 GOTO 660 
  63. 630 IF ERR=53 THEN RESUME 640 ELSE ON ERROR GOTO 0 
  64. 640 CLOSE:OPEN "O",1,"DIR.DAT":CLOSE 
  65. 650 ON ERROR GOTO 0 
  66. 660 OPEN "I",1,"DIR.DAT" 
  67. 670 FOR X=1 TO 1000 
  68. 680   IF EOF(1)THEN CLOSE:GOTO 720 ELSE INPUT #1,A(X):ENTRIES=ENTRIES+1 
  69. 690   LOCATE 15,20,0:PRINT A(X); 
  70. 700 NEXT 
  71. 710 CLOSE 
  72. 720 '                           ************ 
  73. 730 '                         ****  MENU  **** 
  74. 740 '                           ************ 
  75. 750 IF SORTFLAG THEN GOSUB 5040 
  76. 760 IF MONOCHROME THEN COLOR 7 ELSE IF PAGE THEN COLOR ,,1:SCREEN ,,1,1:GOTO 1320 
  77. 770 WIDTH 80:SCREEN 0,1,1,1:COLOR ,1,1:PAGE=TRUE 
  78. 780 CLS 
  79. 790 COLOR 6 
  80. 800 LOCATE 5,1,0 
  81. 810 PRINT CHR$(201)STRING$(78,205)CHR$(187); 
  82. 820 PRINT CHR$(186); 
  83. 830 COLOR 13 
  84. 840 PRINT TAB(13)"*** DISK DIRECTORY *** MENU ****"; 
  85. 850 PRINT ENTRIES"ENTRIES ON RECORD ***"; 
  86. 860 COLOR 6 
  87. 870 PRINT TAB(80)CHR$(186); 
  88. 880 PRINT CHR$(204)STRING$(78,205)CHR$(185); 
  89. 890 PRINT CHR$(186)TAB(13); 
  90. 900 COLOR 3:PRINT"Enter:"TAB(80):COLOR 6:PRINT CHR$(186); 
  91. 910 PRINT CHR$(186)TAB(19); 
  92. 920 COLOR 27:PRINT"1. ";:COLOR 3 
  93. 930 PRINT"To FIND an item."TAB(80); 
  94. 940 COLOR 6:PRINT CHR$(186); 
  95. 950 PRINT CHR$(186)TAB(19); 
  96. 960 COLOR 27:PRINT"2. ";:COLOR 3 
  97. 970 PRINT"To ENTER an item or an entire disk."TAB(80); 
  98. 980 COLOR 6:PRINT CHR$(186); 
  99. 990 PRINT CHR$(186)TAB(19); 
  100. 1000 COLOR 27:PRINT"3. ";:COLOR 3 
  101. 1010 PRINT"To DELETE an item or an entire disk."TAB(80); 
  102. 1020 COLOR 6:PRINT CHR$(186); 
  103. 1030 PRINT CHR$(186)TAB(19); 
  104. 1040 COLOR 27:PRINT"4. ";:COLOR 3 
  105. 1050 PRINT"To LIST the file to the CRT or the PRINTER."TAB(80); 
  106. 1060 COLOR 6:PRINT CHR$(186); 
  107. 1070 PRINT CHR$(186)TAB(19); 
  108. 1080 COLOR 27:PRINT"5. ";:COLOR 3 
  109. 1090 PRINT"To LIST the directory of a disk."TAB(80); 
  110. 1100 COLOR 6:PRINT CHR$(186); 
  111. 1110 PRINT CHR$(186)TAB(19); 
  112. 1120 COLOR 27:PRINT"6. ";:COLOR 3 
  113. 1130 PRINT"To BACKUP the data file."TAB(80); 
  114. 1140 COLOR 6:PRINT CHR$(186); 
  115. 1150 PRINT CHR$(186)TAB(19); 
  116. 1160 COLOR 27:PRINT"";:COLOR 3 
  117. 1170 PRINT""TAB(80); 
  118. 1180 COLOR 6:PRINT CHR$(186); 
  119. 1190 PRINT CHR$(186)TAB(19); 
  120. 1200 COLOR 27:PRINT"";:COLOR 3 
  121. 1210 PRINT""TAB(80); 
  122. 1220 COLOR 6:PRINT CHR$(186); 
  123. 1230 PRINT CHR$(186)TAB(19); 
  124. 1240 COLOR 27:PRINT"9. ";:COLOR 3 
  125. 1250 PRINT"To RETURN to DOS."TAB(80); 
  126. 1260 COLOR 6:PRINT CHR$(186); 
  127. 1270 PRINT CHR$(204)STRING$(78,205)CHR$(185); 
  128. 1280 PRINT CHR$(186)TAB(27); 
  129. 1290 COLOR 20,7:PRINT" *** ENTER YOUR CHOICE *** "; 
  130. 1300 COLOR 6,1:PRINT TAB(80)CHR$(186); 
  131. 1310 PRINT CHR$(200)STRING$(78,205)CHR$(188); 
  132. 1320 BEEP 
  133. 1330 CHOICE$="":WHILE CHOICE$="":CHOICE$=INKEY$:WEND 
  134. 1340 CHOICE=INSTR("123456789",CHOICE$) 
  135. 1350 IF CHOICE=0 THEN 1320 
  136. 1360 SCREEN ,,0,0:COLOR 6,1,1:CLS 
  137. 1370 '               1    2    3    4    5    6    7    8    9 
  138. 1380 ON CHOICE GOTO 1390,1790,2590,3020,3650,4050,750,750,4620 
  139. 1390 '**************************************** 
  140. 1400 '*     ***  Find an ITEM routine ***    * 
  141. 1410 '**************************************** 
  142. 1420 COLOR ,3,3:CLS 
  143. 1430 COLOR 16:PRINT AL;:COLOR 1 
  144. 1440 PRINT TAB(26)"*** FIND AN ITEM ROUTINE ***" 
  145. 1450 COLOR 16:PRINT AL 
  146. 1460 COLOR 4:PRINT"Enter complete or partial "; 
  147. 1470 PRINT"filespec of ITEM to be found "AQ"........" 
  148. 1480 COLOR 1:INPUT AT:IF AT="*" THEN 720' Return to menu. 
  149. 1490 ACAP=AT:GOSUB 5230:AT=ACAP 
  150. 1500 FOR X=1 TO ENTRIES 
  151. 1510 IF INSTR(A(X),AT)=0 OR LEFT$(A(X),12)=LEFT$(AX,12) THEN 1600 
  152. 1520 AX=A(X) 
  153. 1530 PRINT AV;LEFT$(A(X),12);AV" can be found on disks: "; 
  154. 1540 FOR Y=X TO ENTRIES 
  155. 1550   IF LEFT$(AX,12)=LEFT$(A(Y),12) THEN PRINT RIGHT$(A(Y),3)", ";:GOTO 1570 
  156. 1560   Y=ENTRIES 
  157. 1570 NEXT 
  158. 1580 PRINT:PRINT:PRINT"Is this the ITEM you wanted to find "; 
  159. 1590 GOSUB 4770:IF ANSWER="Y"THEN 1620 
  160. 1600 NEXT:PRINT:PRINT"I cannot locate any incidence of "AV;AT;AV". Try again." 
  161. 1610 PRINT:GOTO 1460 
  162. 1620 PRINT:PRINT"Do you want to RUN "AV;AX;AV" "; 
  163. 1630 GOSUB 4770:IF ANSWER="N" THEN 720 
  164. 1640 ON ERROR GOTO 1660 
  165. 1650 GOTO 1670 
  166. 1660 IF ERR=53 THEN RESUME 1680 ELSE ON ERROR GOTO 0 
  167. 1670 IF MID$(AX,10,3)="BAS" THEN RUN "A:"+LEFT$(AX,12) ELSE 1750 
  168. 1680 ON ERROR GOTO 1690:RUN "B:"+LEFT$(AX,12) 
  169. 1690 IF ERR=53 THEN RESUME 1700 ELSE ON ERROR GOTO 0 
  170. 1700 COLOR 4:PRINT:BEEP:BEEP:PRINT"I cannot locate "AV;AX;AV; 
  171. 1710 PRINT" on either drive "AV"A"AV" or drive "AV"B"AV"!!!" 
  172. 1720 PRINT"Please check to see that Disk #"; 
  173. 1730 PRINT RIGHT$(AX,3)" is mounted and press any" 
  174. 1740 PRINT"key to continue ";:COLOR 1:GOSUB 4700:PRINT:GOTO 1620 
  175. 1750 PRINT:PRINT"Since "AV;AX;AV" doesn't have the "AV".BAS"AV" extension,"; 
  176. 1760 PRINT "I can't RUN it!" 
  177. 1770 PRINT"Press any key to return to the menu...("AV"*"AV" to jump to DOS) "; 
  178. 1780 GOSUB 4670:IF ANSWER<>"*"THEN 720 ELSE CLS:SYSTEM 
  179. 1790 '**************************** 
  180. 1800 '**** ITEM ENTRY ROUTINE **** 
  181. 1810 '**************************** 
  182. 1820 COLOR 4,7,7:CLS 
  183. 1830 COLOR 1:PRINT AL;:COLOR 4 
  184. 1840 PRINT TAB(27)"*** Item Entry Routine ***" 
  185. 1850 COLOR 1:PRINT AL:COLOR 4 
  186. 1860 LOCATE 12,1 
  187. 1870 PRINT"Do you want to enter from the ";:COLOR 17:PRINT"K";:COLOR 4 
  188. 1880 PRINT "eyboard or read a ";:COLOR 17:PRINT "D";:COLOR 4:PRINT "isk "AQ; 
  189. 1890 COLOR 1 
  190. 1900 GOSUB 4670:COLOR 4 
  191. 1910 IF ANSWER="*"THEN 720 ELSE IF ANSWER="k" OR ANSWER="K" THEN 1940 
  192. 1920 IF ANSWER="D" OR ANSWER="d" THEN 2130 
  193. 1930 LOCATE L,T:BEEP:GOTO 1900 
  194. 1940 ' Keyboard item entry routine 
  195. 1950 LOCATE 12,1:PRINT SPACE$(79) 
  196. 1960 LOCATE 4,1 
  197. 1970 PRINT AV".BAS"AV" is the default extension." 
  198. 1980 PRINT "Enter filespec "AQ;:INPUT A:IF A="*"THEN 720 
  199. 1990 ACAP=A:GOSUB 5230:A=ACAP 
  200. 2000 IF LEN(A)>12 THEN BEEP:PRINT A" is too long !":GOTO 1980 
  201. 2010 INPUT "Enter disk # ";AD 
  202. 2020 IF VAL(AD)<1 OR VAL(AD)>999 THEN BEEP:GOTO 2010 
  203. 2030 AD=RIGHT$("00"+AD,3) 
  204. 2040 K=INSTR(A,".") 
  205. 2050 IF K=0 THEN A=LEFT$(A+"       ",8)+".BAS":GOTO 2040 
  206. 2060 A=LEFT$(MID$(A,1,K-1)+"       ",8)+RIGHT$(A,LEN(A)-(K-1)) 
  207. 2070 A=LEFT$(A+"   ",12)+AD 
  208. 2080 PRINT"Is "AV;A;AV" correct "; 
  209. 2090 GOSUB 4770:IF ANSWER$="N"THEN 1980 
  210. 2100 ENTRIES=ENTRIES+1 
  211. 2110 A(ENTRIES)=A:A="":PRINT"Entered. Do you have any more entries "; 
  212. 2120 GOSUB 4770:IF ANSWER="N"THEN GOSUB 5010:GOSUB 4960:RUN ELSE 1970 
  213. 2130 'Read disk entry routine 
  214. 2140 LOCATE 12,1:PRINT SPACE$(79) 
  215. 2150 LOCATE 4,1 
  216. 2160 PRINT "Enter disk number to be read "AQ; 
  217. 2170 INPUT ADISK:IF ADISK="*"THEN 720 ELSE DISK=VAL (ADISK) 
  218. 2180 IF DISK<0 OR DISK>999 THEN BEEP:GOTO 2160 
  219. 2190 ADISK=STR$(DISK):MID$(ADISK,1)="0":ADISK=RIGHT$("00"+ADISK,3) 
  220. 2200 PRINT "Enter drive (A or B) (B is the default) "; 
  221. 2210 GOSUB 4670:ADRIVE=ANSWER$:IF ADRIVE=CHR$(13) THEN ADRIVE="B":GOTO 2240 
  222. 2220 ACAP=ADRIVE:GOSUB 5230:ADRIVE=ACAP 
  223. 2230 IF ADRIVE<>"A" AND ADRIVE<>"B" THEN LOCATE L,T:BEEP:GOTO 2210 
  224. 2240 LOCATE L,T:PRINT "? "ADRIVE 
  225. 2250 PRINT:PRINT"Read disk #"ADISK" on drive "AV;ADRIVE;AV". Is this correct "; 
  226. 2260 GOSUB 4770:IF ANSWER="N"THEN 2160 
  227. 2270 PRINT"Deleting references to disk #"ADISK"......" 
  228. 2280 FOR X=1 TO ENTRIES 
  229. 2290   IF RIGHT$(A(X),3)=ADISK THEN A(X)="" 
  230. 2300 NEXT 
  231. 2310 '              ****************************************** 
  232. 2320 '            ***** Routine to Read a Disk's Directory **DIR2    BASC4      112783 21376.                            
  233. ****** 
  234. 2340 CLS 
  235. 2350 PRINT AL; 
  236. 2360 IF ADRIVE="A"THEN FILES"A:*.*" ELSE FILES "B:*.*" 
  237. 2370 PRINT:PRINT AL; 
  238. 2380 ROW=CSRLIN:COL=POS(0):COLOR 6,1 
  239. 2390 IF DOS1.1 THEN STLIN=2 ELSE STLIN=3 
  240. 2400 IF DOS1.1 THEN ENDPT=78:STEPPT=13 ELSE ENDPT=69:STEPPT=18 
  241. C2      C3      {&B:C2       ╖>σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷σ÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷÷60 GOSUB 5010 
  242. 2570 GOSUB 4960 
  243. 2580 RUN 
  244. 2590 '          ***************************************************** 
  245. 2600 '          *   *** DELETE AN ITEM OR ENTIRE DISK ROUTINE ***   * 
  246. 2610 '          ***************************************************** 
  247. 2620 COLOR 2,0,0:CLS 
  248. 2630 PRINT AL; 
  249. 2640 PRINT TAB(22)"*** DELETE AN ITEM OR DISK ROUTINE ***" 
  250. 2650 PRINT AL; 
  251. 2660 LOCATE 12,1 
  252. 2670 PRINT"Delete an "; 
  253. 2680 COLOR 20,7:PRINT"I"; 
  254. 2690 COLOR 2,0:PRINT"tem or an entire "; 
  255. 2700 COLOR 20,7:PRINT"D"; 
  256. 2710 COLOR 2,0:PRINT"isk "AQ; 
  257. 2720 COLOR 4,7:GOSUB 4680:COLOR 2,0 
  258. 2730 IF ANSWER="*"THEN 720 ELSE IF ANSWER="I" THEN 2790 
  259. 2740 IF ANSWER="i" THEN 2790 
  260. 2750 IF ANSWER="D" THEN 2930 
  261. 2760 IF ANSWER="d" THEN 2930 
  262. 2770 SOUND 350,4:LOCATE L,T 
  263. 2780 GOTO 2720 
  264. 2790 '*** Item Delete *** 
  265. 2800 LOCATE L,T:PRINT"? Item":PRINT 
  266. 2810 PRINT"Enter complete or partial filespec of item to be deleted "AQ; 
  267. 2820 INPUT AT:IF AT="*"THEN 720 
  268. 2830 ACAP=AT:GOSUB 5230:AT=ACAP 
  269. 2840 FOR X=1 TO ENTRIES 
  270. 2850   IF INSTR(A(X),AT)<>0 THEN 2880 
  271. 2860 NEXT 
  272. 2870 PRINT"I can't locate "AV;AT;AV". Try again.":GOTO 2810 
  273. 2880 PRINT"Is "AV;A(X);AV" the item you want to delete "; 
  274. 2890 GOSUB 4770:IF ANSWER$="N"THEN 2860 
  275. 2900 A(X)="":PRINT"Deleted. Do you have any other items to delete "; 
  276. 2910 GOSUB 4770:IF ANSWER$="Y"THEN 2810 
  277. 2920 GOSUB 4960:RUN 
  278. 2930 '*** Disk Delete *** 
  279. 2940 PRINT"Enter number of disk to be deleted ";:INPUT D 
  280. 2950 PRINT"Searching......."; 
  281. 2960 FOR X=1 TO ENTRIES 
  282. 2970   IF VAL(RIGHT$(A(X),3))=D THEN A(X)="" 
  283. 2980 NEXT 
  284. 2990 PRINT"Done." 
  285. 3000 PRINT"Do you have any other disks to delete "; 
  286. 3010 GOSUB 4770:IF ANSWER$="Y"THEN 2940 ELSE 2920 
  287. 3020 '************************** 
  288. 3030 '*  *** LIST ROUTINE ***  * 
  289. 3040 '************************** 
  290. 3050 COLOR 4,3,3:CLS 
  291. 3060 LOCATE 11,1:PRINT"Do you want the list Sorted by Disk number "; 
  292. 3070 GOSUB 4770:IF ANSWER$="Y"THEN GOSUB 5140 
  293. 3080 PRINT"List to "; 
  294. 3090 COLOR 30,0:PRINT"C"; 
  295. 3100 COLOR 4,3:PRINT"RT or "; 
  296. 3110 COLOR 30,0:PRINT"P"; 
  297. 3120 COLOR 4,3:PRINT"rinter "; 
  298. 3130 GOSUB 4680:IF ANSWER$="*"THEN 720 
  299. 3140 IF ANSWER$="c" OR ANSWER$="C"THEN 3190 
  300. 3150 IF ANSWER$="p" OR ANSWER$="P"THEN 3380 
  301. 3160 SOUND 200,5 
  302. 3170 LOCATE L,T 
  303. 3180 GOTO 3130 
  304. 3190 '*** List to CRT Routine *** 
  305. 3200 WIDTH 40:COLOR 4,3,3:PAGE=FALSE:BACK=FALSE 
  306. 3210 SCREEN 0,1,0,0:CLS 
  307. 3220 FOR X=1 TO ENTRIES 
  308. 3230   IF X/22=INT(X/22) THEN 3330 
  309. 3240   PRINT USING "###  ";X; 
  310. 3250   COLOR 1 
  311. 3260   PRINT LEFT$(A(X),12);:COLOR 4 
  312. 3270   PRINT"  Disk # ";:COLOR 1:PRINT RIGHT$(A(X),3):COLOR 4 
  313. 3280 NEXT 
  314. 3290 LOCATE 25,1:COLOR 20,7 
  315. 3300 PRINT"End of listing. Press any key "; 
  316. 3310 GOSUB 4680 
  317. 3320 GOTO 720 
  318. 3330 COLOR 20,7 
  319. 3340 LOCATE 25,1:PRINT"Press any key to continue "; 
  320. 3350 GOSUB 4680 
  321. 3360 COLOR 4,3:CLS:GOTO 3280 
  322. 3370 '*********************** 
  323. 3380 '*** List to Printer *** 
  324. 3390 '*********************** 
  325. 3400 CLS:LOCATE 12,1 
  326. 3410 PRINT"Printing List. Press any key to abort printout....." 
  327. 3420 PAGES=ENTRIES\150+1 
  328. 3430 FOR PAGE.NUM=1 TO PAGES 
  329. 3440   LPRINT 
  330. 3450   LPRINT TAB(12)DATE$;TAB(52)"Page"PAGE.NUM"of"PAGES"Pages." 
  331. 3460   LPRINT 
  332. 3470   LPRINT TAB(12); 
  333. 3480   FOR X=1 TO 3 
  334. 3490     LPRINT USING AFORMAT;"Dsk","Filespec"; 
  335. 3500   NEXT 
  336. 3510   LPRINT 
  337. 3520   LPRINT TAB(12)STRING$(59,"-") 
  338. 3530   FOR X=(PAGE.NUM-1)*150 TO (PAGE.NUM-1)*150+50 
  339. 3540     LPRINT TAB(12); 
  340. 3550     FOR Y=1 TO 150 STEP 50 
  341. 3560       IF INKEY$<>"" THEN Y=3:X=ENTRIES+150:PAGE.NUM=PAGES:GOTO 3590 
  342. 3570       IF (X+Y)>ENTRIES THEN Y=151:GOTO 3590 
  343. 3580       LPRINT USING AFORMAT;RIGHT$(A(X+Y),3);LEFT$(A(X+Y),12); 
  344. 3590     NEXT 
  345. 3600     LPRINT 
  346. 3610   NEXT 
  347. 3620   LPRINT TAB(12)STRING$(59,"-");CHR$(12); 
  348. 3630 NEXT 
  349. 3640 GOTO 720 
  350. 3650 '****************************************************** 
  351. 3660 '*   *** Routine to list the Directory of a Disk ***  * 
  352. 3670 '****************************************************** 
  353. 3680 CLS 
  354. 3690 PRINT AL; 
  355. 3700 PRINT TAB(20)"*** Display Disk Directory Routine ***" 
  356. 3710 PRINT AL 
  357. 3720 PRINT"Do you want an "; 
  358. 3730 COLOR 31,0:PRINT"A"; 
  359. 3740 COLOR 6,1:PRINT"ctual Disk Directory or the "; 
  360. 3750 COLOR 31,0:PRINT"D"; 
  361. 3760 COLOR 6,1:PRINT "ata of a Disk as stored by "AV"DIR"AV"." 
  362. 3770 PRINT AQ; 
  363. 3780 GOSUB 4680:IF ANSWER$="*"THEN 720 
  364. 3790 IF ANSWER="A" OR ANSWER="a" THEN 3820 
  365. 3800 IF ANSWER="D" OR ANSWER="d" THEN 3930 
  366. 3810 SOUND 234,5:LOCATE L,T:GOTO 3780 
  367. 3820 '*** List actual directory *** 
  368. 3830 LOCATE L,T:PRINT "? Actual Directory" 
  369. 3840 PRINT"Enter drive "AV"A"AV", "AV"B"AV", or "AV"C"AV" "; 
  370. 3850 GOSUB 4680:IF ANSWER="*"THEN 720 
  371. 3860 ACAP=ANSWER:GOSUB 5230 
  372. 3870 IF ACAP="A" OR ACAP="B" OR ACAP="C" THEN ANSWER=ACAP:GOTO 3890 
  373. 3880 SOUND 231,5:LOCATE L,T:GOTO 3850 
  374. 3890 LOCATE L,T:PRINT "? "ANSWER 
  375. 3900 PRINT AL:COLOR 0,2 
  376. 3910 FILES ANSWER+":*.*" 
  377. 3920 COLOR 6,1:GOTO 3710 
  378. 3930 LOCATE L,T:PRINT"? Data":PRINT "Enter disk number "AQ; 
  379. 3940 INPUT AD:IF AD="*"THEN 720 
  380. 3950 D=VAL(AD):C=0 
  381. 3960 PRINT AL:COLOR 0,2 
  382. 3970 FOR X=1 TO ENTRIES 
  383. 3980   IF D<>VAL(RIGHT$(A(X),3))THEN 4020 
  384. 3990   IF POS(0)>=78 THEN PRINT 
  385. 4000   PRINT LEFT$(A(X),12)" "; 
  386. 4010   C=C+1 
  387. 4020 NEXT 
  388. 4030 IF C=0 THEN PRINT"Disk number"D"isn't listed." 
  389. 4040 GOTO 3920 
  390. 4050 '****************************************************** 
  391. 4060 '*          *** Backup Data File  Routine ***         * 
  392. 4070 '****************************************************** 
  393. 4080 IF BACK AND NOT MONOCHROME THEN SCREEN ,,2,2:COLOR 6,1,1:GOTO 4530 
  394. 4090 WIDTH 80:IF MONOCHROME THEN CLS:COLOR 7,0 ELSE SCREEN 0,1,2,2:COLOR ,1,1:BACK=TRUE 
  395. 4100 BACK=TRUE:CLS 
  396. 4110 COLOR 6 
  397. 4120 LOCATE 5,1,0 
  398. 4130 PRINT CHR$(201)STRING$(78,205)CHR$(187); 
  399. 4140 PRINT CHR$(186); 
  400. 4150 COLOR 13 
  401. 4160 PRINT TAB(18)"     *** Backup Data File Routine ***"; 
  402. 4170 COLOR 6 
  403. 4180 PRINT TAB(80)CHR$(186); 
  404. 4190 PRINT CHR$(204)STRING$(78,205)CHR$(185); 
  405. 4200 PRINT CHR$(186)TAB(13); 
  406. 4210 COLOR 3:PRINT"Enter:"TAB(80):COLOR 6:PRINT CHR$(186); 
  407. 4220 PRINT CHR$(186)TAB(19); 
  408. 4230 COLOR 27:PRINT"1. ";:COLOR 3 
  409. 4240 PRINT"To BACKUP the Data File to drive "AV"A"AV"."TAB(80); 
  410. 4250 COLOR 6:PRINT CHR$(186); 
  411. 4260 PRINT CHR$(186)TAB(19); 
  412. 4270 COLOR 27:PRINT"2. ";:COLOR 3 
  413. 4280 PRINT"To BACKUP the Data File to drive "AV"B"AV"."TAB(80); 
  414. 4290 COLOR 6:PRINT CHR$(186); 
  415. 4300 PRINT CHR$(186)TAB(19); 
  416. 4310 COLOR 27:PRINT"3. ";:COLOR 3 
  417. 4320 PRINT"To BACKUP the Data File to drive "AV"C"AV"."TAB(80); 
  418. 4330 COLOR 6:PRINT CHR$(186); 
  419. 4340 PRINT CHR$(186)TAB(19); 
  420. 4350 COLOR 6:PRINT TAB(80) CHR$(186); 
  421. 4360 PRINT CHR$(186)TAB(19); 
  422. 4370 COLOR 6:PRINT TAB(80) CHR$(186); 
  423. 4380 PRINT CHR$(186)TAB(19); 
  424. 4390 COLOR 6:PRINT TAB(80) CHR$(186); 
  425. 4400 PRINT CHR$(186)TAB(19); 
  426. 4410 COLOR 6:PRINT TAB(80) CHR$(186); 
  427. 4420 PRINT CHR$(186)TAB(19); 
  428. 4430 COLOR 6:PRINT TAB(80) CHR$(186); 
  429. 4440 PRINT CHR$(186)TAB(19); 
  430. 4450 COLOR 27:PRINT"9. ";:COLOR 3 
  431. 4460 PRINT"To RETURN to the main MENU."TAB(80); 
  432. 4470 COLOR 6:PRINT CHR$(186); 
  433. 4480 PRINT CHR$(204)STRING$(78,205)CHR$(185); 
  434. 4490 PRINT CHR$(186)TAB(27); 
  435. 4500 COLOR 20,7:PRINT" *** ENTER YOUR CHOICE *** "; 
  436. 4510 COLOR 6,1:PRINT TAB(80)CHR$(186); 
  437. 4520 PRINT CHR$(200)STRING$(78,205)CHR$(188); 
  438. 4530 BEEP 
  439. 4540 CHOICE$="":WHILE CHOICE$="":CHOICE$=INKEY$:WEND 
  440. 4550 CHOICE=INSTR("123456789",CHOICE$):IF CHOICE=0 THEN 4530 
  441. 4560 '                1    2    3    4    5    6    7    8    9 
  442. 4570 ON CHOICE GOSUB 4590,4600,4610,4080,4080,4080,4080,4080,720 
  443. 4580 GOTO 4080 
  444. 4590 DRIVE=0:GOSUB 4860:RETURN 
  445. 4600 DRIVE=1:GOSUB 4860:DRIVE=0:RETURN 
  446. 4610 DRIVE=2:GOSUB 4860:DRIVE=0:RETURN 
  447. 4620 '******* RETURN TO DOS ROUTINE ******* 
  448. 4630 CLS 
  449. 4640 SYSTEM 
  450. 4650 '********************** SUBROUTINES ********************** 
  451. 4660 ' 
  452. 4670 '********************************** 
  453. 4680 '*** Blinking Cursor Subroutine *** 
  454. 4690 '********************************** 
  455. 4700 T=POS(0):L=CSRLIN 
  456. 4710 LOCATE L,T,0:PRINT "?";:SOUND 32767,3:ANSWER$=INKEY$ 
  457. 4720 IF ANSWER$<>""THEN IF ANSWER$="*"THEN RETURN 720 ELSE RETURN 
  458. 4730 LOCATE L,T,0:PRINT CHR$(219);:SOUND 32767,3:ANSWER$=INKEY$ 
  459. 4740 IF ANSWER$<>""THEN IF ANSWER$="*"THEN RETURN 720 ELSE RETURN 
  460. 4750 GOTO 4710 
  461. 4760 ' ******************************** 
  462. 4770 ' *** Yes/No Answer Subroutine *** 
  463. 4780 ' ******************************** 
  464. 4790 GOSUB 4670:LOCATE L,T 
  465. 4800 IF ANSWER$="Y" OR ANSWER$="y" OR ANSWER$=CHR$(13) THEN 4830 
  466. 4810 IF ANSWER$="0" OR ANSWER$="n" OR ANSWER$="N" THEN 4840 
  467. 4820 SOUND 250,4:GOTO 4790 
  468. 4830 ANSWER$="Y":PRINT "? Yes":RETURN 
  469. 4840 ANSWER$="N":PRINT "? No":RETURN 
  470. 4850 ' 
  471. 4860 '******* SUBROUTINE TO DUMP DATA TO A SPECIFIC DISK ******** 
  472. 4870 'DRIVE=0 IF DRIVE "A" OR 1 IF DRIVE "B" or 2 if "C" 
  473. 4880 SCREEN ,,0,0:COLOR 31,4,4:CLS 
  474. 4890 LOCATE 12,14,0:PRINT"Saving Data to Disk....."; 
  475. 4900 IF DRIVE=0 THEN OPEN"O",1,"A:DIR.DAT":GOTO 4930 
  476. 4910 IF DRIVE=1 THEN OPEN"O",1,"B:DIR.DAT":GOTO 4930 
  477. 4920 OPEN"O",1,"C:DIR.DAT":GOTO 4930 
  478. 4930 FOR X=1 TO ENTRIES:IF A(X)="" THEN 4940 ELSE WRITE #1,A(X) 
  479. 4940 NEXT:CLOSE:RETURN 
  480. 4950 '******* SUBROUTINE TO DUMP DATA TO DEFAULT DISK ******** 
  481. 4960 SCREEN ,,0,0:COLOR 31,4,4:CLS 
  482. 4970 LOCATE 12,14,0:PRINT"Saving Data to Disk....."; 
  483. 4980 OPEN"O",1,"DIR.DAT" 
  484. 4990 FOR X=1 TO ENTRIES:IF A(X)="" THEN 5000 ELSE WRITE #1,A(X) 
  485. 5000 NEXT:CLOSE:RETURN 
  486. 5010 '***************************************************** 
  487. 5020 '*   SUBROUTINE TO SORT THE DATA ARRAY BY FILESPEC   * 
  488. 5030 '***************************************************** 
  489. 5040 PRINT"Sorting Data.........." 
  490. 5050 M=ENTRIES:N=M:C=0 
  491. 5060 M=INT(M/2):IF M=0 THEN SORTFLAG=FALSE:RETURN ELSE J=1:K=N-M 
  492. 5070 I=J 
  493. 5080 L=I+M:C=C+1 
  494. 5090 IF A(I)<A(L)THEN 5100 ELSE SWAP A(I),A(L):I=I-M:IF I<1 THEN 5100 ELSE 5080 
  495. 5100 J=J+1:IF J>K THEN 5060 ELSE 5070 
  496. 5110 '***************************************************** 
  497. 5120 '*   SUBROUTINE TO SORT THE DATA ARRAY BY DISK NO.   * 
  498. 5130 '***************************************************** 
  499. 5140 PRINT"Sorting Data.........." 
  500. 5150 FOR X=1 TO ENTRIES:A(X)=RIGHT$(A(X),3)+LEFT$(A(X),12):NEXT 
  501. 5160 GOSUB 5050 
  502. 5170 SORTFLAG=TRUE 
  503. 5180 FOR X=1 TO ENTRIES:A(X)=RIGHT$(A(X),12)+LEFT$(A(X),3):NEXT 
  504. 5190 RETURN 
  505. 5200 '********************************************** 
  506. 5210 '*   SUBROUTINE TO CAPITALIZE VARIABLE ACAP   * 
  507. 5220 '********************************************** 
  508. 5230 FOR XACAP=1 TO LEN(ACAP) 
  509. 5240 A1=MID$(ACAP,XACAP,1) 
  510. 5250 IF A1>="a" AND A1<="z" THEN MID$(ACAP,XACAP,1)=CHR$(ASC(A1)-32)
  511. 5260 NEXT:RETURN
  512. 5270 END ' of DIR2.BAS
  513.