home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / PROGRAM / BASIC / QBS_0103 / QBS103-8.DOC < prev    next >
Text File  |  1993-04-30  |  42KB  |  1,381 lines
  1. ════════════════════════════════════════════════════════════════════════════════
  2.  Area:    QuickBasic
  3.   Msg:    #8693
  4.  Date:    03-30-93 08:58 (Public)
  5.  From:    DOUGLAS LUSHER
  6.  To:      LEE MADAJCZYK
  7.  Subject: DISK NOT READY, AND GENER
  8. ────────────────────────────────────────────────────────────────────────────────
  9. LM> DL> By the way, if you're doing a lot of work on floppy drives, you
  10. LM>   > might also want to check if the disk in the drive is
  11. LM>   > write-protected or not. I have code for that also, if you need
  12.  
  13. LM> Douglas...
  14. LM>    Could you post that here? If I said Pretty Please? Thanks..
  15.  
  16. Sure, here it is. I trust you know to load QB with the /L switch
  17. and to include the QB.BI file. Of course when you use this in a
  18. program, you will want to use the code I posted earlier to make
  19. sure that there is a disk in the drive before using this to make
  20. sure that the floppy is not write protected. This function returns
  21. True (-1) if the disk in the specified drive *can* be written to,
  22. i.e. it is not write protected.
  23.  
  24. FUNCTION FloppyWriteOK% (Drive$)
  25. DIM XRegister as RegTypeX
  26.  
  27. Drive% = (ASC(Drive$) OR 32) - 97
  28.  
  29. 'reset floppy drive
  30. XRegister.AX = 0
  31. XRegister.DX = Drive%
  32. CALL InterruptX(&H13, XRegister, XRegister)
  33. 'spin it
  34. XRegister.AX = &H401
  35. XRegister.CX = &H101
  36. XRegister.DX = Drive%
  37. CALL InterruptX(&H13, XRegister, XRegister)
  38.  
  39. Buffer$ = SPACE$(512)
  40. 'read from the disk
  41. XRegister.AX = &H201
  42. XRegister.ES = VARSEG(Buffer$)
  43. XRegister.BX = SADD(Buffer$)
  44. XRegister.CX = &H101
  45. XRegister.DX = Drive%
  46. CALL InterruptX(&H13, XRegister, XRegister)
  47.  
  48. 'try writing back to the disk
  49. XRegister.AX = &H301
  50. XRegister.ES = VARSEG(Buffer$)
  51. XRegister.BX = SADD(Buffer$)
  52. XRegister.CX = &H101
  53. XRegister.DX = Drive%
  54. CALL InterruptX(&H13, XRegister, XRegister)
  55. FloppyWriteOK% = ((XRegister.Flags AND 1) = 0)
  56.  
  57. END FUNCTION
  58.  
  59. ---
  60.  ■ SLMR 2.1a ■ Being weird isn't enough.
  61.  
  62.  
  63. --- TMail v1.30.4
  64.  * Origin: TC-AMS MLTBBS 2.2 - Minnetonka, MN (612)-938-4799 (1:282/7)
  65.  
  66.  
  67.  
  68. ════════════════════════════════════════════════════════════════════════════════
  69.  Area:    QuickBasic
  70.   Msg:    #8487
  71.  Date:    03-29-93 15:27 (Public)
  72.  From:    JOE NEGRON
  73.  To:      SEAN SULLIVAN
  74.  Subject: Need a routine
  75. ────────────────────────────────────────────────────────────────────────────────
  76. SS> I know I've seen a routine for determining the directory from which a
  77.   > program was launched, but can't remember where.  Anyone have this info?
  78.  
  79. Here you go:
  80.  
  81. ============================== Begin code ==============================
  82. DEFINT A-Z
  83.  
  84. '$INCLUDE: 'qbx.bi'
  85.  
  86. DECLARE FUNCTION ProgName$ ()
  87.  
  88. '***********************************************************************
  89. '* FUNCTION ProgName$
  90. '*
  91. '* PURPOSE
  92. '*    Uses DOS ISR 21H, Function 51H (Get PSP Address) to return the
  93. '*    name of the currently executing program.
  94. '*
  95. '* EXTERNAL ROUTINE(S)
  96. '*    QBX.LIB
  97. '*    -------
  98. '*    SUB Interrupt (IntNum%, IRegs AS RegType, ORegs AS RegType)
  99. '***********************************************************************
  100. FUNCTION ProgName$ STATIC
  101.    DIM IRegs AS RegType, ORegs AS RegType
  102.  
  103.    IRegs.ax = &H5100                         'DOS Function 51h
  104.    Interrupt &H21, IRegs, ORegs              '  Get PSP Address
  105.  
  106.    DEF SEG = ORegs.bx
  107.    EnvSeg% = PEEK(&H2C) + PEEK(&H2D) * 256   'Get environment address
  108.    DEF SEG = EnvSeg%
  109.  
  110.    DO
  111.       Byte% = PEEK(Offset%)                  'Take a byte
  112.  
  113.       IF Byte% = 0 THEN                      'Items are ASCIIZ terminated
  114.          Count% = Count% + 1
  115.  
  116.          IF Count% AND EXEFlag% THEN         'EXE also ASCIIZ terminated
  117.             EXIT DO                          'Exit at the end
  118.          ELSEIF Count% = 2 THEN              'Last entry in env. terminated
  119.             EXEFlag% = TRUE                  '  with two NULs.  Two bytes
  120.             Offset% = Offset% + 2            '  ahead is the EXE file name.
  121.          END IF
  122.       ELSE                                   'If Byte% <> 0, reset
  123.          Count% = FALSE                      '  zero counter
  124.  
  125.          IF EXEFlag% THEN                    'If EXE name found,
  126.             Temp$ = Temp$ + CHR$(Byte%)      '  build string
  127.          END IF
  128.       END IF
  129.  
  130.  
  131.       Offset% = Offset% + 1                  'To grab next byte...
  132.    LOOP                                      'Do it again
  133.  
  134.    DEF SEG                                   'Reset default segment
  135.    ProgName$ = Temp$                         'Assign Temp$ to the FUNCTION
  136.    Temp$ = ""                                'Clean up
  137. END FUNCTION
  138. =============================== End code ===============================
  139.  
  140.           --Joe in Bay Ridge, Brooklyn, NY, Mon, 03-29-1993--
  141.  
  142. ... Old enough to know better; too young to resist.
  143. ___
  144.  X Blue Wave/QWK v2.12 X
  145.  
  146. --- Maximus 2.01wb
  147.  * Origin: * BlueDog BBS * (212) 594-4425 * NYC FileBone Hub (1:278/709)
  148.  
  149.  
  150.  
  151. ════════════════════════════════════════════════════════════════════════════════
  152.  Area:    QuickBasic
  153.   Msg:    #9614
  154.  Date:    03-30-93 22:58 (Public)
  155.  From:    LYN BORCHERT
  156.  To:      QUINN TYLER JACKSON
  157.  Subject: A Simple PickList Sub
  158. ────────────────────────────────────────────────────────────────────────────────
  159. Hello Quinn!
  160.  
  161. Just thought I'd contribute a little to the source code floating around here.
  162. Feel free to capture it for QBS or whatever.
  163.  
  164. I also have something I'd like you to take a look at.  Is there a Fido
  165. address that I can send you a file to?
  166.  
  167. -=[ Lyn ]=-
  168.  
  169. ---------------------------[ Snip Snip ]----------------------------------
  170. DEFINT A-Z
  171. DECLARE SUB pl (rw, co, fg, bg, Hfg, Hbg, sr() AS STRING, reslt)
  172.  
  173. '*****  The Following Code is to Demo the PickList Routine  *****
  174.  
  175. COLOR 0, 1
  176. CLS
  177.  
  178. '**** First we must Create a Dynamic Array with the number of
  179. '**** elements our picklist will contain.  In this example we
  180. '**** have a menu of 5 choices. To use this Sub-program with
  181. '**** QuickBasic, you will need to make the array sharable since
  182. '**** QuickBasic doesn't allow passing of Arrays as an argument.
  183. '**** (I think)
  184.  
  185. REDIM main(1 TO 5) AS STRING
  186.  
  187. '**** Next we must populate the Array
  188.  
  189. main(1) = "This is the First Selection"
  190. main(2) = "Selection 2"
  191. main(3) = "Selection Number three is this one"
  192. main(4) = "Selection 4"
  193. main(5) = "Selection 5"
  194.  
  195. '**** Now call the Picklist Sub with all the arguments needed ****
  196.  
  197. CALL pl(6, 23, 0, 7, 15, 0, main(), result)
  198.  
  199. '**** When program execution returns from the Sub, the variable
  200. '**** "result" has been populated with the array element that the
  201. '**** user selected.
  202.  
  203. '**** Lets move our cursor to a place away from our picklist for
  204. '**** displaying the results and set the colors.
  205.  
  206. LOCATE 20, 30
  207. COLOR 15, 0
  208.  
  209. '**** Now lets use a Select Case to determine which item was selected
  210. '**** and do the appropriate task for that selection.
  211.  
  212.  
  213. SELECT CASE result
  214.  
  215.     CASE 1
  216.         PRINT "You Picked Selection 1";
  217.     CASE 2
  218.         PRINT "You Picked Selection 2";
  219.     CASE 3
  220.         PRINT "You Picked Selection 3";
  221.     CASE 4
  222.         PRINT "You Picked Selection 4";
  223.     CASE 5
  224.         PRINT "You Picked Selection 5";
  225.     CASE ELSE
  226. END SELECT
  227.  
  228. '**** A good practice when ending a program is to set the colors back
  229. '**** to the default and locate the cursor to a nice spot.
  230.  
  231. COLOR 7, 0
  232. LOCATE 25, 1
  233. END
  234.  
  235.  
  236.  
  237. '*****************************************************************
  238. '*                     PickList Subroutine                       *
  239. '*                       by Lyn Borchert                         *
  240. '*                                                               *
  241. '* Purpose:  To display a list of selections for the user to     *
  242. '*           select from.                                        *
  243. '*                                                               *
  244. '* Compiler: MS BASIC v7.x PDS                                   *
  245. '*                                                               *
  246. '* This source code is hereby released into the Public Domain.   *
  247. '*                                                               *
  248. '* QBS * Yes                                                     *
  249. '*                                                               *
  250. '*****************************************************************
  251. SUB pl (rw, co, fg, bg, Hfg, Hbg, sr() AS STRING, reslt)
  252.  
  253. '**** These are several var. declarations that I usually use as
  254. '**** Constants.
  255.  
  256. FALSE = 0
  257. TRUE = NOT FALSE
  258. done = FALSE
  259. backspace = 8
  260. downarrow = 20480
  261. endkey = 20224
  262. enter = 13
  263. escape = 27
  264. home = 18176
  265. leftarrow = 19200
  266.  
  267. rightarrow = 19712
  268. tabkey = 9
  269. uparrow = 18432
  270.  
  271. '**** First thing to do is find the longest string in the array
  272. '**** so we know how big the box needs to be. The loop goes one by
  273. '**** one through the array until only the length of the longest
  274. '**** array element is in the var. c
  275.  
  276. FOR x = 1 TO UBOUND(sr)
  277.     IF LEN(sr(x)) > c THEN
  278.         c = LEN(sr(x))
  279.     END IF
  280. NEXT x
  281.  
  282. '**** So that our box looks nice, the first line will be blank.
  283. '**** I add an extra 4 spaces, 2 for each side.
  284.  
  285. LOCATE rw, co
  286. COLOR fg, bg
  287. PRINT SPACE$(c + 4)
  288.  
  289. '**** Now to loop through our array again, this time to print the
  290. '**** elements of the array using the normal forground and background
  291. '**** colors.  First I print a blank line just like above, then go 2
  292. '**** characters beyond for a shadow effect. and finally print the
  293. '**** contents of the array.
  294.  
  295. FOR x = 1 TO UBOUND(sr)
  296.     LOCATE rw + x, co
  297.     COLOR fg, bg
  298.     PRINT SPACE$(c + 4);
  299.     COLOR 8, 0
  300.     PRINT SPACE$(2)
  301.     COLOR fg, bg
  302.     LOCATE rw + x, co + 2
  303.     PRINT sr(x)
  304. NEXT x
  305.  
  306. '**** Next I print one line below the last line to complete the box.
  307. '**** Then one more line below that and shifted 2 characters to the
  308. '**** right to finish up the shadow effect.
  309. LOCATE rw + x, co
  310. COLOR fg, bg
  311. PRINT SPACE$(c + 4);
  312. COLOR 8, 0
  313. PRINT SPACE$(2)
  314. LOCATE rw + x + 1, co + 2
  315. PRINT SPACE$(c + 4)
  316.  
  317. '**** This next section will paint the default highlighted selection.
  318. '**** The var sp is used to pad any array elements that were shorter
  319. '**** than any other ones.  That way our highlight always looks the
  320.  
  321. '**** same length. Of course, if this is the longest selection we don't
  322. '**** need to generate the sp var.
  323.  
  324. IF c > LEN(sr(1)) THEN
  325.  
  326.     LOCATE rw + 1, co + 2
  327.     sp = c - LEN(sr(1))
  328.     COLOR Hfg, Hbg
  329.     PRINT sr(1) + SPACE$(sp)
  330. ELSE
  331.     LOCATE rw + 1, co + 2
  332.     COLOR Hfg, Hbg
  333.     PRINT sr(1)
  334. END IF
  335.  
  336. '**** Now to set some pointer variables to keep track of things.
  337. '**** laslin is the Last Line of a valid selection.
  338. '**** firslin is the First Line of a valid selection.
  339. '**** Pointer is the currently highlighted selection.
  340. '**** oldpointer is the previously highlighted selection until it
  341. '**** gets returned to a non-highlighted state.
  342. '**** rwp is the row location of the highlighted selection.
  343.  
  344. laslin = rw + UBOUND(sr)
  345. firslin = rw + 1
  346. pointer = 1
  347. oldpoint = 1
  348. rwp = rw + pointer
  349.  
  350. '**** Put it all in a loop.
  351. DO
  352.     DO                           '**** This little loop is my canned
  353.         k$ = INKEY$              '**** input routine. It waits for a
  354.     LOOP UNTIL k$ <> ""          '**** keypress from the user and then
  355.     KC = CVI(k$ + CHR$(0))       '**** returns a unique number for
  356.                                  '**** every key on the keyboard.
  357.  
  358.     SELECT CASE KC               '**** Now a case select to act upon
  359.                                  '**** whatever key was pressed.
  360.         CASE downarrow
  361.             rwp = rw + pointer        '**** First locate row position of
  362.             pointer = pointer + 1     '**** current selection.
  363.                                       '**** Then increment the pointer var
  364.                                       '**** and if it goes beyond the end
  365.                                       '**** send it back to the top.
  366.             IF pointer > UBOUND(sr) THEN pointer = 1
  367.  
  368.         CASE uparrow                  '**** Do the same as above only in
  369.             rwp = rw + pointer        '**** reverse for the up arrow.
  370.             pointer = pointer - 1
  371.             IF pointer < 1 THEN pointer = UBOUND(sr)
  372.  
  373.         CASE enter                   '**** Here the user made his selection
  374.  
  375.             reslt = pointer          '**** so we load the var reslt with
  376.             done = TRUE              '**** his selection number and tell
  377.                                      '**** the loop we are all done.
  378.         CASE ELSE
  379.             SOUND 999, 1             '**** Here we beep at the user to
  380.                                      '**** indicate a bad keypress.
  381.     END SELECT
  382.  
  383. '**** Now we need to update the screen with the users movements.
  384. '**** I first locate to where the highlight was and reprint the line
  385. '**** in the normal colors. Using the sp var. for the same purpose
  386. '**** as before if necessary.
  387.  
  388.     LOCATE rwp, co + 2
  389.     IF c > LEN(sr(oldpoint)) THEN
  390.         sp = c - LEN(sr(oldpoint))
  391.         COLOR fg, bg
  392.         PRINT sr(oldpoint) + SPACE$(sp)
  393.     ELSE
  394.         COLOR fg, bg
  395.         PRINT sr(oldpoint)
  396.     END IF
  397.  
  398. '**** Now update the row location of our new highlighted line.
  399.  
  400.     rwp = rw + pointer
  401.  
  402. '**** Next print the new highlighted line.
  403.  
  404.     LOCATE rwp, co + 2
  405.     IF c > LEN(sr(pointer)) THEN
  406.         sp = c - LEN(sr(pointer))
  407.         COLOR Hfg, Hbg
  408.         PRINT sr(pointer) + SPACE$(sp)
  409.     ELSE
  410.         COLOR Hfg, Hbg
  411.         PRINT sr(pointer)
  412.     END IF
  413.  
  414. '**** Lastly, update the old highlight location pointer with the
  415. '**** current highlighted position.
  416.  
  417.     oldpoint = pointer
  418.  
  419. '**** Are we done?  If not go get another keypress from the user.
  420.  
  421. LOOP UNTIL done = TRUE
  422.  
  423. END SUB
  424.  
  425. ---
  426.  * Origin: ->Home of JEM DISC CD-ROM, Freq. JEMDISC for Info.<- (1:300/12)
  427.  
  428.  
  429.  
  430. ════════════════════════════════════════════════════════════════════════════════
  431.  Area:    QuickBasic
  432.   Msg:    #9916
  433.  Date:    03-29-93 14:10 (Public)
  434.  From:    RICH TIETJENS
  435.  To:      ARTHUR SHIPKOWSKI
  436.  Subject: QB-CIMR Positions
  437. ────────────────────────────────────────────────────────────────────────────────
  438. In a message of 26 Mar 93  16:33:12, Arthur Shipkowski wrote:
  439.  
  440. AS> You call 6:27am early? On school days, I get up at 5:50am, take a shower,
  441. AS> poll my bossnode for mail, eat breakfast and get to school by 7:15am. I'm
  442. AS> a miracle worker...sometimes I even use PB & QBX that early... That's
  443. AS> when I get code like:
  444. AS>
  445. AS>    FOR I% = 1 TO 10
  446. AS>       DO
  447. AS>       NEXT I%
  448. AS>    LOOP
  449. AS>
  450. AS> and spend all afternoon figuring out what's wrong.
  451.  
  452. ROFL!  I wish I could share this with my non-programming friends, but it
  453. wouldn't be funny if I had to explain it (which I would).
  454.  
  455. Looks like an Aggie program to me!
  456.  
  457. --- FIDOdoor+ 3.2.6 [IOSmail 0.89]
  458.  * Origin: You make my head explode. (1:3807/10.0)
  459.  
  460.  
  461.  
  462. ════════════════════════════════════════════════════════════════════════════════
  463.  Area:    QuickBasic
  464.   Msg:    #10184
  465.  Date:    03-31-93 06:46 (Public)
  466.  From:    DICK DENNISON
  467.  To:      MICHAEL BAILEY
  468.  Subject: File Date/Time
  469. ────────────────────────────────────────────────────────────────────────────────
  470. MB> If you could go ahead and post GetFileDateTime, I'd appreciate it.
  471.  
  472. 'Ok should be in the next 4 msgs:
  473.  
  474. ______O_/_________________| SNIP |________________\_O_____
  475.       O \                 | HERE |                / O
  476. 'This file created by PostIt! v5.0ba (VBDos version from Brent Ashley)
  477. '>>> Start of page 1 of dt.bas
  478.  
  479. ' DT      BAS : A Quick Basic tool to manipulate a file's date/time
  480. ' stamp
  481. ' author .....: Dick Dennison [74270,3636] 1:272/34 914-374-3903 *hst*
  482. ' 24 hrs
  483. ' supports ...: At least Dos 5.0 and later, untested to Dos 3.1
  484. ' syntax .....: DT [FILENAME]
  485. ' returns ....: The filename (or directory)
  486. ' includes ...: QB.bi from Microsoft
  487. ' cost .......: Free = Credit where credit due
  488. '             : Do not use as is for commercial use - may not be resold
  489. '             : May not be rebundled without prior written consent
  490. ' dated ......: 03/30/93 Version 1.0 released
  491. '
  492. '$INCLUDE: 'qb.bi'  'Supply correct path and start QB /L QB
  493. '
  494. DECLARE FUNCTION GetNum% (howmany%, min%, max%)
  495. DECLARE FUNCTION getdate& ()
  496. DECLARE FUNCTION gettime& ()
  497. DECLARE SUB SetFileDate (filename$, datef&, timef&)
  498. DECLARE FUNCTION filestru$ (filespec$)
  499. DECLARE FUNCTION fixdate$ (parm%)
  500. DECLARE FUNCTION fixtime$ (parm%)
  501. DECLARE FUNCTION getdir$ ()
  502.  
  503. TYPE filestruct
  504.    res AS STRING * 20
  505.    attr AS INTEGER
  506.    timef AS INTEGER
  507.    datef AS INTEGER
  508.    size AS LONG
  509.    nameff AS STRING * 14
  510. END TYPE
  511. DIM SHARED fi AS filestruct
  512.  
  513. DIM SHARED mon(12) AS STRING
  514. mon$(1) = "-Jan-": mon$(2) = "-Feb-": mon$(3) = "-Mar-": mon$(4) = _
  515.  "-Apr-"
  516. mon$(5) = "-May-": mon$(6) = "-Jun-": mon$(7) = "-Jul-": mon$(8) = _
  517.  "-Aug-":
  518. mon$(9) = "-Sep-": mon$(10) = "-Oct-": mon$(11) = "-Nov-": mon$(12) = _
  519.  "-Dec-"
  520.  
  521. PCOPY 0, 1
  522. COLOR 11, 0
  523.  
  524. filename$ = getdir$
  525. CLS
  526. PRINT filestru$(filename$)
  527. x& = getdate&
  528. y& = gettime&
  529. SetFileDate filename$, x&, y&
  530. PRINT filestru$(filename$)
  531. PRINT "Press a key"
  532. DO: a$ = INKEY$: LOOP WHILE a$ = ""
  533. PCOPY 1, 0
  534. LOCATE 25, 1
  535.  
  536. FUNCTION filestru$ (filespec$)
  537. DIM regs AS RegTypeX
  538. 'File structures
  539.  
  540. temp$ = filespec$ + CHR$(0)
  541.  
  542.    regs.ax = &H1A00                       'DOS service to set DTA
  543.    regs.ds = VARSEG(fi)
  544.    regs.dx = VARPTR(fi)
  545.    CALL INTERRUPTX(&H21, regs, regs)
  546.  
  547.    regs.ax = &H4E00                       'Find first matching file
  548.    regs.cx = 0                            'regular files
  549.    regs.ds = VARSEG(temp$)
  550.    regs.dx = SADD(temp$)
  551.    CALL INTERRUPTX(&H21, regs, regs)
  552.  
  553.    IF regs.flags AND 1 THEN
  554.        a$ = filespec$ + " File not Found"
  555.        filestru$ = a$
  556.  
  557.        EXIT FUNCTION
  558.    END IF
  559.  
  560. '        PRINT fixdate$(fi.datef),
  561.  '       PRINT fixtime$(fi.timef),
  562.   '      PRINT fi.size,
  563.    '     PRINT fi.nameff  'parse for AsciiZ
  564.         datef$ = fixdate$((fi.datef))
  565.         timef$ = fixtime$((fi.timef))
  566.    a$ = fi.nameff + "  " + STR$(fi.size) + "  " + datef$ + timef$
  567.    filestru$ = a$
  568.  
  569. END FUNCTION
  570.  
  571. FUNCTION fixdate$ (parm%)
  572. 'Date and time are in packed format - these are the breakouts
  573.  
  574. '>>> Continued on page 2.
  575.  
  576. --- VP [DOS] V4.09e
  577.  
  578.  * Origin: The MailMan  (914)374-3903 NY Quick Share Pt #7 *HST (1:272/34)
  579.  
  580.  
  581.  
  582. ════════════════════════════════════════════════════════════════════════════════
  583.  Area:    QuickBasic
  584.   Msg:    #10185
  585.  Date:    03-31-93 06:46 (Public)
  586.  From:    DICK DENNISON
  587.  To:      MICHAEL BAILEY
  588.  Subject: File Date/Time
  589. ────────────────────────────────────────────────────────────────────────────────
  590. '>>> Start of page 2 of dt.bas
  591.  
  592. 'bits 00h-04h = day (1-31)
  593. 'bits 05h-08h = month (1-12)
  594. 'bits 09h-0Fh = year (relative to 1980)
  595.  
  596. day% = parm% AND 31        'get bits 0-4
  597. dayz$ = LTRIM$(STR$(day%))
  598. IF LEN(dayz$) = 1 THEN dayz$ = "0" + (dayz$)  'Parse and add leading 0
  599. ' if needed
  600. parm% = parm% \ 32         'shift left 5
  601. Month% = parm% AND 15      'get bits 5-8
  602. parm% = parm% \ 16         'shift left 4
  603. year% = (parm% AND 255) + 80    'get bits 9-15 and add to 1980
  604. moddate$ = dayz$ + mon$(Month%) + LTRIM$(STR$(year%))  'Format is
  605. ' 20-Oct-90
  606.  
  607. fixdate$ = "  " + moddate$ + "  "
  608.  
  609. END FUNCTION
  610.  
  611. FUNCTION fixtime$ (parm%)
  612. 'Date and time are in packed format - these are the breakouts
  613. 'bits 00h-04h = 2 second incs (0-29)
  614. 'bits 05h-0Ah = minutes (0-59)
  615. 'bits 0Bh-0Fh = hours (0-23)
  616.  
  617. temp& = parm%
  618. IF parm% < 0 THEN temp& = temp& + 65536  'Check for sign (+ -)
  619. secs% = (temp& AND 31) * 2  'get bits 0-4 and multiply by 2
  620. temp& = temp& \ 32          'shift right 5
  621. mins% = temp& AND 63        'get bits 5-10
  622. temp& = temp& \ 64          'shift right 6
  623. hours% = temp& AND 31       'get bits 11-15
  624. sec$ = LTRIM$(STR$(secs%))
  625. IF LEN(sec$) = 1 THEN sec$ = "0" + sec$    'Parse and add leading 0's
  626. min$ = LTRIM$(STR$(mins%))
  627. IF LEN(min$) = 1 THEN min$ = "0" + min$    'if needed
  628. hour$ = LTRIM$(STR$(hours%))
  629. IF LEN(hour$) = 1 THEN hour$ = "0" + hour$
  630.  
  631. modtime$ = hour$ + ":" + min$ + ":" + sec$  'Format is 01:30:46
  632. fixtime$ = modtime$
  633.  
  634. END FUNCTION
  635.  
  636. FUNCTION getdate&
  637. gdatetop:
  638. PRINT "New Month (01-12): ";
  639. mo% = GetNum%(2, 1, 12)
  640. IF mo% = 0 THEN
  641.    getdate& = fi.datef + 0&
  642.    PRINT "Use Old Date"
  643.  
  644.    EXIT FUNCTION
  645. END IF
  646. PRINT "New Date (01-31): ";
  647. da% = GetNum%(2, 1, 31)
  648. PRINT "New Year : 19";
  649. yr% = GetNum%(2, 0, 99) - 80
  650. PRINT "          New File Date : "; LTRIM$(STR$(mo%)); "/"; _
  651.  LTRIM$(STR$(da%)); "/"; LTRIM$(STR$(yr% + 80))
  652.  
  653. 'datef%   'bits 0-4h=day(1-31),5-8h=month(1-12),9-Fh=year-1980
  654.          ' +                      , * 32          ,*512
  655. datef& = yr% * 512& + mo% * 32& + da%
  656.  
  657. getdate& = datef&
  658. END FUNCTION
  659.  
  660. FUNCTION getdir$
  661.  
  662. CLS
  663. SHARED dta AS STRING * 44
  664. 'SHARED namef$
  665. DIM regs AS RegTypeX
  666. DIM array(125) AS STRING
  667.    regs.ax = &H1A00                       'DOS service to set DTA
  668.    regs.ds = VARSEG(dta)
  669.    regs.dx = VARPTR(dta)
  670.    CALL INTERRUPTX(&H21, regs, regs)
  671. temp$ = "*.*" + CHR$(0)
  672. IF LEN(COMMAND$) THEN temp$ = COMMAND$ + CHR$(0)
  673.   findnext% = 0
  674.    FOR p% = 0 TO 124
  675.    'BEEP
  676.        IF findnext% THEN
  677.            regs.ax = &H4F00
  678.        ELSE
  679.            regs.ax = &H4E00 'find first
  680.  
  681.        END IF
  682.        regs.cx = 0             'normal attributes
  683.        regs.ds = VARSEG(temp$)
  684.        regs.dx = SADD(temp$)
  685.        CALL INTERRUPTX(&H21, regs, regs)
  686.        'PRINT regs.ax
  687.  
  688. '>>> Continued on page 3.
  689.  
  690. --- VP [DOS] V4.09e
  691.  * Origin: The MailMan  (914)374-3903 NY Quick Share Pt #7 *HST (1:272/34)
  692.  
  693.  
  694.  
  695. ════════════════════════════════════════════════════════════════════════════════
  696.  Area:    QuickBasic
  697.   Msg:    #10186
  698.  Date:    03-31-93 06:47 (Public)
  699.  From:    DICK DENNISON
  700.  To:      MICHAEL BAILEY
  701.  Subject: File Date/Time
  702. ────────────────────────────────────────────────────────────────────────────────
  703. '>>> Start of page 3 of dt.bas
  704.  
  705.        IF regs.ax AND 255 THEN
  706.            'PRINT "not found"
  707.            EXIT FOR
  708.        ELSE
  709.            namef$ = RTRIM$(MID$(dta$, 31, 12))
  710.            mark% = INSTR(namef$, CHR$(0))
  711.            IF mark% > 0 THEN namef$ = LEFT$(namef$, mark% - 1)
  712.        END IF
  713.        array$(p%) = namef$
  714.        PRINT namef$,
  715.        findnext% = -1
  716.    NEXT p%
  717.  
  718.  
  719. 'Setup some special key functions
  720.    cr$ = CHR$(13)
  721.    Nul$ = CHR$(0)
  722.    ArrowLt$ = Nul$ + CHR$(75)
  723.    ArrowRt$ = Nul$ + CHR$(77)
  724.    ArrowUp$ = Nul$ + CHR$(72)
  725.    ArrowDn$ = Nul$ + CHR$(80)
  726.    EndKey$ = Nul$ + CHR$(79)
  727.    Esc$ = CHR$(27)
  728.    Home$ = Nul$ + CHR$(71)
  729.    SpaceBar$ = CHR$(32)
  730. '==========================================
  731. botline% = p% \ 5 + 1
  732. 'Move cursor around
  733. IF LEN(COMMAND$) THEN GOTO skip
  734. LOCATE 1, 1, 1
  735. DO                         'This section lets the user move
  736.  In$ = INKEY$              'move the cursor around on the screen
  737.  SELECT CASE In$
  738.   CASE cr$
  739.    EXIT DO
  740.   CASE Esc$                'END
  741.    END
  742.   CASE Home$               'Goto the beginning of the line
  743.    LOCATE , 1
  744.   CASE EndKey$             'Goto the end of the line
  745.    LOCATE , 57
  746.   CASE ArrowUp$            'UpArrow
  747.    x% = CSRLIN
  748.    IF x% > 0 THEN
  749.        xx% = xx% - 5
  750.        LOCATE x% - 1
  751.    END IF
  752.   CASE ArrowDn$            'DownArrow
  753.    x% = CSRLIN
  754.    IF x% < botline% THEN
  755.        xx% = xx% + 5
  756.  
  757.        LOCATE x% + 1
  758.    END IF
  759.   CASE ArrowLt$            'LeftArrow
  760.    IF POS(0) > 14 THEN LOCATE , POS(0) - 14
  761.    IF yy% > 0 THEN yy% = yy% - 1
  762.   CASE ArrowRt$            'RightArrow
  763.    IF POS(0) < 56 THEN LOCATE , POS(0) + 14
  764.    IF yy% < 4 THEN yy% = yy% + 1
  765.   CASE SpaceBar$
  766.    BEEP
  767.  END SELECT
  768.  LOCATE , , 1                   'Keep cursor flashing
  769. LOOP
  770. '======================================================================
  771. num% = xx% + yy%
  772. 'CLS
  773. skip:
  774. getdir = array$(num%)
  775. END FUNCTION
  776.  
  777. FUNCTION GetNum% (howmany%, min%, max%)
  778. 'asc 48-57
  779. FOR n% = 1 TO howmany%
  780. getnumtop:
  781.    DO
  782.        a$ = INKEY$
  783.    LOOP WHILE a$ = ""
  784.    'PRINT ASC(a$)
  785.    SELECT CASE ASC(a$)
  786.        CASE 48 TO 57
  787.            PRINT a$;
  788.        CASE 13
  789.            GetNum% = 0
  790.            EXIT FUNCTION
  791.        CASE ELSE
  792.            BEEP
  793.            a$ = ""
  794.            GOTO getnumtop
  795.    END SELECT
  796.    IF VAL(a$) > max% THEN
  797.  
  798. '>>> Continued on page 4.
  799.  
  800. --- VP [DOS] V4.09e
  801.  * Origin: The MailMan  (914)374-3903 NY Quick Share Pt #7 *HST (1:272/34)
  802.  
  803.  
  804.  
  805. ════════════════════════════════════════════════════════════════════════════════
  806.  Area:    QuickBasic
  807.   Msg:    #10187
  808.  Date:    03-31-93 06:47 (Public)
  809.  From:    DICK DENNISON
  810.  To:      MICHAEL BAILEY
  811.  Subject: File Date/Time
  812. ────────────────────────────────────────────────────────────────────────────────
  813. '>>> Start of page 4 of dt.bas
  814.  
  815.        BEEP
  816.        a$ = ""
  817.        GOTO getnumtop
  818.    END IF
  819.    nu$ = nu$ + a$
  820.  
  821.    a$ = ""
  822. NEXT n%
  823.    IF VAL(nu$) > max% OR VAL(nu$) < min% THEN
  824.        BEEP
  825.        nu$ = ""
  826.        GOTO getnumtop
  827.    END IF
  828. PRINT
  829. GetNum% = VAL(nu$)
  830. END FUNCTION
  831.  
  832. FUNCTION gettime&
  833. 'mo% = GetNum%(2, 1, 12)
  834. gtimetop:
  835. PRINT "New Hour (00-23): ";
  836. hour% = GetNum%(2, -1, 23)
  837. IF hour% < 0 THEN
  838.    gettime& = fi.timef + 0&
  839.    PRINT "Use old time"
  840.    EXIT FUNCTION
  841. END IF
  842.  
  843. PRINT "New Minutes (00-59): ";
  844. min% = GetNum%(2, 0, 59)
  845. PRINT "New Seconds (00-59) : ";
  846. sec% = GetNum%(2, 0, 59)
  847.  
  848. PRINT "          New file time : " + LTRIM$(STR$(hour%)) + ":" + _
  849.  LTRIM$(STR$(min%)) + ":" + LTRIM$(STR$(sec%))
  850. 'timef%   'bits 0-4h=2secincs(0-29),5-Ah=mins(0-59),B-Fh=Hours(0-23)
  851.          ' +                      , * 32          ,*2048
  852. timef& = hour% * 2048& + min% * 32& + sec%
  853. gettime& = timef&
  854. END FUNCTION
  855.  
  856. SUB SetFileDate (filename$, datef&, timef&)
  857. DIM regs AS RegType
  858. OPEN filename$ FOR APPEND AS 1
  859. handle% = FILEATTR(1, 2)
  860.  
  861. regs.ax = &H5700 + 1 'SET file date/time  + 0 the GET
  862. regs.bx = handle%    'file handle
  863.  
  864. 'timef%   'bits 0-4h=2secincs(0-29),5-Ah=mins(0-59),B-Fh=Hours(0-23)
  865.          ' +                      , * 32          ,*2048
  866.  
  867. 'timef% = 2 * 2048 + 22 * 32
  868. 'datef%   'bits 0-4h=day(1-31),5-8h=month(1-12),9-Fh=year-1980
  869.          ' +                      , * 32          ,*512
  870. 'datef% = 12 * 512 + 6 * 32 + 16
  871. IF timef& > 32767 THEN tim% = timef& - 65536 ELSE tim% = timef&
  872. IF datef& > 32767 THEN dat% = datef& - 65536 ELSE dat% = datef&
  873. regs.cx = tim%
  874. regs.dx = dat%
  875.  
  876. CALL INTERRUPT(&H21, regs, regs)
  877. IF regs.flags AND 1 THEN BEEP
  878. CLOSE 1
  879. END SUB
  880.  
  881.  
  882. ______O_/_________________| SNIP |________________\_O_____
  883.       O \                 | HERE |                / O
  884.  
  885.  
  886. --- VP [DOS] V4.09e
  887.  * Origin: The MailMan  (914)374-3903 NY Quick Share Pt #7 *HST (1:272/34)
  888.  
  889.  
  890.  
  891. ════════════════════════════════════════════════════════════════════════════════
  892.  Area:    QuickBasic
  893.   Msg:    #10275
  894.  Date:    03-31-93 12:00 (Public)
  895.  From:    SEAN SULLIVAN
  896.  To:      JANUSZ SUCHOROLSKI
  897.  Subject: ASCII TEXT SEARCH +
  898. ────────────────────────────────────────────────────────────────────────────────
  899. Greetings and Salutations JANUSZ!
  900.  
  901. Monday March 29 1993 11:12, JANUSZ SUCHOROLSKI wrote to ALL:
  902.  
  903.  JS> I'd like to implement a "text search" while inside ASCII file.
  904.  JS> Here's some code:
  905.  
  906. .....
  907.  
  908.  JS> It simply shows the whole line in reverse video, however I'd like to see
  909.  JS> just the occurence(s) of the string highlighted instead of the whole
  910.  JS> line. I guess somebody did it before and might post a missing
  911.  JS> bit(bytes).
  912.  
  913. Janusz, I've reworked your code a little to give you what you want.  Hope
  914. this helps.
  915.  
  916. ---------------------8<-------cut here---------->8----------------------------
  917.  
  918. DEFINT A-Z
  919. CLS
  920.  
  921. 'Get input file and search string
  922. LOCATE 1, 1: COLOR 0, 11: PRINT SPACE$(80)
  923. LOCATE 1, 1: INPUT "Text file name: ", tf$
  924. LOCATE 1, 1: PRINT SPACE$(80)
  925. LOCATE 1, 1: INPUT "Search for:", ts$
  926. ts$ = UCASE$(ts$)
  927.  
  928. 'search string length
  929. tl = LEN(ts$)
  930. COLOR 7, 0
  931.  
  932. 'open file
  933. freenum = FREEFILE
  934. OPEN tf$ FOR INPUT AS #freenum
  935. LineNum = 0
  936.  
  937. 'set up view port for printing file
  938. VIEW PRINT 2 TO 24
  939.  
  940. 'read in file line by line highlighting found search text found
  941. WHILE NOT EOF(freenum)
  942.   LineNum = LineNum + 1
  943.   LINE INPUT #freenum, Check$
  944.  
  945.   'if line contains the search text, highlight that text
  946.   IF INSTR(UCASE$(Check$), ts$) THEN
  947.     TextFound = INSTR(UCASE$(Check$), ts$)
  948.     COLOR 7, 0: Found$ = MID$(Check$, 1, TextFound - 1): PRINT Found$;
  949.     COLOR 0, 7: Found$ = MID$(Check$, TextFound, tl): PRINT Found$;
  950.     COLOR 7, 0: Found$ = MID$(Check$, TextFound + tl): PRINT Found$
  951.   'else print the line
  952.  
  953.   ELSE PRINT Check$
  954.   END IF
  955.  
  956.   'pause when page is full
  957.   IF LineNum = 21 THEN
  958.     COLOR 0, 12: PRINT "< MORE >": COLOR 7, 0
  959.     DO
  960.       Ky$ = INKEY$
  961.     LOOP WHILE Ky$ = ""
  962.     LineNum = 0
  963.     CLS 2
  964.   END IF
  965.  
  966. WEND
  967.  
  968. CLOSE #freenum
  969.  
  970. --------------------------8<-----cut here----->8-------------------------
  971.  
  972. I've added a top line prompt for easier testing and print the text in a
  973. view port.  You were using INPUT to get the file data, but that chops up the
  974. input if commas, etc, are in the line.  Using LINE INPUT you get the whole
  975. line
  976. at once.  If the string is found in the line, the line is then parsed to
  977. highlight just the search string, otherwise the whole line is printed as is.
  978. I add a routine to pause when the screen is full.  Hope this helps ya.
  979.  
  980. Sean
  981.  
  982. --- GoldED 2.40.P0623
  983.  * Origin: COMNET Point #28 [Watervliet, NY] (1:267/113.28)
  984.  
  985.  
  986.  
  987. ════════════════════════════════════════════════════════════════════════════════
  988.  Area:    QuickBasic
  989.   Msg:    #10684
  990.  Date:    03-31-93 15:31 (Public)
  991.  From:    JOHN GALLAS
  992.  To:      PAUL CRUTCHFIELD
  993.  Subject: Quickbasic 4.5 Question]
  994. ────────────────────────────────────────────────────────────────────────────────
  995. PC> I wish to know the following:
  996.  
  997. PC>    Using Soundblaster, play music through sb speaker (Without .MOD,
  998. PC>.CMF, just memory stuff..like the PLAY "ABC" command except going
  999. PC>through the sb speaker.
  1000.  
  1001. Try this:
  1002.  
  1003. '-------------------------------clip here-------------------------------
  1004.  
  1005. '                        Sound Blaster Source Code
  1006. '                         Made by Brandon Callison
  1007. '        Register 388h is the address/status port, and 389h is the data port.
  1008. 'This is, of course, only for the FM music.  (The cannels 1-11)  which are
  1009. 'compatible with Ad-Lib, Sound Blaster, SB Pro, Thunder Board, and many
  1010. 'others.  All boards advertised as compatible with Ad-Lib or Sound Blaster
  1011. 'are compatible with this.  Explainations of the mysterious code will be
  1012. 'throughout the program.
  1013.  
  1014. DEFINT A-Z
  1015.  
  1016. DECLARE SUB SBStop ()
  1017. DECLARE SUB SBReset ()
  1018. DECLARE SUB SBOutPort (reg, x)
  1019. DECLARE SUB SBPlayNote (freq#, oct)
  1020.  
  1021. ' vvvvvvvvvvvvvvvvvvvvvvv
  1022. ' The following are his variable declarations; I'm leaving them in so you
  1023. ' can see what all the variables are for:
  1024. '
  1025. 'float freq;                          /* Frequency                */
  1026. 'int oct;                             /* Octave                   */
  1027. 'int reg;                             /* Register no.             */
  1028. 'int x;                               /* Poke number to register  */
  1029. 'int i;                               /* GLOBAL Dummy loop signal */
  1030. '
  1031. ' ^^^^^^^^^^^^^^^^^^^^^^^
  1032.  
  1033. SBReset
  1034. SBPlayNote 277.2, 5                  'Middle C sharp on octave 5
  1035. SLEEP 2
  1036. SBStop                               'Must be called to cut sound
  1037.  
  1038. END
  1039.  
  1040. SUB SBOutPort (reg, x)
  1041.  
  1042. OUT &H388, reg              'Outputs the register to be written to
  1043.  
  1044. FOR I = 1 TO 6
  1045.  
  1046.     reg = INP(&H388)
  1047.  
  1048.  
  1049. NEXT I
  1050.  
  1051. '   ^- This loop requires some explaining.  The sound card must allow time
  1052. 'to process it's code.  6 reads from the status port will cause it to wait
  1053. 'for 2.3 microseconds.  You MUST NOT make any outputs to the sound card port
  1054. 'without waiting at least this amount of time in-between calls.  The same
  1055. 'applies below, except the wait is 23 microseconds, by 35 reads from the data
  1056. 'port.
  1057.  
  1058. OUT &H389, x
  1059. FOR I = 1 TO 35                 'Outputs the data into the register
  1060.     reg = INP(&H389)
  1061. NEXT I
  1062.  
  1063. END SUB
  1064.  
  1065. SUB SBPlayNote (freq#, oct)
  1066.  
  1067. freq2 = INT(1.31 * freq#)          'Convert from hz to raw frequency?!?!
  1068. SBOutPort &H60, &HF0
  1069. SBOutPort &HC0, 1
  1070. SBOutPort &HA0, freq2 AND &HFF
  1071. SBOutPort &HB0, ((freq2 AND &HFF00) / &H100) OR (oct * 4) OR 32
  1072.        '   ^- for different channels, do anywhere from the register
  1073.        '   0xB0 to 0xBA.  (channels 1-11)
  1074.  
  1075. END SUB
  1076.  
  1077. SUB SBReset
  1078.  
  1079. FOR I = 1 TO 244         ' The sound card has 244 data ports.  Just clears
  1080.     OUT &H388, 0         ' all of them.
  1081. NEXT I
  1082.  
  1083. END SUB
  1084.  
  1085. SUB SBStop
  1086.  
  1087. SBOutPort &HB0, 0       ' As I said earlier for different channels
  1088.  
  1089. END SUB
  1090.  
  1091.  * OLX 2.1 TD * "If you can't make it good, make it LOOK good." - B Gates
  1092.  
  1093. --- Maximus 2.01wb
  1094.  * Origin: Command Line BBS =Mpls. MN= V.32bis [612-788-6685] (1:282/2007)
  1095.  
  1096.  
  1097.  
  1098. ════════════════════════════════════════════════════════════════════════════════
  1099.  Area:    QuickBasic
  1100.   Msg:    #11477
  1101.  Date:    04-01-93 00:05 (Public)
  1102.  From:    SCOTT BAILEY
  1103.  To:      PAUL CRUTCHFIELD
  1104.  Subject: pocal 1/3
  1105. ────────────────────────────────────────────────────────────────────────────────
  1106. In a message dated 28 Mar 93  14:48:21, Paul Crutchfield wrote:
  1107.  
  1108.  PC> What is your name? (Then they enter their name..(both sides see it)
  1109.  PC>                     (I can backspace a letter if they type it in right
  1110.  PC> after they type it in)
  1111.  PC> then it does:
  1112.  PC>   Hello, (red) <name>!
  1113.  
  1114.      Here are a couple SUBs from one of my first doors.  I don't use the
  1115. command parser, but I thought I'd write a quick one just to see how hard it
  1116. would be, so it may be a little rough.  I prefer using the COL sub myself.
  1117.      Anyway, here goes...
  1118. '----Start of pocal.bas----
  1119. 'ANSI.SYS must be installed
  1120. 'colour commands must be in lowercase
  1121. 'for bright colours and blink use col
  1122. DEFINT A-Z
  1123. DECLARE SUB col (A%, f%, b%)
  1124. DECLARE SUB pocal (text$, y%, Z%)
  1125. DECLARE SUB getkeys (hm%, A$)
  1126. DIM SHARED A$, modem, display, baud&, plaintext
  1127. 'A$ holds answer after a call to getkeys
  1128. plaintext = 1   '0=no ANSI
  1129. modem = 1
  1130. display = 2
  1131. baud& = 0 'not online
  1132. CLS
  1133. LOCATE , , 1 'turn cursor on
  1134. OPEN "com2:2400" FOR RANDOM AS #modem
  1135. OPEN "cons:" FOR OUTPUT AS #display
  1136. pocal "@cyanEnter your name:>@magenta", 0, 1
  1137. CALL getkeys(32, "")
  1138. pocal "", 1, 1 'CR+LF
  1139. pocal "@cyanHello @red" + A$ + "@cyan!", 1, 1
  1140. col 1, 33, 40'bright yellow on black
  1141. pocal "", 1, 1
  1142. pocal "Good bye!", 1, 1
  1143. 'simple menu
  1144. 'pocal "@greenEnter <@cyanM@green>enu,", 0, 1
  1145. 'pocal "<@cyanL@green>ook,<@cyanS@green>earch@magenta>", 0, 1
  1146. 'CALL getkeys(1, "MLS")
  1147. 'pocal "", 1, 1
  1148. 'IF A$ = "M" THEN pocal "@blueYou chose Menu", 1, 1
  1149. 'IF A$ = "L" THEN pocal "@whiteYou chose Look", 1, 1
  1150. 'IF A$ = "S" THEN pocal "@cyanYou chose Search", 1, 1
  1151. END
  1152.  
  1153. SUB col (A, f, b)
  1154. 'a=attribute:    0=all attributes off
  1155. '                1=bold on
  1156. '                5=blink on
  1157. '                7=reverse video
  1158. 'f=foreground:   30=black
  1159.  
  1160. '                31=red
  1161. '                32=green
  1162. '                33=yellow
  1163. '                34=blue
  1164. '                35=magenta
  1165. '                36=cyan
  1166. '                37=white
  1167. 'b=background    40=black
  1168. '                41=red
  1169. '                42=green
  1170. '                43=yellow
  1171. '                44=blue
  1172. '                45=magenta
  1173. '                46=cyan
  1174. '                47=white
  1175. IF plaintext = 0 THEN EXIT SUB
  1176. change$ = CHR$(27) + "[" + LTRIM$(STR$(A)) + ";"
  1177. change$ = change$ + LTRIM$(STR$(f)) + ";" + LTRIM$(STR$(b)) + "m"
  1178. IF baud& THEN                     'if online then
  1179.         CALL pocal(change$, 0, 1) 'print to modem and locally
  1180.     ELSE
  1181.         CALL pocal(change$, 0, 0) 'just print locally
  1182. END IF
  1183. END SUB
  1184. 'Continued next message
  1185.  
  1186.  
  1187. --- DLG Pro v0.995/DLGMail
  1188.  * Origin: Computer Answers, Prince Albert, Sask., Canada (1:140/601)
  1189.  
  1190.  
  1191.  
  1192. ════════════════════════════════════════════════════════════════════════════════
  1193.  Area:    QuickBasic
  1194.   Msg:    #11478
  1195.  Date:    04-01-93 00:12 (Public)
  1196.  From:    SCOTT BAILEY
  1197.  To:      PAUL CRUTCHFIELD
  1198.  Subject: pocal 2/3
  1199. ────────────────────────────────────────────────────────────────────────────────
  1200. 'Continued
  1201. SUB getkeys (hm%, pare$)
  1202. '------
  1203. 'hm%=# of chars to ask for
  1204. 'pare$=accepted chars ("" for any char)
  1205. '------
  1206. A$ = ""
  1207. back:
  1208. DO
  1209.   DO
  1210.     temp$ = INKEY$
  1211.     IF LEN(temp$) THEN EXIT DO   'local key pressed
  1212.   LOOP UNTIL LOC(modem) > 0      'chars waiting?
  1213.   IF temp$ = "" THEN             'if no local keys pressed then
  1214.     temp$ = INPUT$(LOC(modem), 1)'take all remote chars so no overflow
  1215.     temp$ = LEFT$(temp$, 1)      'accept only 1st char
  1216.   END IF
  1217.   IF temp$ = CHR$(13) AND INSTR(pare$, CHR$(13)) THEN 'CR valid?
  1218.     A$ = A$ + CHR$(13)
  1219.     EXIT SUB
  1220.   END IF
  1221.   IF temp$ = CHR$(8) AND LEN(A$) = 0 THEN GOTO back 'a$ empty-can't backup
  1222.   IF temp$ = CHR$(13) AND LEN(A$) = 0 THEN GOTO back'a$ empty-CR not valid
  1223.   IF temp$ = CHR$(13) AND LEN(A$) > 0 THEN EXIT SUB 'a$ not empty-CR exits
  1224.   IF temp$ = CHR$(8) THEN               'backspace char
  1225.       A$ = LEFT$(A$, LEN(A$) - 1)       'shorten a$
  1226.       'pocal CHR$(27) + "[D " + CHR$(27) + "[D", 0, 1 'ANSI backspace
  1227.       pocal CHR$(8) + " " + CHR$(8), 0, 1 'backspace
  1228.       GOTO back
  1229.   END IF
  1230.   IF pare$ <> "" THEN            'any keys to look for?
  1231.     temp$ = UCASE$(temp$)        'yes, change params to uppercase(if any)
  1232.     il% = INSTR(pare$, temp$)    'check if key is in pare$
  1233.     IF il% = 0 THEN A$ = "": GOTO back  'nope, get another char
  1234.   END IF
  1235. A$ = A$ + temp$
  1236. pocal temp$, 0, 1           'print locally and to modem with no CR or LF
  1237. IF LEN(A$) >= hm% THEN EXIT SUB 'reached max length so exit
  1238. LOOP
  1239. END SUB
  1240.  
  1241. SUB pocal (text$, y%, Z%)
  1242. 'text$=text to send
  1243. 'y%=add CR+LF (0=NO or 1=YES)
  1244. 'Z%=Send to modem(0=NO or 1=YES)
  1245. SHARED hm%
  1246. FOR count = 1 TO LEN(text$) STEP 4 'shortest command is 4 chars so we
  1247.     ps = INSTR(text$, "@black")    'won't miss any if we
  1248.     IF ps > 0 THEN                 'step through for speed
  1249.         text$ = LEFT$(text$, ps - 1)
  1250.         rtext$ = MID$(text$, ps + 6)
  1251.         A = 0: f = 30: b = 40
  1252.         GOSUB ansi
  1253.  
  1254.     END IF
  1255.     ps = INSTR(text$, "@red")
  1256.     IF ps > 0 THEN
  1257.         rtext$ = MID$(text$, ps + 4)
  1258.         text$ = LEFT$(text$, ps - 1)
  1259.         A = 0: f = 31: b = 40
  1260.         GOSUB ansi
  1261.     END IF
  1262.     ps = INSTR(text$, "@green")
  1263.     IF ps > 0 THEN
  1264.         rtext$ = MID$(text$, ps + 6)
  1265.         text$ = LEFT$(text$, ps - 1)
  1266.         A = 0: f = 32: b = 40
  1267.         GOSUB ansi
  1268.     END IF
  1269.     ps = INSTR(text$, "@yellow")
  1270.     IF ps > 0 THEN
  1271.         rtext$ = MID$(text$, ps + 7)
  1272.         text$ = LEFT$(text$, ps - 1)
  1273.         A = 0: f = 33: b = 40
  1274.         GOSUB ansi
  1275.     END IF
  1276.     ps = INSTR(text$, "@blue")
  1277.     IF ps > 0 THEN
  1278.         rtext$ = MID$(text$, ps + 5)
  1279.         text$ = LEFT$(text$, ps - 1)
  1280. 'Continued next message
  1281.  
  1282.  
  1283. --- DLG Pro v0.995/DLGMail
  1284.  * Origin: Computer Answers, Prince Albert, Sask., Canada (1:140/601)
  1285.  
  1286.  
  1287.  
  1288. ════════════════════════════════════════════════════════════════════════════════
  1289.  Area:    QuickBasic
  1290.   Msg:    #11479
  1291.  Date:    04-01-93 00:14 (Public)
  1292.  From:    SCOTT BAILEY
  1293.  To:      PAUL CRUTCHFIELD
  1294.  Subject: pocal 3/3
  1295. ────────────────────────────────────────────────────────────────────────────────
  1296. 'Continued
  1297.         A = 0: f = 34: b = 40
  1298.         GOSUB ansi
  1299.     END IF
  1300.     ps = INSTR(text$, "@magenta")
  1301.     IF ps > 0 THEN
  1302.         rtext$ = MID$(text$, ps + 8)
  1303.         text$ = LEFT$(text$, ps - 1)
  1304.         A = 0: f = 35: b = 40
  1305.         GOSUB ansi
  1306.     END IF
  1307.     ps = INSTR(text$, "@cyan")
  1308.     IF ps > 0 THEN
  1309.         rtext$ = MID$(text$, ps + 5)
  1310.         text$ = LEFT$(text$, ps - 1)
  1311.         A = 0: f = 36: b = 40
  1312.         GOSUB ansi
  1313.     END IF
  1314.     ps = INSTR(text$, "@white")
  1315.     IF ps > 0 THEN
  1316.         rtext$ = MID$(text$, ps + 6)
  1317.         text$ = LEFT$(text$, ps - 1)
  1318.         A = 0: f = 37: b = 40
  1319.         GOSUB ansi
  1320.     END IF
  1321. NEXT
  1322. IF y% THEN text$ = text$ + CHR$(13) + CHR$(10)
  1323. IF baud& AND Z% = 1 THEN PRINT #modem, text$;
  1324. PRINT #display, text$;
  1325. EXIT SUB
  1326. ansi:
  1327. text$ = text$ + CHR$(27) + "[" + LTRIM$(STR$(A)) + ";"
  1328. text$ = text$ + LTRIM$(STR$(f)) + ";" + LTRIM$(STR$(b)) + "m" + rtext$
  1329. RETURN
  1330. END SUB
  1331. '----End of Pocal.bas----
  1332.  
  1333.  
  1334. --- DLG Pro v0.995/DLGMail
  1335.  * Origin: Computer Answers, Prince Albert, Sask., Canada (1:140/601)
  1336.  
  1337.  
  1338.  
  1339. ════════════════════════════════════════════════════════════════════════════════
  1340.  Area:    QuickBasic
  1341.   Msg:    #11577
  1342.  Date:    03-30-93 06:42 (Public)
  1343.  From:    CHRIS TRACY
  1344.  To:      GEOFFREY LIU
  1345.  Subject: DISABLE THE PAUSE KEY
  1346. ────────────────────────────────────────────────────────────────────────────────
  1347. Well, since everyone might not have an assembler compiler, I compiled it for
  1348. the less fortunate...
  1349.  
  1350. --- Snip
  1351. CLS:?STRING$(50,178):DEFINT A-Z 'Created by PostIt! v5.1
  1352. Y$="*+,-./":FOR A=0 TO 6:P(A)=2^A:NEXT:OPEN "B",1,"NOPAUSE2.OBJ
  1353. T$="abcdefghijklmnopqrstuvwxyz":T$=T$+UCASE$(T$)+"0123456789()
  1354. G"a6*m42BWfwDZvMmUe2CTPmIF,qvDYj2BGe0CZvwBIXwzYbciwvMCZL2BUbImUatUis
  1355. G"b*LUU84Ngm42BWfwDZvMmUe2CTvaId*qPZKLc+OH4+uOuAjfa0GtpbvqvnvrY8fv
  1356. G"fHfvem0tevuoyE*iniacmqaqAjdauWxefevbrarbrvqcJ5baGe*qqbb8GLiaGbeDKupv
  1357. G"fulQjbayW)cSfJl*cc91tovewjrfaPJib*KObejOdcqae+EiLla6db*qD3OBya4Gu
  1358. G"Ac,Wcat3j4YrnnhIlmAG*4sIE+4YrjE4Wh6MeanhYhUySbeaW)4())RpaKRaSwFS
  1359. G"Shtb1mB7427IbbkEaj3J4byT1hU8Vl*Gla6db+DzaLh4YrjU4OhcaGllAb*0CiFGLl
  1360. G"gBab*WYBZzmaqmdufaXVqvaeBavbWCewfaXHqvaeBcvbq8nufaXBrvaedgvbqCBufaXYr
  1361. G"vaeVhvbGHIc+0b"
  1362. N=379:K=255:IF LEN(C$)<>506 THEN ?"Incomplete script!":END
  1363. FOR A=1 TO N:LOCATE 1:?STRING$(50/N*A,177):IF L=0 THEN GOSUB G:L=6
  1364. W=T\P(6-L):GOSUB G:W=W OR T*P(L):L=L-2:B$=CHR$(W AND K):PUT 1,,B$:NEXT
  1365. ?:IF C=11 THEN ?"Ok":END ELSE ?"Bad checksum!":END
  1366. G:I=I+1:T=INSTR(T$,MID$(C$,I,1))-1:C=(C+T)*2:C=C\256+(C AND 255):RETURN
  1367. SUB G(A$):SHARED C$,Y$:FOR Q=1 TO 6:DO:S=INSTR(A$,CHR$(Q+41))
  1368. IF S THEN A$=LEFT$(A$,S-1)+STRING$(Q+1,97)+MID$(A$,S+1)
  1369. LOOP WHILE S:NEXT:C$=C$+A$:END SUB
  1370. --- Snip
  1371.  
  1372. Welp.. there it is.. I compiled it with Turbo Assembler becuase Macro
  1373. Assembler wan't happy when I tried to compile it to an object file..
  1374.  
  1375. -chris
  1376.  
  1377. --- T.A.G. 2.6d Standard
  1378.  * Origin: DangerBase ][ Programming Staff 412-438-4101 (1:2615/4@FIDONET.ORG)
  1379.  
  1380.  
  1381.