home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / VISUAL_B / CODIGO_1 / BCC101 / DIALOG.BAS < prev    next >
Encoding:
BASIC Source File  |  1993-04-07  |  8.4 KB  |  209 lines
  1.           '''''''''''''''''''''''''''''''''''''''''''''''''''''''
  2.           '                      dialog.bas                     '
  3.           '                                                     '
  4.           '''''''''''''''''''''''''''''''''''''''''''''''''''''''
  5.           '  compile ->  bc dialog /o;                          '
  6.           '  link ->     link /e YourProg + dialog, , nul, qb;  '
  7.           '                                                     '
  8.           '''''''''''''''''''''''''''''''''''''''''''''''''''''''
  9. '
  10. '$INCLUDE: 'DIALOG.BI'
  11. '$INCLUDE: 'QB.BI'
  12.  
  13. SUB BoxDialog (Top%, BoxWidth%, Border$, Msg$, MsgClr%, Shadow%)
  14.  
  15.      Temp$ = SPACE$(BoxWidth)                   ' make a temp string
  16.      BoxTop = ASC(MID$(Border$, 2, 1))          ' value of top character
  17.      BoxBot = ASC(MID$(Border$, 7, 1))          ' value of bottom char
  18.  
  19.      IF MonCols = 0 THEN VidInfo ' obtain video segment and screen dimensions
  20.  
  21.      col = 1 + ((MonCols - BoxWidth) \ 2)       ' get left-hand column
  22.      IF col > 1 THEN col = col + (BoxWidth MOD 2) ' make em visually line up
  23.      row = Top                                  ' set starting row
  24.  
  25.      MID$(Temp$, 1, 1) = MID$(Border$, 1, 1)    ' set upper-left corner
  26.      MID$(Temp$, 2) = STRING$(BoxWidth - 1, BoxTop)  ' set top of box
  27.      MID$(Temp$, BoxWidth, 1) = MID$(Border$, 3, 1)  ' set upper-right corner
  28.  
  29.      WriteStr Temp$, row, col, MsgClr           ' write this string
  30.      row = row + 1                              ' increment row position
  31.  
  32.      IF LEN(Msg$) < BoxWidth - 4 THEN           ' Msg$ will fit in one line
  33.           LSET Temp$ = ""                        ' clear the temp string
  34.           MID$(Temp$, 1, 1) = MID$(Border$, 4, 1) ' set left-side character
  35.           MID$(Temp$, 3) = Msg$                  ' set message into temp string
  36.           MID$(Temp$, BoxWidth, 1) = MID$(Border$, 5, 1) ' set right-side char
  37.  
  38.           WriteStr Temp$, row, col, MsgClr       ' send temp string to screen
  39.           IF Shadow THEN GOSUB ShadowRight       ' shadow as called for
  40.  
  41.      ELSE                                       ' Msg$ needs to be word wrapped
  42.           begin = 0: endpos = BoxWidth - 4       ' set begin and end of area
  43.  
  44. WrapIt:
  45.           Char = ASC(MID$(Msg$, endpos, 1))      ' get one char from message
  46.  
  47.           LSET Temp$ = ""                        ' clear temp string
  48.  
  49.           IF Char <> 32 THEN                     ' if char not a space...
  50.                 SELECT CASE Char
  51.                      ' do nothing if this character is one of these-> ",-.:;"
  52.                      CASE 44, 45, 46, 58, 59        ' do nothing
  53.                      CASE ELSE
  54.                           IF endpos < LEN(Msg$) THEN ' if not at message end...
  55.                                 endpos = endpos - 1    ' decrement endpos
  56.                                 GOTO WrapIt            ' do it all over again
  57.                           END IF
  58.                 END SELECT
  59.           END IF
  60.  
  61.           tempLen = endpos - begin               ' calc length of line to display
  62.  
  63.           MID$(Temp$, 1, 1) = MID$(Border$, 4, 1) ' set left-side character
  64.  
  65.           MID$(Temp$, 3) = MID$(Msg$, begin + 1, tempLen) ' set portion of msg
  66.           tempLen = tempLen + 1                   ' increment tempLen variable
  67.  
  68.           MID$(Temp$, BoxWidth, 1) = MID$(Border$, 5, 1) ' set right-side char
  69.  
  70.           WriteStr Temp$, row, col, MsgClr        ' send temp string to screen
  71.           IF Shadow THEN GOSUB ShadowRight        ' shadow as called for
  72.  
  73.           IF begin + tempLen < LEN(Msg$) THEN     ' haven't processed all of Msg
  74.                 row = row + 1                       ' increment row position
  75.                 begin = endpos                      ' set new beginning position
  76.                 endpos = begin + BoxWidth - 4       ' set new ending position
  77.                 IF endpos > LEN(Msg$) THEN endpos = LEN(Msg$) ' oops - to far
  78.                 GOTO WrapIt                         ' do it all over again
  79.           END IF
  80.      END IF
  81.  
  82.      row = row + 1                               ' increment row position
  83.  
  84.      MID$(Temp$, 1, 1) = MID$(Border$, 6, 1)     ' set lower-left corner
  85.      MID$(Temp$, 2) = STRING$(BoxWidth - 2, BoxBot)  ' set bottom of box
  86.      MID$(Temp$, BoxWidth, 1) = MID$(Border$, 8, 1)  ' set lower-right corner
  87.  
  88.      WriteStr Temp$, row, col, MsgClr            ' send temp string to screen
  89.      IF Shadow THEN GOSUB ShadowRight            ' shadow as called for
  90.  
  91.      row = row + 1                               ' increment row position
  92.  
  93.      IF Shadow THEN                            ' shadow the line below the box
  94.           FOR begin = col + 2 TO col + BoxWidth + 1
  95.                 IF begin <= MonCols THEN DoShadow row, begin
  96.           NEXT
  97.      END IF
  98.  
  99.      EXIT SUB
  100.  
  101. ShadowRight:
  102.      IF col + BoxWidth <= MonCols THEN DoShadow row, col + BoxWidth
  103.      IF col + BoxWidth + 1 <= MonCols THEN DoShadow row, col + BoxWidth + 1
  104. RETURN
  105.  
  106. END SUB
  107.  
  108. FUNCTION ClrAttr% (fg%, bg%) STATIC
  109.  
  110.      ' (fg AND 15) removes blink from forground color
  111.      ' OR (16 * bg ...) adds background color to attribute
  112.      ' - (128 * (fg > 15)) adds blink {if any} to high bits of attribute byte
  113.  
  114.      ClrAttr% = (fg AND 15) OR (16 * bg - (128 * (fg > 15)))
  115.  
  116. END FUNCTION
  117.  
  118. SUB DoShadow (row%, col%) STATIC
  119.  
  120.      IF VidSeg = 0 THEN VidInfo   ' obtain video segment and screen dimensions
  121.  
  122.      offset = MonCols * 2 * (row - 1) + col * 2 - 1 ' get video map coordinates
  123.  
  124.      DEF SEG = VidSeg                    ' video map segment
  125.      attr = PEEK(offset) AND 15          ' get attrib and remove BG color
  126.      attr = attr + (8 * (attr > 7))      ' remove high intensity
  127.      POKE offset, attr                   ' put new color at screen location
  128.      DEF SEG                             ' back to BASIC DGROUP
  129.  
  130. END SUB
  131.  
  132. SUB VidInfo
  133.  
  134.      DIM Reg AS RegType
  135.  
  136.      Reg.ax = &HF00             ' get current display mode
  137.      INTERRUPT &H10, Reg, Reg   ' BIOS video interrupt 10h
  138.      Vmode = Reg.ax MOD 256     ' video mode returned in AL
  139.  
  140.      VidSeg = &HB800                  ' assume CGA color segment
  141.  
  142.      SELECT CASE Vmode
  143.           CASE 0 - 3, 7
  144.                 'case 0:                   ' 40x25 B&W text screen
  145.                 'case 1:                   ' 40x25 color text screen
  146.                 'case 2:                   ' 80x25 B&W text scren
  147.                 'case 3:                   ' 80x25 color text scren
  148.                 'case 7:                   ' mono adapter or EGA text screen
  149.                 IF Vmode = 7 THEN VidSeg = &HB000   ' fix segment if mono
  150.           CASE 4 - 6
  151.                 'case 4:                   ' CGA 320x200 4-color graphics
  152.                 'case 5:                   ' CGA 320x200 4-color (clr burst off)
  153.                 'case 6:                   ' CGA 640x200 2-color graphics
  154.           CASE 8
  155.                 'case 8:                   ' Hercules graphics or low res PCjr
  156.                 VidSeg = &HB000            ' seg for Herc - PCjr = ??
  157.           CASE 9 - 10
  158.                 'case 9:                   ' 320x200 16-color PCjr (seg = ??)
  159.                 'case 10:                  ' 640x200 4-color PCjr (seg = ??)
  160.           CASE 13 - 19
  161.                 'case 13:                  ' EGA 320x200 16-color graphics
  162.                 'case 14:                  ' EGA 640x200 16-color graphics
  163.                 'case 15:                  ' EGA 640x350 monochrome graphics
  164.                 'case 16:                  ' EGA 640x350 4 or 16 clr(RAM decides)
  165.                 'case 17:                  ' VGA 640x480 2-color graphics
  166.                 'case 18:                  ' VGA 640x480 16-color graphics
  167.                 'case 19:                  ' VGA 320x200 256-color graphics
  168.                 VidSeg = &HA000
  169.           CASE ELSE
  170.                 'default:                  ' unknown/unsupported mode?
  171.      END SELECT
  172.  
  173.      DEF SEG = 0                       ' ROM BIOS
  174.      MonCols = PEEK(&H44A)             ' get number of display columns
  175.      MonRows = PEEK(&H484) + 1         ' get number of display rows
  176.      DEF SEG                           ' back to BASIC DGROUP
  177.  
  178. END SUB
  179.  
  180. SUB WriteStr (A$, row%, col%, attr%) STATIC
  181.  
  182.      IF VidSeg = 0 THEN VidInfo ' obtain video segment and screen dimensions
  183.  
  184.      offset = MonCols * 2 * (row - 1) + col * 2 - 2 ' get video map coordinates
  185.  
  186.      Saddr = VARSEG(A$)      ' segment to string's location
  187.      Z = VARPTR(A$)          ' have QB give you string's descripter
  188.  
  189.      '---- Address is byte two and three of descripter (past length
  190.      '     word, bytes 0 and 1).
  191.      Soffset& = PEEK(Z + 2) + 256& * PEEK(Z + 3) ' get string's address
  192.  
  193.      FOR CharCount = 1 TO LEN(A$)     ' roll through the string
  194.           DEF SEG = Saddr              ' set segment at string's location
  195.           Char = PEEK(Soffset&)        ' get one char from string
  196.           Soffset& = Soffset& + 1      ' increment pointer into string
  197.  
  198.           DEF SEG = VidSeg             ' video map segment
  199.           POKE offset, Char            ' poke the character into map
  200.           offset = offset + 1          ' increment video map position
  201.           POKE offset, attr            ' poke the attribute into map
  202.           offset = offset + 1          ' increment video map position
  203.      NEXT
  204.  
  205.      DEF SEG                          ' back to BASIC DGROUP
  206.  
  207. END SUB
  208.  
  209.