home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / BASIC / QBS_0103 / QBS103-3.DOC < prev    next >
Text File  |  1993-04-30  |  41KB  |  1,365 lines
  1. ════════════════════════════════════════════════════════════════════════════════
  2.  Area:    QuickBasic
  3.   Msg:    #11117
  4.  Date:    03-17-93 08:48 (Public)
  5.  From:    JIM TANNER
  6.  To:      CASEY PEARSON
  7.  Subject: Layout problem (HELP!<g>)
  8. ────────────────────────────────────────────────────────────────────────────────
  9. CP> I need help with random access files.  (RAF)  Here is the layout:
  10. CP> Field                Columns                Type
  11.  
  12. { ----------------------------------------------------- }
  13.  
  14. TYPE TypeName                     {  Give it a name  }
  15.  StreetNumber        String * 6   {  6 bytes         }
  16.  StreetName          String * 12  {  12 bytes        }
  17.  StreetDirection     String * 2   {  2 bytes         }
  18.  StreetType          String * 6   {  6 bytes         }
  19.  City                String * 15  {  15 bytes        }
  20.  State               String * 2   {  2 bytes         }
  21.  ZipCode             String * 6   {  6 bytes         }
  22.  YTDHoursWorked      Interger     {  2 bytes         }
  23.  HourlyRate          Single       {  4 bytes         }
  24.  YTDGrossPay         Double       {  8 bytes         }
  25.  SocialSecurity      String * 9   {  9 bytes         }
  26.  KillFlag            Integer      {  2 bytes         }
  27.  Filler              String * 54  {  54 bytes (Makes record 128 bytes long.)
  28. END TYPE                          { ----             }
  29.                                   { 128 total bytes in each record. }
  30.  
  31. { I closed up the spaces in your field names.  Be sure to do }
  32. { this in your code as there can't be any spaces. }
  33.  
  34. { You may be able to get by with assigning "YTDGrossPay" as   }
  35. { "Single" rather than "Double"  You can save 4 bytes.  If you }
  36. { do, be sure to increase Filler to  String * 58  }
  37.  
  38. { Also you may want to increase SocialSecurity to String * 11 to allow }
  39. { for the dashes as in "###-##-####"  }
  40. { If so you'll need to decrease the number (54) in Filler  }
  41. { by 2                                                     }
  42.  
  43. { *** See note below regarding "KillFlag" and "Filler" *** }
  44.  
  45. DIM NameType AS TypeName          { DIMension the Record  }
  46.                                   { NameType is 1 Record  }
  47.  
  48. FileNum% = FREEFILE               { Get next available file number }
  49.  
  50. OPEN "FILENAME.EXT" FOR RANDOM AS #FileNum% LEN = LEN(NameType)
  51.  
  52. { This opens the file for Read/Write     }
  53. { Change "FILENAME.EXT" to whatever      }
  54. { you want to call the file that will    }
  55. { be written to disk as a permanent      }
  56. { file.                                  }
  57.  
  58.  
  59. { Now find out how many records are in the   }
  60. { file and assign the next available number  }
  61. { to the new record about to be created.     }
  62.  
  63.  
  64. NumRecords% = LOF(FileNum%) \ LEN(NameType)
  65.  
  66. IF NumRecords% <> 0 THEN           { The file does have records in it. }
  67.    RecordNum% = NumRecords% + 1    { Assign next available number. }
  68. ELSE                               { No records yet.     }
  69.    RecordNum% = 1                  { So first record is number 1.  }
  70. ENDIF
  71.  
  72. { Gets number of records based on the length of file (LOF) divided by
  73. { the LENgth of the record (NameType).
  74. { If there's no records in the file then the length will be 0 and NumRecords%
  75. { will be 0 and the next available RecordNum% would be 1.
  76. { If the LOF of FileNum% was 1024 there would be 8 records in the file.
  77. { and NumRecords% would be 8 and the next available RecordNum% would be 9.
  78. { This is based on 1024 (LOF of FileNum% divided by LENgth of NameType [the
  79. { length {128 bytes} of each Record]). }
  80.  
  81. { You can also setup an Index routine to keep up with the }
  82. { Record numbers (RecordNum%) if you need to.             }
  83.  
  84.  
  85. { Now get some info to put in a new record.  }
  86.  
  87. COLOR 7, 0
  88. CLS
  89. LOCATE 2, 5
  90. INPUT "Enter Street number: "; NameType.StreetNumber
  91. INPUT "Enter Street name: "; NameType.StreetName
  92. INPUT "Enter Street direction: "; NameType.StreetDirection
  93. .
  94. .
  95. NameType.KillFlag = 1
  96. NameType.Filler = "AaBbCcDdEeFf... and so on for 54 characters"
  97.  
  98.  
  99. { *** See note below regarding "KillFlag" and "Filler" *** }
  100.  
  101.  
  102. { Now that the user has entered some info and the  "KillFlag" and   }
  103. { "Filler" data have been specified, you're ready to put it into the }
  104. { file as a record and write it to disk. }
  105.  
  106. PUT #FileNum%, RecordNum%, NameType  { Puts info in file as a record. }
  107.  
  108. { Use either of the 2 lines below. }
  109.  
  110. CLOSE #FileNum%    { Close the file opened as FileNum% }
  111. CLOSE              { Closes any/all open files }
  112.  
  113. { ------------------------------------------------------- }
  114.  
  115. *** NOTE ***
  116.  
  117.  
  118. Notice I added 2 items to your list.  The first is KillFlag. I use this in
  119. all my Random access files in case I want to delete that record at some point
  120. later.  I set the KillFlag to 1 when the record is first created then if I
  121. want to remove that record, set it to 2 and use a routine to remove the
  122. record if KillFlag for that record number is <> 1   Note also that when a
  123. record is removed/deleted using this method it's lost and gone forever.  I
  124. use a "DO/ LOOP" and "IF/ENDIF" routine to delete individual records from
  125. Random access files.
  126.  
  127. Also the Filler is a string of text that can be anything you want.  It makes
  128. each record exactly 128 bytes long which is supposed to increase the speed or
  129. something.  I usually put in a copyright notice or something in the Filler
  130. field. This will also provide some space in the record in case you want to go
  131. in later and revise your code to add more fields.
  132.  
  133. I used "TypeName" and "NameType" as examples only.  You can call 'em anything
  134. you want.  I try to be as descriptive as possible with these names as it
  135. saves some additional commenting and makes the code more understandable when
  136. you go back to it a year or so later (or the next Monday morning).
  137.  
  138. This may not be the *only* way to do this but it's what I use and it works.
  139. YMMV (Your Mileage May Vary).
  140.  
  141. This is off the top of my head but should be close.
  142.  
  143. Now you may REALLY be confused.
  144.  
  145. Hope it helps...
  146.  
  147. Jim...
  148.  
  149. --- GEcho 1.00/beta+
  150.  * Origin: RiverBend | Home of GolfLog | HST DS 16800 | (1:19/99)
  151.  
  152.  
  153.  
  154. ════════════════════════════════════════════════════════════════════════════════
  155.  Area:    QuickBasic
  156.   Msg:    #12544
  157.  Date:    03-17-93 15:49 (Public)
  158.  From:    ROBERT CHURCH
  159.  To:      ALL
  160.  Subject: DOS Date and Time stamps
  161. ────────────────────────────────────────────────────────────────────────────────
  162. Thanks to all of you for reading my question, but I've found my own solution.
  163. <Grin>  This turned out to be one of those things that's easier in assembly
  164. and PowerBASIC 3.0's inline asm made it even easier.  Here's my solition. I'm
  165. also sending all of my DOS file routines for PB:
  166.  
  167. 'QBS=YES!!!
  168.  
  169. 'Start of .BI file
  170.  
  171. TYPE DTAType
  172.     Stff  AS STRING * 21
  173.     Attr  AS BYTE
  174.     FTime AS WORD
  175.     FDate AS WORD
  176.     Size  AS DWORD
  177.     FileN AS STRING * 13
  178. END TYPE
  179.  
  180. DECLARE SUB SetDTA(DTA AS DTAType)
  181. DECLARE SUB PrintDTA (D AS DTAType)
  182. DECLARE SUB CvtDOSDate (BYVAL DosDate AS WORD, Month AS WORD, Day AS WORD,_
  183. Year AS WORD)
  184. DECLARE SUB DPrint (BYVAL PrintMe AS STRING, BYVAL CRLF AS WORD)
  185. DECLARE FUNCTION FindFirst? (FileN AS STRING, DTA AS DTAType, Attr AS WORD)
  186. DECLARE FUNCTION FindNext?  (DTA AS DTAType)
  187.  
  188. 'Start of .BAS FILE
  189.  
  190. 'Configure the compiler here.
  191. $COM 0
  192. $COMPILE UNIT "FILE.PBU"
  193. $CPU 8086
  194. $DEBUG UNIT OFF
  195. $DIM ALL
  196. $STATIC
  197. $ERROR ALL OFF
  198. $EVENT OFF
  199. $FLOAT PROCEDURE
  200. $LIB COM OFF, LPT OFF, GRAPH OFF, FULLFLOAT OFF, IPRINT OFF
  201. $OPTIMIZE SIZE
  202. $OPTION CNTLBREAK OFF, GOSUB OFF
  203. $SOUND 0
  204. $STACK &H600
  205.  
  206. $INCLUDE "FILE.BI"
  207.  
  208. DECLARE SUB SetDTA(DTA AS DTAType)
  209. DECLARE SUB CvtDOSDate (BYVAL DosDate AS WORD, Month AS WORD, Day AS WORD,_
  210.     Year AS WORD)
  211. DECLARE FUNCTION FindFirst? (FileN AS STRING, DTA AS DTAType, Attr AS WORD)
  212. DECLARE FUNCTION FindNext?  (DTA AS DTAType)
  213.  
  214. DEFWRD A-Z
  215.  
  216.  
  217. SUB DPrint (BYVAL PrintMe AS STRING, BYVAL CRLF AS WORD) STATIC PUBLIC
  218.  
  219.     'Add a CR if CRLF is true
  220.     IF ISTRUE(CRLF) THEN PrintMe = PrintMe + CHR$(13) + CHR$(10)
  221.  
  222.     PrintMe = PrintMe + "$"  'append a $ for DOS
  223.  
  224.     REG 1, &H0900
  225.     REG 4, StrPtr(PrintMe)
  226.     REG 8, StrSeg(PrintMe)
  227.     CALL INTERRUPT &H21
  228.  
  229. END SUB
  230.  
  231. FUNCTION FindFirst? (Spec AS STRING, DTA AS DTAType, Attr AS WORD) STATIC_
  232.     PUBLIC
  233.  
  234.     DIM Flags AS BYTE
  235.  
  236.     DTA.FileN = ""
  237.     REG 4, VARPTR (DTA)     'Set the new DTA
  238.     REG 8, VARSEG (DTA)
  239.     REG 1, &H1A00
  240.     CALL INTERRUPT &H21
  241.  
  242.     Spec = Spec + CHR$(0)   'DOS wants a NULL
  243.     REG 1, &H4E00           'FindFirst
  244.     REG 3, Attr             'set the attribute
  245.     REG 4, StrPtr(Spec)
  246.     REG 8, StrSeg(Spec)
  247.  
  248.     CALL INTERRUPT &H21
  249.  
  250.     Flags = REG(0) AND 1    'Return NOT carry flag
  251.     IF Flags THEN FindFirst?? = 0 ELSE FindFirst?? = 1
  252.  
  253. END FUNCTION
  254.  
  255. ' More next page!
  256.  
  257. --- FMail 0.90
  258.  * Origin: -= Floating Point =- Hillsboro, Oregon (1:105/330.3)
  259.  
  260.  
  261.  
  262. ════════════════════════════════════════════════════════════════════════════════
  263.  Area:    QuickBasic
  264.   Msg:    #12545
  265.  Date:    03-17-93 15:51 (Public)
  266.  From:    ROBERT CHURCH
  267.  To:      ALL
  268.  Subject: DOS Date and Time Stamps
  269. ────────────────────────────────────────────────────────────────────────────────
  270. FUNCTION FindNext? (DTA AS DTAType) STATIC PUBLIC
  271.  
  272.     DIM Flags AS BYTE
  273.  
  274.     DTA.FileN = ""
  275.     REG 4, VARPTR (DTA)     'Set the new DTA
  276.     REG 8, VARSEG (DTA)
  277.     REG 1, &H1A00
  278.     CALL INTERRUPT &H21
  279.  
  280.     REG 1, &H4F00           'FindNext
  281.  
  282.     CALL INTERRUPT &H21
  283.  
  284.     Flags = REG(0) AND 1    'Get the carry flag, NOT it and return
  285.     IF Flags THEN FindNext?? = 0 ELSE FindNext?? = 1
  286.  
  287. END FUNCTION
  288.  
  289.  
  290. SUB CvtDOSDate (BYVAL DosDate AS WORD, Month AS WORD, Day AS WORD,
  291.     _Year AS WORD) STATIC PUBLIC
  292.  
  293.     ASM   Mov   ax, DosDate  ; process month
  294.     ASM   Push  ax
  295.     ASM   Mov   cl, 5        ; shift right 5 bits
  296.     ASM   Shr   ax, cl
  297.     ASM   And   ax, &H0F     ; and the result with 16
  298.     ASM   Cbw
  299.     ASM   Les   bx, Month    ; get Month's address in ES:BX
  300.     ASM   Mov   es:[bx], ax  ; move the month into Month
  301.     ASM   ; Start on Day
  302.     ASM   Pop   ax           ; get a new copy of DosDate
  303.     ASM   Push  ax           ; save it for Year
  304.     ASM   And   ax, &H1F     ; and it with 32
  305.     ASM   Cbw
  306.     ASM   Les   bx, Day      ; get Day's address in ES:BX
  307.     ASM   Mov   es:[bx], ax  ; move the day into Day
  308.     ASM   ; Year
  309.     ASM   Pop   ax           ; get a new copy of DosDate
  310.     ASM   Mov   cl, 9        ; shift right 9 bits
  311.     ASM   Shr   ax, cl
  312.     ASM   And   ax, &H1F      ; and it with 32
  313.     ASM   Add   ax, 80       ; add 80, Gates thought it would be smart
  314.     ASM                      ; to save this as years since 1980
  315.     ASM   Cbw
  316.     ASM   Les   bx, Year     ; get Year's address in ES:BX
  317.     ASM   Mov   es:[bx], ax  ; move the year into Year
  318.  
  319. END SUB
  320.  
  321.  
  322. SUB SetDTA(DTA AS DTAType) STATIC PUBLIC
  323.  
  324.  
  325. 'INT 21 - DOS 1+ - SET DISK TRANSFER AREA ADDRESS
  326. '        AH = 1Ah
  327. '        DS:DX -> Disk Transfer Area (DTA)
  328.  
  329.  
  330.     i = REG(8)
  331.     REG 1, &H1A00
  332.     REG 8, VARSEG (DTA)
  333.     REG 4, VARPTR (DTA)
  334.  
  335.     CALL INTERRUPT &H21
  336.  
  337.     REG 8, i
  338.  
  339. END SUB
  340.  
  341.  
  342. FUNCTION GetDTA??? STATIC
  343.  
  344. 'INT 21 - DOS 2+ - GET DISK TRANSFER AREA ADDRESS
  345. '        AH = 2Fh
  346. 'Return: ES:BX -> current DTA
  347.  
  348. asm   mov   ah, &H2F
  349. asm   int   &H21
  350.  
  351.     GetDTA??? = REG(9) + (65536 * REG(2)) + 1
  352.  
  353. END FUNCTION
  354.  
  355.  
  356. >-= Rob =-<
  357.  
  358. --- FMail 0.90
  359.  * Origin: -= Floating Point =- Hillsboro, Oregon (1:105/330.3)
  360.  
  361.  
  362.  
  363. ════════════════════════════════════════════════════════════════════════════════
  364.  Area:    Net Mail
  365.   Msg:    #13782
  366.  Date:    03-18-93 19:47 (Private)
  367.  From:    JEFF FREEMAN
  368.  To:      LEE MADAJCZYK
  369.  Subject: @1:124/7006
  370. ────────────────────────────────────────────────────────────────────────────────
  371. Subj: Top Twenty
  372.  >    Do you think you could repost your "Top Twenty Posters"
  373.  >    list? I missed it (My host went to a new version of RA
  374.  
  375. No sweat!
  376.  
  377. ---
  378.  
  379. The votes are in for "Person least likely to have a life" and these are
  380. the results:
  381.  
  382. ("Sort /R /+50" the list of persons, chopped out everything but this)
  383.  
  384. ###     --Name--                From         Posts
  385.  1   Jones      Zack           1:387/641      352
  386.  2   Jackson    Quinn Tyler    1:153/918      211
  387.  3   Yiu        Victor         1:106/30       166
  388.  4   Coates     Dik            1:229/110      153
  389.  5   Butler     Mark           1:105/319.32   113
  390.  6   McKee      Rob            1:125/411      108
  391.  7   Gallas     John           1:282/7        107
  392.  8   Henshaw    Coridon        1:250/820      106
  393.  9   Pearson    Casey          1:159/100       95
  394. 10   French     Calvin         1:134/75        95
  395. 11   Pedley     Rick           1:249/140       86
  396. 12   Harris     Mark           1:121/8         71
  397. 13   Roberts    Matt           1:325/602       69
  398. 14   Tracy      Chris          1:2615/4        68
  399. 15   Montgomery Earl           1:124/4210      63
  400. 16   Madajczyk  Lee            1:280/5         54
  401. 17   Mayo       Walt           1:3627/101      52
  402. 18   Martin     Hugh           1:128/13        51
  403. 19   Church     Robert         1:105/330.3     50
  404. 20   Ford       Eric B.        1:3632/1.6      49
  405.  
  406. Hasta
  407.  
  408. ---
  409.  * Origin: WarWorld's point away from home... (1:124/7006.1)
  410.  
  411.  
  412. ════════════════════════════════════════════════════════════════════════════════
  413.  Area:    QuickBasic
  414.   Msg:    #13227
  415.  Date:    03-14-93 18:15 (Public)
  416.  From:    CORIDON HENSHAW
  417.  To:      ALL
  418.  Subject: New PostIt! like encoder
  419. ────────────────────────────────────────────────────────────────────────────────
  420. Here's a little project that I've been working on....  A PostIt! replacemnt.
  421. It generates files SMALLER than PostIt!, if you remove PostIt!'s compression.
  422.  
  423. --- --- --- Cut Here --- --- ---
  424. '>>> Start of page 1.
  425.  
  426. DECLARE FUNCTION StripName$ (InFile$)
  427. DECLARE SUB ChangeAttrs (X%, Y%, Attr%, Length%)
  428. DECLARE SUB DrawBox (Row1%, Col1%, Row2%, Col2%, ShadowBack%,_
  429.  ShadowFore%, WindowBack%, WindowFore%, BoarderBack%, BoarderFore%,_
  430.  Shadow%, Boarder%)
  431. DECLARE SUB DecodeFile (InFile$)
  432. DECLARE SUB DecodeShiftTable (ShiftTable AS STRING, NumBlocks AS LONG)
  433. DECLARE FUNCTION GetBlock% (InH%, Char() AS STRING * 1)
  434. DECLARE FUNCTION EncodeBlock$ (Block() AS STRING * 1, Block%)
  435. DECLARE SUB EncodeFile (InFile$, OutFile$)
  436.  
  437. '$STATIC
  438. DIM SHARED GlobalUpShift(1 TO 16384) AS INTEGER
  439. '$DYNAMIC
  440. CONST Header = "=====BEGIN BT7 SCRIPT====="
  441. CONST Footer = "=====END BT7 SCRIPT====="
  442.  
  443. COLOR 11
  444. CLS
  445.  
  446. PRINT "(D)ecode or (E)ncode: ( )";
  447. DO
  448.         IKey$ = UCASE$(INKEY$)
  449. LOOP UNTIL IKey$ = "D" OR IKey$ = "E"
  450.  
  451. LOCATE , POS(0) - 2
  452. PRINT IKey$
  453.  
  454. LINE INPUT "Input file: ", InFile$
  455. IF DIR$(InFile$) = "" THEN
  456.         PRINT "File not found."
  457.         END
  458. END IF
  459.  
  460. IF IKey$ = "D" THEN
  461.         DecodeFile InFile$
  462. ELSE
  463.         LINE INPUT "Output file: ", OutFile$
  464.         IF DIR$(OutFile$) <> "" THEN
  465.                 PRINT "File already exists."
  466.                 END
  467.         END IF
  468.  
  469.         EncodeFile InFile$, OutFile$
  470. END IF
  471.  
  472. REM $STATIC
  473.  
  474. DEFINT A-Z
  475. SUB ChangeAttrs (X, Y, Attr, Length)
  476. DIM Offset AS LONG
  477. DIM Count AS LONG
  478.  
  479. DEF SEG = &HB800
  480. Offset = (X * 160) + Y
  481. FOR Count = 1 TO Length
  482.         POKE Offset, Attr
  483.         Offset = Offset + 2
  484. NEXT
  485.  
  486. END SUB
  487.  
  488. SUB DecodeFile (InFile$)
  489.  
  490. DIM Char(1 TO 6) AS STRING * 1
  491. DIM InBuffer AS STRING
  492. DIM ShiftTable AS STRING
  493. DIM ScriptBuffer(1 TO 1801)     AS STRING
  494. DrawBox 2, 2, 22, 78, 0, 7, 7, 14, 7, 14, 2, 1
  495.  
  496. COLOR 0, 7
  497. LOCATE 3, 3
  498. PRINT "Files                              Decoding";
  499. LOCATE 4, 3
  500. PRINT "│  Input File:                     │    Line:";
  501. LOCATE 5, 3
  502. PRINT "│  └ Size:                         │   Block:";
  503. LOCATE 6, 3
  504. PRINT "│ Output File:                     │    Byte:";
  505. LOCATE 7, 3
  506. PRINT "└ └ Size:                          └ Percent:";
  507. LOCATE 9, 3
  508. PRINT "Reading header";
  509. LOCATE 11, 3
  510. PRINT "Reading shifttable";
  511. LOCATE 13, 3
  512. PRINT "Reading data";
  513. LOCATE 14, 3
  514. PRINT "└ Line:";
  515. LOCATE 16, 3
  516. PRINT "Decoding shifttable";
  517. LOCATE 17, 3
  518.  
  519. --- GEcho 1.00
  520.  * Origin: TCS Concordia - Mail Only - Toronto, Ontario (1:250/820)
  521.  
  522.  
  523.  
  524. ════════════════════════════════════════════════════════════════════════════════
  525.  Area:    QuickBasic
  526.   Msg:    #13228
  527.  Date:    03-14-93 18:16 (Public)
  528.  From:    CORIDON HENSHAW
  529.  To:      ALL
  530.  Subject: New PostIt! like encoder
  531. ────────────────────────────────────────────────────────────────────────────────
  532.                         IF Upshift AND 2 ^ (Y - 1) THEN
  533.                                 Char(Y) = CHR$(ASC(Char(Y)) - 34)
  534.                         END IF
  535.                         IF HighBit AND 2 ^ (Y - 1) THEN
  536.                                 Char(Y) = CHR$(ASC(Char(Y)) + 2 ^ 7)
  537.                         END IF
  538.                         PUT #OutH, , Char(Y)
  539.                         Ch& = Ch& + 1
  540.                         IF Ch& = FileSize& THEN EXIT DO
  541.  
  542.                         LOCATE 4, 48
  543.                         PRINT Lines;
  544.                         LOCATE 5, 48
  545.                         PRINT BlockCount&
  546.                         LOCATE 6, 48
  547.                         PRINT Ch&;
  548.                         LOCATE 7, 48
  549.                         PRINT INT(Ch& / FileSize& * 100)
  550.  
  551.                 NEXT
  552.         NEXT
  553.         Block$ = ""
  554.         HighBit = 0
  555.         Upshift = 0
  556.  
  557. LOOP UNTIL ExitFlag = 1
  558.  
  559. LOCATE 4, 48
  560. PRINT Lines;
  561. LOCATE 5, 48
  562. PRINT BlockCount&
  563. LOCATE 6, 48
  564. PRINT Ch&;
  565. LOCATE 7, 48
  566. PRINT INT(Ch& / FileSize& * 100)
  567.  
  568. LOCATE 7, 13
  569. PRINT LOF(OutH);
  570.  
  571. CLOSE #InH, #OutH
  572.  
  573. END SUB
  574.  
  575. SUB DecodeShiftTable (ShiftTable AS STRING, NumBlocks AS LONG)
  576.  
  577. DIM X AS LONG
  578.  
  579. ERASE GlobalUpShift
  580. Y = 1
  581.  
  582. FOR X = 1 TO 16384
  583.         ShiftByte = ASC(MID$(ShiftTable, Y, 1)) - 34 + 1
  584.         IF ShiftByte AND 2 ^ Bit THEN
  585.  
  586.                 GlobalUpShift(X) = 1
  587.         END IF
  588.         Bit = Bit + 1
  589.         IF Bit = 1 THEN Bit = 2
  590.         IF Bit = 5 THEN Bit = 6
  591.         IF Bit = 7 THEN
  592.                 Bit = 0
  593.                 Y = Y + 1
  594.                 IF Y >= NumBlocks THEN EXIT FOR
  595.         END IF
  596.         LOCATE 17, 13
  597.         PRINT X;
  598.         LOCATE 18, 13
  599.         PRINT Y;
  600.         LOCATE 19, 13
  601.         PRINT INT(Y / NumBlocks * 100);
  602. NEXT
  603. LOCATE 17, 13
  604. PRINT X;
  605. LOCATE 18, 13
  606. PRINT Y;
  607. LOCATE 19, 13
  608. PRINT INT(Y / NumBlocks * 100);
  609. END SUB
  610.  
  611. SUB DrawBox (Row1, Col1, Row2, Col2, ShadowBack, ShadowFore,_
  612.  WindowBack, WindowFore, BoarderBack, BoarderFore, Shadow, Boarder)
  613. SELECT CASE Boarder
  614.         CASE 1
  615.                 HorizLine$ = "─" '196
  616.                 VertLine$ = "│"  '179
  617.                 LTCorner$ = "┌"  '218
  618.                 LBCorner$ = "└"  '192
  619.                 RTCorner$ = "┐"  '191
  620.                 RBCorner$ = "┘"  '217
  621.         CASE 2
  622.                 HorizLine$ = "═" '205
  623.                 VertLine$ = "║"  '186
  624.                 LTCorner$ = "╔"  '201
  625.                 LBCorner$ = "╚"  '200
  626.                 RTCorner$ = "╗"  '187
  627.                 RBCorner$ = "╝"  '188
  628.         CASE 3
  629.                 HorizLine$ = "-"
  630.  
  631. --- GEcho 1.00
  632.  * Origin: TCS Concordia - Mail Only - Toronto, Ontario (1:250/820)
  633.  
  634.  
  635.  
  636. ════════════════════════════════════════════════════════════════════════════════
  637.  Area:    QuickBasic
  638.   Msg:    #13229
  639.  Date:    03-14-93 18:17 (Public)
  640.  From:    CORIDON HENSHAW
  641.  To:      ALL
  642.  Subject: New PostIt! like encoder
  643. ────────────────────────────────────────────────────────────────────────────────
  644. END FUNCTION
  645.  
  646. SUB EncodeFile (InFile$, OutFile$)
  647.  
  648. DIM Char(1 TO 6)                AS STRING * 1
  649. DIM OutBuffer                   AS STRING
  650. DIM ScriptBuffer(1 TO 1801)     AS STRING
  651. DIM ShiftBuffer(1 TO 39)        AS STRING
  652.  
  653. DrawBox 2, 2, 22, 78, 0, 7, 7, 14, 7, 14, 1, 1
  654.  
  655. COLOR 0, 7
  656.  
  657. LOCATE 4, 3
  658. PRINT "File status                         Writing header";
  659. LOCATE 5, 3
  660. PRINT "│  Input File:";
  661. LOCATE 6, 3
  662. PRINT "│  └ Size:                          Writing shifttable";
  663. LOCATE 7, 3
  664. PRINT "│ Output File:                      └ Line:";
  665. LOCATE 8, 3
  666. PRINT "└ └ Size:"
  667.  
  668. LOCATE 9, 3
  669. PRINT "                                    Writing script"
  670.  
  671. LOCATE 10, 3
  672. PRINT "Encoding                            └ Line:";
  673. LOCATE 11, 3
  674. PRINT "│    Line:";
  675. LOCATE 12, 3
  676. PRINT "│   Block:";
  677. LOCATE 13, 3
  678. PRINT "│    Byte:";
  679. LOCATE 14, 3
  680. PRINT "└ Percent:"
  681.  
  682. LOCATE 16, 3
  683. PRINT "Creating shifttable";
  684. LOCATE 17, 3
  685. PRINT "│    Line:";
  686. LOCATE 18, 3
  687. PRINT "│   Block:";
  688. LOCATE 19, 3
  689. PRINT "│    Byte:";
  690. LOCATE 20, 3
  691. PRINT "└ Percent:";
  692.  
  693. InH = FREEFILE
  694. OPEN InFile$ FOR BINARY AS #InH
  695. OutH = FREEFILE
  696. OPEN OutFile$ FOR OUTPUT AS #OutH
  697.  
  698.  
  699. FOR X = 3 TO 7
  700.         ChangeAttrs X, 3, &H7E, 15
  701. NEXT
  702.  
  703. COLOR 14, 7
  704.  
  705. LOCATE 5, 18
  706. PRINT StripName$(InFile$);
  707. LOCATE 6, 13
  708. PRINT LOF(InH)
  709. LOCATE 7, 18
  710. PRINT StripName$(OutFile$);
  711. LOCATE 8, 12
  712. PRINT LOF(OutH)
  713.  
  714. FOR X = 8 TO 13
  715.         ChangeAttrs X, 3, &H7E, 15
  716. NEXT
  717.  
  718. X = 0
  719. DO
  720.         X = X + 1
  721.         Vx = Vx + 1
  722.  
  723.         BytesLeft = GetBlock(InH, Char())
  724.         OutBuffer = OutBuffer + EncodeBlock(Char(), X)
  725.  
  726.         IF Vx = 9 THEN
  727.                 Lines = Lines + 1
  728.                 ScriptBuffer(Lines) = OutBuffer
  729.                 OutBuffer = ""
  730.                 Vx = 0
  731.  
  732.         END IF
  733.         FLoc = LOC(InH)
  734.  
  735.         LOCATE 11, 13
  736.         PRINT Lines;
  737.         LOCATE 12, 13
  738.         PRINT X;
  739.         LOCATE 13, 13
  740.         PRINT FLoc;
  741.  
  742. --- GEcho 1.00
  743.  * Origin: TCS Concordia - Mail Only - Toronto, Ontario (1:250/820)
  744.  
  745.  
  746.  
  747. ════════════════════════════════════════════════════════════════════════════════
  748.  Area:    QuickBasic
  749.   Msg:    #13230
  750.  Date:    03-14-93 18:18 (Public)
  751.  From:    CORIDON HENSHAW
  752.  To:      ALL
  753.  Subject: New PostIt! like encoder
  754. ────────────────────────────────────────────────────────────────────────────────
  755. CLOSE #OutH, InH
  756.  
  757. END SUB
  758.  
  759. FUNCTION GetBlock (InH, Char() AS STRING * 1)
  760.  
  761. BytesLeft = LOF(InH) - LOC(InH)
  762.  
  763. FOR X = 1 TO 6
  764.         Char(X) = ""
  765. NEXT
  766.  
  767. IF BytesLeft >= 6 THEN
  768.         FOR X = 1 TO 6
  769.                 GET #InH, , Char(X)
  770.         NEXT
  771. ELSE
  772.         FOR X = 1 TO BytesLeft
  773.                 GET #InH, , Char(X)
  774.         NEXT
  775.         BytesLeft = LOF(InH) - LOC(InH)
  776.         IF BytesLeft <= 6 AND BytesLeft >= 1 THEN
  777.                 FOR X = BytesLeft TO 6
  778.                         Char(X) = CHR$(0)
  779.                 NEXT
  780.         END IF
  781. END IF
  782.  
  783. GetBlock = BytesLeft
  784.  
  785. END FUNCTION
  786.  
  787. FUNCTION StripName$ (InFile$)
  788. FOR Y = LEN(InFile$) TO 1 STEP -1
  789.         IF MID$(InFile$, Y, 1) = "\" THEN
  790.                 StripName$ = UCASE$(MID$(InFile$, Y + 1))
  791.                 Flag = 1
  792.                 EXIT FOR
  793.         END IF
  794. NEXT
  795. IF Flag <> 1 THEN
  796.         StripName$ = UCASE$(InFile$)
  797. END IF
  798. END FUNCTION
  799. --- --- --- Cut Here --- --- ---
  800.  
  801. The next version will have more advanced features, and error-checking.  It'll
  802. be hatched through PDNBASIC because of it's size.
  803.  
  804. --- GEcho 1.00
  805.  * Origin: TCS Concordia - Mail Only - Toronto, Ontario (1:250/820)
  806.  
  807.  
  808.  
  809. ════════════════════════════════════════════════════════════════════════════════
  810.  Area:    QuickBasic
  811.   Msg:    #13237
  812.  Date:    03-17-93 12:45 (Public)
  813.  From:    CORIDON HENSHAW
  814.  To:      VICTOR YIU
  815.  Subject: Looking for crc32 code
  816. ────────────────────────────────────────────────────────────────────────────────
  817. Hello Victor!
  818.  
  819. Saturday March 13 1993, Victor Yiu writes to Coridon Henshaw:
  820.  
  821.  CH>> ===BEGIN: CRC32.UUE===
  822.  CH>> begin 644 CRC32.OBJ
  823.  
  824.  VY> Either I don't have a UUE code decoder or don't know how to extract the
  825.  VY> file.
  826.  
  827. Remember that encoder/decoder that I posted a few days ago?  Here's a script
  828. for it.  The script is a UUdecoder, a simple one, mind you, but it works.
  829.  
  830. =====BEGIN BT7 SCRIPT=====
  831. UUD20.COM,705,23
  832. !!!!!!911%i%~*b!aia~n1-
  833. h*!Sgh$CrAOqnf!Aq`lAQd!Gpthqdr!?ACNRAU!Pdqrhnm!?A1-/An!PqAghfg!Adq-.+#!W
  834. .+Hmot!BsAo`sg!A.ehkd9!?AHmots!@AehkdA!`dqqnq-!?.+Ntso!BtsAehk!CdAdqqn!A
  835. q-.+Dm!KcAmnsA!aentmc-!?.+O`cc!BhmfAsq!Gtmb`sd!?cAkhmd!A.+MnA`!Rbshnm.!_
  836. +#o%!!!x!!!!!!!~=!!>o%,e{++?s0,c3A+9Cu6Az9Cu%)$1+jw3/L.!B;#r-9AT$"3*LB5j
  837. 7"KLB"(1~o%v>9BS5"84!:#;#!3?LB5b,V8'!2(PZ3>LB$,ow$n#9o8I%:yv&9#29"jG7!>b
  838. <)&LBr+U$h.""%5."gg"gC1(!>`%,<3Hadts,<9?fhtm,<9?mAtg+99ACsz+9C,!tz+9Cs7?
  839. z+?s$)$3js9`%2(OH).3;L*'Br$h>")t"'">2%,sg]!g5!:cq@:AA8#9#'++_+;,+O*BQc:"
  840. O`Qg+C.1)+a++O>3*BQcOh=!Qg+C)+:#a+*B+L:1Qc+C)$:#')"$!-3\@$$vCj0'6g6!,<4K
  841. dmt&+;1Gcs$gv!9cg@!3KL*'B*=+",)25#">@$;c,^8'!2(P?r*,z2@GH+Lt+O$OPgy!g@1'
  842. !XW;_t!@%/Aj);+T.s<;+s!T:)}@!x=2OtY+Lt-?&Og|!W%P;+trj:7#EL*5#"5c,=+"=@4*
  843. $B1c++;`?s6+A+"o?s0C@$:g$?$?:$;d!urs%}%2?1cH:@$!u9,^,};7$x2*G/5&Ar),z9=*
  844. !"89!g$<^!wBxB;#,/)",H$<s@92%F#;')"!!,C|?'"3?L)&Br)9[")d85!j)*(%7+"B9o;D
  845. %,q8!o-4,?%"3>6JLBq.,?BYt'g5!h#;>~,gB9=&H"84!O%Yg+!Wh-2e~9o"814g!:#!3?3L
  846. LBBAAA&y
  847. =====END BT7 SCRIPT=====
  848.  
  849. Don't remove the "=====BEGIN"... or "=====END"... lines.  This encoder saved
  850. 600 bytes over PostIt 5.1.
  851.  
  852. --- GEcho 1.00
  853.  * Origin: TCS Concordia - Mail Only - Toronto, Ontario (1:250/820)
  854.  
  855.  
  856.  
  857. ════════════════════════════════════════════════════════════════════════════════
  858.  Area:    QuickBasic
  859.   Msg:    #13362
  860.  Date:    03-18-93 08:32 (Public)
  861.  From:    DOUGLAS LUSHER
  862.  To:      EARL MONTGOMERY
  863.  Subject: INTERRUPT HELP
  864. ────────────────────────────────────────────────────────────────────────────────
  865. EM>MSGID: 1:124/6108.0 2ba53248
  866. EM>Just when I thought I was getting the hang of interrupts I run
  867. EM>across a new one that is giving me fits. It is Get the current
  868. EM>Directory (&H21 function 47H).
  869.  
  870. Earl: here's the implementation of that I use. Be sure to load QB with
  871. the /L switch.
  872.  
  873. DIM SHARED XRegister AS RegTypeX
  874.  'you need the Xtra registers for this one
  875.  
  876. CurDrive$ = "C:"
  877. PRINT DefaultDirectory$(CurDrive$)
  878. END
  879. '*******************************************
  880.  
  881.  
  882. FUNCTION DefaultDirectory$ (Drive$)
  883.  
  884. DefaultDirectory$ = ""
  885. XRegister.AX = &H4700
  886. XRegister.DX = 0
  887. IF LEN(Drive$) THEN XRegister.DX = (ASC(Drive$) OR 32) - 96
  888.  'if a drive string is passed, convert it to lower case by ASC() OR 32
  889.  'and then subtract 96 to get the zero-based system DOS uses
  890. Temp$ = SPACE$(64)
  891.  'set up a buffer to hold the output of the interrupt
  892. XRegister.DS = VARSEG(Temp$)
  893. XRegister.SI = SADD(Temp$)
  894.  'these registers must point to the buffer, the segment goes into DS
  895.  'and the offset into SI
  896. CALL InterruptX(&H21, XRegister, XRegister)
  897. IF (XRegister.Flags AND 1) = 0 THEN
  898.  'if the carry flag is clear, then no errors encountered
  899.   DefaultDirectory$ = LEFT$(Temp$, INSTR(Temp$, CHR$(0)) - 1)
  900.  'the info you want is now in the buffer you provided and it has a
  901.  'null byte - CHR$(0) - at the end of it. So find that null in the
  902.  'buffer using INSTR and subtract 1 to get the number of characters
  903.  'in the buffer that you want to keep. Then grab those characters
  904.  'using LEFT$()
  905. END IF
  906.  
  907. END FUNCTION
  908.  
  909. Hope this helps!
  910. ---
  911.  ■ SLMR 2.1a ■ Objectivity is in the eye of the beholder.
  912.  
  913. --- TMail v1.30.4
  914.  * Origin: TC-AMS MLTBBS 2.2 - Minnetonka, MN (612)-938-4799 (1:282/7)
  915.  
  916.  
  917.  
  918. ════════════════════════════════════════════════════════════════════════════════
  919.  Area:    QuickBasic
  920.   Msg:    #3313
  921.  Date:    03-18-93 14:31 (Public)
  922.  From:    DICK DENNISON
  923.  To:      ROBERT CHURCH
  924.  Subject: DOS Date and Time stamps
  925. ────────────────────────────────────────────────────────────────────────────────
  926. RC> How do you convert the bit-mapped DOS date and time stamps in the DTA
  927. RC> QB useable variables?  I'd like to convert them to INTEGERs for:
  928.  
  929. FUNCTION fixdate$ (parm%)
  930. 'Date and time are in packed format - these are the breakouts
  931. 'bits 00h-04h = day (1-31)
  932. 'bits 05h-08h = month (1-12)
  933. 'bits 09h-0Fh = year (relative to 1980)
  934.  
  935. day% = parm% AND 31        'get bits 0-4
  936. dayz$ = LTRIM$(STR$(day%))
  937. IF LEN(dayz$) = 1 THEN dayz$ = "0" + (dayz$)  'Parse and add leading 0 if
  938. needed
  939. parm% = parm% \ 32         'shift left 5
  940. month% = parm% AND 15      'get bits 5-8
  941. parm% = parm% \ 16         'shift left 4
  942. year% = (parm% AND 255) + 80    'get bits 9-15 and add to 1980
  943. moddate$ = dayz$ + mon$(month%) + LTRIM$(STR$(year%))  'Format is 20-Oct-9
  944. 0
  945.  
  946. fixdate$ = moddate$
  947.  
  948. END FUNCTION
  949.  
  950. FUNCTION fixtime$ (parm%)
  951. 'Date and time are in packed format - these are the breakouts
  952. 'bits 00h-04h = 2 second incs (0-29)
  953. 'bits 05h-0Ah = minutes (0-59)
  954. 'bits 0Bh-0Fh = hours (0-23)
  955.  
  956. temp& = parm%
  957. IF parm% < 0 THEN temp& = temp& + 65536  'Check for sign (+ -)
  958. secs% = (temp& AND 31) * 2  'get bits 0-4 and multiply by 2
  959. temp& = temp& \ 32          'shift right 5
  960. mins% = temp& AND 63        'get bits 5-10
  961. temp& = temp& \ 64          'shift right 6
  962. hours% = temp& AND 31       'get bits 11-15
  963. sec$ = LTRIM$(STR$(secs%))
  964. IF LEN(sec$) = 1 THEN sec$ = "0" + sec$    'Parse and add leading 0's
  965. min$ = LTRIM$(STR$(mins%))
  966. IF LEN(min$) = 1 THEN min$ = "0" + min$    'if needed
  967. hour$ = LTRIM$(STR$(hours%))
  968. IF LEN(hour$) = 1 THEN hour$ = "0" + hour$
  969.  
  970. modtime$ = hour$ + ":" + min$ + ":" + sec$  'Format is 01:30:46
  971. fixtime$ = modtime$
  972.  
  973. END FUNCTION
  974.  
  975. 'Does that help - It's not an integer, but a string.
  976.  
  977.  
  978. --- VP [DOS] V4.09e
  979.  
  980.  * Origin: The MailMan  (914)374-3903 NY Quick Share Pt #7 *HST (1:272/34)
  981.  
  982.  
  983.  
  984. ════════════════════════════════════════════════════════════════════════════════
  985.  Area:    QuickBasic
  986.   Msg:    #3464
  987.  Date:    03-16-93 21:14 (Public)
  988.  From:    RICHARD DALE
  989.  To:      JEFF FREEMAN
  990.  Subject: ANSI0001.BAS 1/5
  991. ────────────────────────────────────────────────────────────────────────────────
  992. JF>It is my understanding that something in the public domain cannot be
  993. JF> copyrighted.
  994.  
  995.  
  996.     Heh heh.  I'm glad I'm not a copyright lawyer!  This has surely
  997. caused numerous headaches.  There are tons of words we use on a regular
  998. basis that are really copyrights -- xerox, kleenex, and so on.  Of
  999. course those are copyrighted trademarks, but constant usage has turned
  1000. them into ersatz "public domain".  The company still owns the rights,
  1001. but people use the names generically.
  1002.  
  1003.     Coke is in a similar situation.  There is a material -- "coke" --
  1004. which is used in making metal (steel, I believe), or something like
  1005. that.  I'm relatively sure it existed long before the great Coca-Cola
  1006. Company trademarked "Coke".  Although you're unlikely to confuse the two
  1007. -- indeed, drinking coke instead of Coke could be fatal -- it's the only
  1008. example I can think of right now where a "public domain" word is a
  1009. copyrighted trademark.  Or is it?  Heh heh heh!
  1010.  
  1011.     Oh yeah. . .  To keep on topic, this is pretty neat.
  1012.  
  1013.  
  1014. DECLARE SUB DrawPicture ()
  1015.  
  1016. SCREEN 9   'adjust for your system type
  1017.  
  1018. LINE (0, 0)-(639, 349), 11, BF
  1019. x1 = 0
  1020. x2 = 1020
  1021. y1 = 0
  1022. y2 = 764
  1023. xPos% = 10
  1024. yPos% = 10
  1025. i% = 1
  1026.  
  1027. DO
  1028.     ' define viewport
  1029.         VIEW (xPos%, yPos%)-(xPos% + 200, yPos% + 155), 0, 15
  1030.  
  1031.     ' define logical coordinates
  1032.         WINDOW SCREEN (x1, y1)-(x2 / i%, y2 / i%)
  1033.  
  1034.         DrawPicture
  1035.         i% = i% + 1
  1036.         xPos% = xPos% + 210
  1037.         IF i% = 4 THEN xPos% = 10: yPos% = 175
  1038. LOOP UNTIL i% = 7
  1039. END
  1040.  
  1041. DATA 68, 4, 200, 76, 52, 12, 112, 44, 128, 52, 172, 76, 128, 52
  1042. DATA 68, 84, 112, 44, 84, 60, 128, 68, 100, 84, 68, 36, 96, 52
  1043. DATA 128, 68, 154, 84, 128, 68, 128, 116, 130, 54, 130, 68, 68
  1044. DATA 4, 52, 12, 172, 76, 142, 90, 142, 76, 142, 108, 142, 108
  1045.  
  1046. DATA 200, 76, 200, 76, 200, 92, 200, 92, 68, 164, 128, 116, 84
  1047. DATA 140, 52, 12, 52, 154, 52, 154, 68, 164, 68, 164, 68, 100
  1048. DATA 68, 36, 68, 84, 84, 45, 84, 76, 84, 109, 84, 140, 68, 100
  1049. DATA 96, 116, 84, 124, 112, 108, 68, 84, 128, 116, 85, 75, 113
  1050. DATA 91, 112, 77, 112, 108, 84, 119, 92, 115, 142, 86, 150, 82
  1051. DATA 180, 66, 186, 62, 186, 62, 236, 90, 236, 90, 68, 184, 68
  1052. DATA 184, 16, 154, 16, 154, 52, 133, 16, 154, 16, 160, 16, 160
  1053. DATA 68, 190, 68, 190, 68, 184, 68, 190, 236, 96, 236, 96, 236
  1054. DATA 90
  1055.  
  1056. SUB DrawPicture STATIC
  1057.         RESTORE
  1058.         FOR i% = 1 TO 40        ' read coordinates
  1059.                 READ x1%, y1%, x2%, y2%
  1060.                 LINE (x1%, y1%)-(x2%, y2%), 1
  1061.         NEXT
  1062.  
  1063.         PAINT (56, 20), 1, 1: PAINT (136, 64), 1, 1
  1064.         PAINT (120, 80), 1, 1: PAINT (152, 110), 14, 1
  1065.         PAINT (76, 48), 14, 1: PAINT (124, 60), 14, 1
  1066.         PAINT (68, 12), 2, 1: PAINT (80, 84), 2, 1
  1067.         PAINT (92, 128), 2, 1: PAINT (36, 150), 12, 1
  1068.         PAINT (150, 125), 12, 1: PAINT (80, 120), 14, 1
  1069.         PAINT (150, 125), 12, 1: PAINT (150, 142), 14, 1
  1070.         PAINT (88, 118), 12, 1: PAINT (144, 86), 12, 1
  1071.         PAINT (100, 120), 2, 1: PAINT (165, 90), 2, 1
  1072. END SUB
  1073.  
  1074.                =-=-=-=-=-=-=-=-= END OF CODE =-=-=-=-=-=-=-=-=
  1075.  
  1076. Day 56: America Held Hostage
  1077.  
  1078.  * DeLuxe2 1.26b #2989 * "We just screwed all these people." Hillary Clinton
  1079. --- FidoPCB v1.4 beta
  1080.  * Origin: Sound Advice - 24 Nodes (816)436-4516 (1:280/333)
  1081.  
  1082.  
  1083.  
  1084. ════════════════════════════════════════════════════════════════════════════════
  1085.  Area:    QuickBasic
  1086.   Msg:    #4717
  1087.  Date:    03-20-93 03:07 (Public)
  1088.  From:    STEVE GARTRELL
  1089.  To:      ALL
  1090.  Subject: Hey, rotate text, anyone?
  1091. ────────────────────────────────────────────────────────────────────────────────
  1092. DEFINT A-Z
  1093. DECLARE SUB RotateArray (SourceArray%(), TargetArray%(), Angle%)
  1094. 'Must have the appropriate QB.QLB/QBX.QLB/VBDOS.QLB loaded
  1095. ' if in the environment-link with appropriate library....
  1096. DECLARE SUB ABSOLUTE (Var%, BYVAL HowFar%, address AS INTEGER)
  1097. CONST C$ = "Recreated 03/14/93 by Steve Gartrell"
  1098. CONST NumBytes = 21
  1099. '$STATIC
  1100. DIM SHARED RORproc%(1 TO (NumBytes / 2))
  1101. '$DYNAMIC
  1102. DIM SHARED BitsPP%, Planes%, MaskBits%, MathNotDone%
  1103. DIM SHARED yResult&(1 TO 3), xResult%(1 TO 3), VertOrient%
  1104. DIM TheScreens%(1 TO 9)
  1105. offset% = VARPTR(RORproc%(1))
  1106. FOR byte% = 0 TO NumBytes - 1
  1107.     READ opcode%
  1108.     POKE (offset% + byte%), opcode%
  1109. NEXT byte%
  1110. TheScreens%(1) = 1
  1111. TheScreens%(2) = 2
  1112. TheScreens%(3) = 7
  1113. TheScreens%(4) = 8
  1114. TheScreens%(5) = 9
  1115. TheScreens%(6) = 11
  1116. TheScreens%(7) = 12
  1117. TheScreens%(8) = 13
  1118. ScrCnt% = 8
  1119. VertOrient% = 0
  1120. DO
  1121.     SCREEN TheScreens%(ScrCnt%)
  1122.     MaskBits% = 128
  1123.     SELECT CASE TheScreens%(ScrCnt%)
  1124.       CASE 1
  1125.         MaskBits% = 192
  1126.         BitsPP% = 2: Planes% = 1
  1127.         ColorMod% = 3
  1128.       CASE 2, 11
  1129.         BitsPP% = 1: Planes% = 1
  1130.         ColorMod% = 2
  1131.         IF TheScreens%(ScrCnt%) = 11 THEN WIDTH , 60
  1132.       CASE 7, 8, 9, 12
  1133.         BitsPP% = 1: Planes% = 4
  1134.         ColorMod% = 16
  1135.         SELECT CASE TheScreens%(ScrCnt%)
  1136.             CASE 9
  1137.                 WIDTH , 43
  1138.             CASE 12
  1139.                 WIDTH , 60
  1140.         END SELECT
  1141.       CASE 13
  1142.         MaskBits% = 255
  1143.         BitsPP% = 8: Planes% = 1
  1144.         ColorMod% = 256
  1145.  
  1146.     END SELECT
  1147.     StartX% = 152: StartY% = 56: EndX% = 175: EndY% = 79
  1148.     'StartX% = 64: StartY% = 0: EndX% = 263: EndY% = 199
  1149.     NumCols% = (EndX% - StartX%) + 1: NumRows% = (EndY% - StartY%) + 1
  1150.     ArrayBytes& = 4 + INT(((NumCols% * BitsPP%) + 7) / 8) * Planes% * NumRows%
  1151.     REDIM SourceArray%(0 TO ArrayBytes& \ 2)
  1152.     REDIM TargetArray%(0 TO 20)
  1153.     FOR TheLine% = 1 TO 25
  1154.         LOCATE TheLine%, 1
  1155.         FOR cnt% = 1 TO 40
  1156.             SELECT CASE TheScreens%(ScrCnt%)
  1157.                 CASE 1, 2, 11
  1158.                 CASE ELSE
  1159.                     thecolor% = thecolor% + 1
  1160.                     IF thecolor% > 15 THEN thecolor% = 1
  1161.                     COLOR thecolor%
  1162.             END SELECT
  1163.             'PRINT CHR$(cnt% MOD 3 + 60);
  1164.             PRINT CHR$(cnt% MOD 10 + 48);
  1165.         NEXT
  1166.     NEXT
  1167.     LOCATE 8, 20: PRINT "123";
  1168.     LOCATE 9, 20: PRINT "456";
  1169.     LOCATE 10, 20: PRINT "789";
  1170.     GET (StartX%, StartY%)-(EndX%, EndY%), SourceArray%(0)
  1171.     MathNotDone% = -1
  1172.     Angle% = 0
  1173.     DO
  1174.         DO: t$ = UCASE$(INKEY$): LOOP UNTIL LEN(t$)
  1175.         SELECT CASE t$
  1176.             CASE "Q"  'QUIT!!!!!
  1177.                 SCREEN 0: WIDTH 80, 25: COLOR 7, 0: END
  1178.             CASE "N"  'CHANGE SCREEN MODE!!!
  1179.                 ScrCnt% = ScrCnt% + 1
  1180.                 IF ScrCnt% = 9 THEN ScrCnt% = 1
  1181.                 EXIT DO
  1182.             CASE "V"  'Toggle vertical orientation
  1183.                 VertOrient% = NOT VertOrient%
  1184.         END SELECT
  1185.         Angle% = (Angle% + 90) MOD 360
  1186.         RotateArray SourceArray%(), TargetArray%(), Angle%
  1187.         PUT (StartX%, StartY%), TargetArray%(0), PSET
  1188.         LOCATE 25, 1: PRINT USING "###"; Angle%;
  1189.         PRINT CHR$(248); " ";
  1190.     LOOP
  1191. LOOP
  1192.  
  1193. RotRight:
  1194. DATA &H55              : 'push   bp
  1195. DATA &H8B,&HEC         : 'mov    bp, sp
  1196. DATA &H51              : 'push   cx
  1197. DATA &H8B,&H4E,&H06    : 'mov    cx, [bp + 6]
  1198. DATA &H8B,&H5E,&H08    : 'mov    bx, [bp + 8]
  1199.  
  1200. DATA &H8B,&H07         : 'mov    ax, [bx]
  1201. DATA &HD2,&HC8         : 'ror    al, cl
  1202. DATA &H89,&H07         : 'mov    [bx], ax
  1203. DATA &H59              : 'pop    cx
  1204. DATA &H5D              : 'pop    bp
  1205. DATA &HCA,&H04,&H00    : 'retf   4
  1206.  
  1207. SUB RotateArray (SourceArray%(), TargetArray%(), Angle%)
  1208.  
  1209. DIM SourcePix%(1 TO 4)
  1210. DIM SourceBitsPP%, SourceBytesPerRow&, SourceRowOffset&
  1211. DIM SourceX%, SourceY%, BytePosCopy&, SourceBytePos&
  1212. DIM SourceRightMove%, SourceBitMask%, SourceToTargetDiff%
  1213. DIM TargetBitsPP%, TargetBytesPerRow&, TargetRowOffset&
  1214. DIM TargetRightMove%, TargetBytePos&, TargetX%, TargetY%
  1215. DIM WhichBits%, NumCols%, NumRows%
  1216.  
  1217. SELECT CASE BitsPP%
  1218.     CASE 1
  1219.         WhichBits% = 7
  1220.     CASE 2
  1221.         WhichBits% = 3
  1222.     CASE 8
  1223.         WhichBits% = 0
  1224. END SELECT
  1225. SourceBitsPP% = SourceArray%(0)
  1226. NumCols% = SourceBitsPP% \ BitsPP%
  1227. NumRows% = SourceArray%(1)
  1228. IF Angle% MOD 180 THEN
  1229.     'Make it square if it's not!!!
  1230.     SELECT CASE NumRows% - NumCols%
  1231.         CASE IS < 0
  1232.             NumCols% = NumRows%
  1233.         CASE IS > 0
  1234.             NumRows% = NumCols%
  1235.     END SELECT
  1236. END IF
  1237. TargetBitsPP% = NumCols% * BitsPP%
  1238. IF TargetBitsPP% AND 7 THEN
  1239.     TargetBytesPerRow& = (TargetBitsPP% \ 8 + 1) * Planes%
  1240. ELSE
  1241.     TargetBytesPerRow& = (TargetBitsPP% \ 8) * Planes%
  1242. END IF
  1243.  
  1244. IF MathNotDone% THEN
  1245.     REDIM TargetArray%(0 TO ((TargetBytesPerRow& * NumRows%) \ 2) + 2)
  1246.     TargetArray%(0) = TargetBitsPP%
  1247.     TargetArray%(1) = NumRows%
  1248.     REDIM yResult&(0 TO NumRows% - 1)
  1249.     yResult&(0) = 4
  1250.     FOR TargetY% = 1 TO NumRows% - 1
  1251.         yResult&(TargetY%) = yResult&(TargetY% - 1) + TargetBytesPerRow&
  1252.     NEXT
  1253.  
  1254.     REDIM xResult%(0 TO NumCols% - 1)
  1255.     FOR TargetX% = 0 TO NumCols% - 1
  1256.         xResult%(TargetX%) = (TargetX% * BitsPP%) \ 8
  1257.     NEXT
  1258. ELSE
  1259.     REDIM TargetArray%(0 TO ((TargetBytesPerRow& * NumRows%) \ 2) + 2)
  1260.     TargetArray%(0) = TargetBitsPP%
  1261.     TargetArray%(1) = NumRows%
  1262. END IF
  1263.  
  1264. TargetBytesPerPlane% = TargetBytesPerRow& \ Planes%
  1265. IF SourceBitsPP% MOD 8 THEN
  1266.     SourceBytesPerPlane% = (SourceBitsPP% \ 8 + 1)
  1267. ELSE
  1268.     SourceBytesPerPlane% = (SourceBitsPP% \ 8)
  1269. END IF
  1270. SourceBytesPerRow& = SourceBytesPerPlane% * Planes%
  1271. SourceRowOffset& = 4
  1272. SourceBytePos& = SourceRowOffset&
  1273. SourceRightMove% = 0
  1274. SourceBitMask% = MaskBits%
  1275.  
  1276. 'adj for zero base
  1277. NumRows% = NumRows% - 1
  1278. NumCols% = NumCols% - 1
  1279.  
  1280. RotRight% = VARPTR(RORproc%(1))
  1281.  
  1282. FOR SourceY% = 0 TO NumRows%
  1283.     FOR SourceX% = 0 TO NumCols%
  1284.         SELECT CASE Angle%
  1285.             CASE 90
  1286.                 TargetX% = SourceY%
  1287.                 TargetY% = NumCols% - SourceX%
  1288.             CASE 180
  1289.                 TargetX% = NumCols% - SourceX%
  1290.                 TargetY% = NumRows% - SourceY%
  1291.             CASE 270
  1292.                 TargetX% = NumRows% - SourceY%
  1293.                 TargetY% = SourceX%
  1294.             CASE ELSE
  1295.                 TargetX% = SourceX%
  1296.                 TargetY% = SourceY%
  1297.         END SELECT
  1298.         IF VertOrient% THEN
  1299.             SELECT CASE Angle%
  1300.                 CASE 90
  1301.                     TempX% = TargetX%
  1302.                     TargetX% = (TempX% AND &H7FF8) + (7 - (TargetY% AND 7))
  1303.                     TargetY% = (TargetY% AND &H7FF8) + (7 - (TempX% AND 7))
  1304.                     TargetY% = (TargetY% AND &H7FF8) + (7 - (TargetY% AND 7))
  1305.                 CASE 180
  1306.                     TargetX% = (TargetX% AND &H7FF8) + (7 - (TargetX% AND 7))
  1307.  
  1308.                     TargetY% = (TargetY% AND &H7FF8) + (7 - (TargetY% AND 7))
  1309.                 CASE 270
  1310.                     TempX% = TargetX%
  1311.                     TargetX% = (TempX% AND &H7FF8) + (7 - (TargetY% AND 7))
  1312.                     TargetY% = (TargetY% AND &H7FF8) + (7 - (TempX% AND 7))
  1313.                     TargetX% = (TargetX% AND &H7FF8) + (7 - (TargetX% AND 7))
  1314.                 CASE ELSE
  1315.                     TargetX% = SourceX%
  1316.                     TargetY% = SourceY%
  1317.             END SELECT
  1318.         END IF
  1319.         TargetBytePos& = yResult&(TargetY%) + xResult%(TargetX%)
  1320.         TargetRightMove% = TargetX% AND WhichBits%
  1321.         IF BitsPP% = 2 THEN
  1322.             TargetRightMove% = TargetRightMove% + TargetRightMove%
  1323.         END IF
  1324.         SourceToTargetDiff% = (TargetRightMove% - SourceRightMove% + 8) AND 7
  1325.         BytePosCopy& = SourceBytePos&
  1326.         DEF SEG = VARSEG(SourceArray%(0))
  1327.         FOR PlaneNum% = 1 TO Planes%
  1328.             SourcePix%(PlaneNum%) = (PEEK(BytePosCopy&) AND SourceBitMask%)
  1329.             BytePosCopy& = BytePosCopy& + SourceBytesPerPlane%
  1330.         NEXT
  1331.         IF SourceToTargetDiff% THEN
  1332.             DEF SEG
  1333.             FOR PlaneNum% = 1 TO Planes%
  1334.                 CALL ABSOLUTE(SourcePix%(PlaneNum%), BYVAL SourceToTargetDiff%, RotRight%)
  1335.             NEXT
  1336.         END IF
  1337.         DEF SEG = VARSEG(TargetArray%(0))
  1338.         FOR PlaneNum% = 1 TO Planes%
  1339.             POKE TargetBytePos&, PEEK(TargetBytePos&) OR SourcePix%(PlaneNum%)
  1340.             TargetBytePos& = TargetBytePos& + TargetBytesPerPlane%
  1341.         NEXT
  1342.         DEF SEG
  1343.         SourceRightMove% = (SourceRightMove% + BitsPP%) AND 7
  1344.         IF SourceBitMask% AND 1 THEN
  1345.             SourceBitMask% = MaskBits%
  1346.             SourceBytePos& = SourceBytePos& + 1
  1347.         ELSE
  1348.             CALL ABSOLUTE(SourceBitMask%, BYVAL BitsPP%, VARPTR(RORproc%(1)))
  1349.         END IF
  1350.     NEXT
  1351.     SourceRowOffset& = SourceRowOffset& + SourceBytesPerRow&
  1352.     SourceBytePos& = SourceRowOffset&
  1353.     SourceBitMask% = MaskBits%
  1354.     SourceRightMove% = 0
  1355. NEXT
  1356.  
  1357. END SUB
  1358.  
  1359.  
  1360. --- D'Bridge 1.30/071082
  1361.  
  1362.  * Origin: RadioLink! Columbus, OH (614)766-2162 HST/DS (1:226/140)
  1363.  
  1364.  
  1365.