$IF 0

This is a complete map of the program
Its made with TURBOMAP, part of the worlds most complete
automated BASIC SOURCE DOCUMENTER, TURBOFLOW! By BLOKKER &BLOKKER

Ä***ÄÄÄÄÄÄÂÄSUB S.GETVIDEOINFOÄÄÄÄSUB INTERRUPT
          ÃÄSUB S.TOGGLEBLINKBITÄÄSUB INTERRUPT
          ÃÄSUB S.CONFIGFILE
          ÃÄSUB S.DISPLAYÄÄÄÄÄÄÄÂÄGSB COLOURSINARRAY
          ³                     ÃÄGSB DRAWBOXES
          ³                     ÃÄGSB CHOOSECOLOURS
          ³                     ÃÄGSB ARRAYTOCOLOURS
          ³                     ÃÄSUB S.BOXÄÄÄÄÄÄÄÄÄÂÄSUB S.COLOUR
          ³                     ³                   ÀÄSUB S.FILLAREA
          ³                     ÃÄSUB S.FILLWITH
          ³                     ÃÄSUB S.COLOUR
          ³                     ÃÄSUB S.FILLAREA
          ³                     ÀÄGSB COLOURBOXES
          ÀÄSUB S.RESULTÄÄÄÄÄÄÄÄÂÄSUB S.COLOUR
                                ÃÄSUB S.BOXÄÄÄÄÄÄÄÄÄÂÄSUB S.COLOUR
                                ³                   ÀÄSUB S.FILLAREA
                                ÀÄSUB S.FILLAREA
Ä*** ??? ÄÄÄDEF F.KEY


Funktions :
----------
FUNCTION f.FileExists% (File$, FAttr%). . . . . . . . . . . . . . COLOURS .BAS
FUNCTION f.Key% . . . . . . . . . . . . . . . . . . . . . . . . . COLOURS .BAS

Subroutines :
-------------
SUB S.Box (Row1%, Col1%, Row2%, Col2%, FG%, BG%, Lines%, Ä> . . . COLOURS .BAS
SUB S.Colour (Fore%, Back%) . . . . . . . . . . . . . . . . . . . COLOURS .BAS
SUB S.ConfigFile (ConfigFile$, Task%) . . . . . . . . . . . . . . COLOURS .BAS
SUB S.Display . . . . . . . . . . . . . . . . . . . . . . . . . . COLOURS .BAS
SUB S.FillArea (R1%, K1%, R2%, K2%, FG%, BG%) static. . . . . . . COLOURS .BAS
SUB S.FillChar(Row1%,Col1%,Row2%,Col2%,Char%) . . . . . . . . . . COLOURS .BAS
SUB S.GetVideoInfo. . . . . . . . . . . . . . . . . . . . . . . . COLOURS .BAS
SUB S.Result (LastKey%) . . . . . . . . . . . . . . . . . . . . . COLOURS .BAS
SUB S.ToggleBlinkBit (Blinkit%) . . . . . . . . . . . . . . . . . COLOURS .BAS

Labels :
--------
Ä ArrayToColour:. . . . . . . . . . . . . . . . . . . . . . . . . COLOURS .BAS
Ä ColourBoxes:. . . . . . . . . . . . . . . . . . . . . . . . . . COLOURS .BAS
Ä ColourChoise: . . . . . . . . . . . . . . . . . . . . . . . . . COLOURS .BAS
Ä ColourInArray:. . . . . . . . . . . . . . . . . . . . . . . . . COLOURS .BAS
Ä ColourText: . . . . . . . . . . . . . . . . . . . . . . . . . . COLOURS .BAS
Ä DrawBoxes:. . . . . . . . . . . . . . . . . . . . . . . . . . . COLOURS .BAS

$endif

'
' 20-06-92. 14:22:34 Colour.BAS
'

' POWERBASIC Colour 'British spelling used to avoid conflict with
' BASIC reserved word
'
' Copyright 1992 BLOKKER+BLOKKER & Thaddy de Koning Powerbasic version
' Copyright 1992 BLOKKER+BLOKKER & Hans Lunsing QuickBasic/PDS version
' Po box 71992 - 1008 ED AMSTERDAM. TEL 31-20 - 6.42.32.75
' BBS 31-20-6.10.81.89 300-14.400 8N1
'
' AllThough Copyrighted Software, Feel free to use it as FreeWare
' But we request a donation to for example UNICEF if you find the information
' given Usefull. This is a policy for all Blokker &Blokker & de Koning
' Software for Powerbasic for published sources only.
' DISCLAIMER: The use of this program is subject ONLY TO DUTCH LAW!!
' The program is presented as is, The purpose of this program is for
' demonstration only.
' Therefore the Authors cannot take any responsability for the use of it.

'
' PowerBasic 2.00 - 2.10
' PowerBasic runtime
'
' Advanced Colorconfiguration Routines for
' 16x16 ColourS CGA EGA VGA. TEXTMODE!
' The routines are intended to be part of another program
' to support userdefined colorsettings

$STACK 1800
DEFINT A-Z
%FLAGS = 0
%AX = 1
%BX = 2
%CX = 3
%DX = 4
%SI = 5
%DI = 6
%BP = 7
%DS = 8
%ES = 9
%MDA=1
%CGA=2
%EGA=3
%MCGA=4
%VGA=5
%HERC=11
%OTHER=0
%Yes =-1
%No =0
%Blink =-1
%Bright =0
%LoadIt =-1
%SaveIt =0
%Enter =13
%Escape =27
%DownArrow =20480
%UpArrow =18432
%LeftArrow =19200
%RightArrow =19712
%ArrowHome =18176         'Futute expansion
%ArrowEnd =20224          'Future expansion
%PgUp =18688
%PgDn =20736
%TabKey =9
%ShTabKey =3840
SHARED Video.mode%
SHARED Video.Rows%
SHARED Video.cols%
SHARED Video.Page%
SHARED Video.Offs%
SHARED Video.Segment%
'
SHARED Video.CRT%
SHARED Video.Colour%
SHARED Video.Port%
'**********************************************************************
'
SHARED ScreenRows%                ' Future expansion
SHARED GFG%                       ' General Foreground
SHARED GBG%                       ' General Background
SHARED MFG%                       ' menu Foreground
SHARED MBG%                       ' menu Background
SHARED BFG%                       ' bar Foreground
SHARED BBG%                       ' bar Background

' This routine is easily adaptable to take more than three settings
'
'**********************************************************************
'
ScreenRows%=25                    'Future expansion
SCREEN 0
WIDTH 80
CALL s.GetVideoInfo               ' wich monitor ?

CALL s.ToggleBlinkBit (%Bright)
CALL s.ConfigFile ("Colour.CFG", %LoadIt)
DO
  CALL s.Display
  CALL s.Result (LastKey%)
LOOP UNTIL LastKey% = %Escape
CALL s.ConfigFile ("Colour.CFG", %SaveIt)
CALL s.ToggleBlinkBit (%Blink)
COLOR 7,0 ' bye bye
CLS
END
' That's all, Folks!
'
'**********************************************************************
'
ColourText:

DATA Black,Blue,Green,Cyan,Red,Magenta,Brown,White
DATA Grey,L.Blue,L.Green,L.Cyan,L.Red,Lila,Yellow,Br.White

'**********************************************************************
'
FUNCTION f.FileExists% (File$, FAttr%)
' Done like this for PB2.00 compatibility reasons
'
LOCAL Attribute%
LOCAL Found%
LOCAL ErrorVal%
Mask$=File$+CHR$(0)
Reg %AX, &H4E00
Reg %CX, FAttr%
Reg %ds, STRSEG(Mask$)
Reg %DX, STRPTR(Mask$)
CALL Interrupt &H21

Found% =(Reg(%Flags) AND 1) =0
IF NOT Found% THEN
  ErrorVal%= Reg (%AX)
  f.FileExists% =%No
ELSE
  f.FileExists% =%Yes
END IF
END FUNCTION

FUNCTION f.Key%
LOCAL I$
DO
  I$=INKEY$
LOOP UNTIL LEN(I$)

f.Key% =CVI(I$+CHR$(0))
END FUNCTION

SUB s.Box (Row1%, Col1%, Row2%, Col2%, FG%, BG%, Lines%, Title$)
'Nice uh, Short and generic.
LOCAL X%
LOCAL Y%
REDIM Mask$(3)
REDIM Box$(3)
LOCAL L$
LOCAL M$
LOCAL R$
'
' LOCAL R% ' include this if Cursor is important
' LOCAL K%
' R%=CSRLIN
' K%=POS(0)
IF Lines% < 0 OR Lines% > 255 THEN
  pbType% =0
ELSEIF Lines% > 9 THEN
  pbType% =9
ELSE
  pbType%= Lines%
END IF
' 0 1 2 3 4 5 6 7 8 9 t/m 255
Mask$(1)= "   ÚÄ¿ÉÍ»É͸ÕÍ»ÚÄ·ÖÄ¿ÖÄ·Õ͸"+STRING$(3,Lines%)
Mask$(2)= "   ³ ³º ºº ³³ º³ ºº ³º º³ ³"+CHR$(Lines%)+" "+CHR$(Lines%)
Mask$(3)= "   ÀÄÙÈͼÓÄÙÀĽÔͼÈ;ÓĽÔ;"+STRING$(3,Lines%)
FOR X% =1 TO 3

  L$ =MID$(Mask$(X%),pbType%*3 +1,1)
  M$ =MID$(Mask$(X%),pbType%*3 +2,1)
  R$ =MID$(Mask$(X%),pbType%*3 +3,1)
  Box$(X%) =L$+STRING$(Col2%-Col1%-1,M$)+R$
NEXT X%

' Title only if possible

IF LEN(Title$) >0 THEN
  IF LEN(Title$) <Col2%-Col1%-2 THEN
    MID$(Box$(1),(((LEN(Box$(1))+1)\2)-(LEN(Title$)+2)\2))=" "+Title$+" "
  END IF

END IF

CALL s.Colour(FG%,BG%)
LOCATE Row1%,Col1%,0
PRINT Box$(1);
FOR X% =Row1%+1 TO Row2%-1
  LOCATE X%,Col1%
  PRINT Box$(2);
NEXT X%
LOCATE X%,Col1%
PRINT Box$(3);

' Shadow only if possible

IF Col2% < 80 AND Row2% < ScreenRows% THEN
  CALL s.FillArea (Row2%+1,Col1%+1,Row2%+1,Col2%+1,8,0)
  CALL s.FillArea (Row1%+1,Col2%+1,Row2%,Col2%+1,8,0)
END IF

' LOCATE R%,K%,1     'To restore Cursor
END SUB

SUB s.ConfigFile (ConfigFile$, Task%)

LOCAL CFil%
LOCAL OK%
IF Task% = %LoadIt THEN
  IF f.FileExists%(ConfigFile$,0) THEN
    CFil% =FREEFILE
    OPEN ConfigFile$ FOR BINARY AS #CFil%
    OK% = %No
    IF LOF(CFil%) >= 6 THEN
      A$=SPACE$(6)
      GET$ #CFil%,lof(cfil%), A$
      OK% = %Yes
		FOR X% =1 TO 6
        IF ASC(MID$(A$,X%,1))>15 THEN
			 OK% = %No
          EXIT FOR
        END IF
      NEXT X%
    END IF
    CLOSE #CFil%
  END IF
  IF OK% THEN
    GFG% = ASC(MID$(A$, 1,1))
    GBG% = ASC(MID$(A$, 2,1))
    MFG% = ASC(MID$(A$, 3,1))
    MBG% = ASC(MID$(A$, 4,1))
    BFG% = ASC(MID$(A$, 5,1))
    BBG% = ASC(MID$(A$, 6,1))
  ELSE
    GFG% = 15
    GBG% = 8
    MFG% = 15
	  MBG% = 9
    BFG% = 0
    BBG% = 14
  END IF
ELSE
  A$=SPACE$(6)
  MID$(A$, 1,1) = CHR$(GFG%)
  MID$(A$, 2,1) = CHR$(GBG%)
  MID$(A$, 3,1) = CHR$(MFG%)
  MID$(A$, 4,1) = CHR$(MBG%)
  MID$(A$, 5,1) = CHR$(BFG%)
  MID$(A$, 6,1) = CHR$(BBG%)
  CFil%=FREEFILE
  OPEN ConfigFile$ FOR BINARY AS #CFil%
  PUT$ #CFil%,A$
  CLOSE #CFil%
END IF
END SUB

SUB s.Display

STATIC Col%
REDIM K%(5)
GOSUB ColourInArray

GOSUB DrawBoxes

GOSUB ColourChoise

GOSUB ArrayToColour

EXIT SUB

'**********************************************************************

ColourInArray:                   ' START GOSUB

REDIM K%(5)
K%(0) = GFG%
K%(1) = GBG%
K%(2) = MFG%
K%(3) = MBG%
K%(4) = BFG%
K%(5) = BBG%

RETURN

'**********************************************************************

ArrayToColour:

GFG% = K%(0)
GBG% = K%(1)
MFG% = K%(2)
MBG% = K%(3)
BFG% = K%(4)
BBG% = K%(5)

RETURN

'**********************************************************************

DrawBoxes:

'
CALL s.Box (1,1,25,80,15,12,2,"Display")

CALL s.FillChar (2,2,24,79,176)

CALL s.Box (3,6,5,27,GFG%,GBG%,2,"" )

CALL s.Box (3,30,5,51,MFG%,MBG%,2,"")

CALL s.Box (3,54,5,75,BFG%,BBG%,2,"")

CALL s.Colour (GFG%,GBG%)

LOCATE 4,7
PRINT " General Text "
CALL s.Colour (MFG%,MBG%)

LOCATE 4,31
PRINT " Menu Text "
CALL s.Colour (BFG%,BBG%)

LOCATE 4,55
PRINT "  Bar "
FOR X% = 0 TO 5

  CALL s.Box (6,(X%-1) MOD 2+6+(12*X%),23,(X%-1) MOD 2+16+(12*X%),15,8,1,"")

  RESTORE ColourText
  FOR Y% = 0 TO 15

    READ Colour$
    LOCATE 7+Y%,7+12*X%+1
    PRINT Colour$;
  NEXT Y%




  CALL s.FillArea (7+K%(X%),(X%-1) MOD 2+7+(12*X%),7+K%(X%),(X%-1) MOD 2+15+(12*X%),15,7)

NEXT X%





RETURN

'**********************************************************************

ColourBoxes:

CALL s.FillArea (3,6,5,27,K%(0),K%(1))

CALL s.FillArea (3,30,5,51,K%(2),K%(3))

CALL s.FillArea (3,54,5,75,K%(4),K%(5))


RETURN

'**********************************************************************

ColourChoise:

DO
  CALL s.FillArea (7+K%(Col%),(Col%-1) MOD 2+7+12*Col%,7+K%(Col%),(Col%-1) MOD 2+15+12*Col%,0,14)
  LastKey% =f.Key%
  SELECT CASE LastKey%
  CASE %Enter,%Escape
    EXIT LOOP
  CASE %DownArrow
    CALL s.FillArea (7+K%(Col%),(Col%-1) MOD 2+7+12*Col%,7+K%(Col%),(Col%-1) MOD 2+15+12*Col%,15,8)
    K%(Col%) = K%(Col%)+1
  CASE %UpArrow
    CALL s.FillArea (7+K%(Col%),(Col%-1) MOD 2+7+12*Col%,7+K%(Col%),(Col%-1) MOD 2+15+12*Col%,15,8)
    K%(Col%) =K%(Col%)-1
  CASE %RightArrow,%TabKey
    CALL s.FillArea (7+K%(Col%),(Col%-1) MOD 2+7+12*Col%,7+K%(Col%),(Col%-1) MOD 2+15+12*Col%,15,7)
    Col% =Col%+1
  CASE %LeftArrow,%ShTabKey
    CALL s.FillArea (7+K%(Col%),(Col%-1) MOD 2+7+12*Col%,7+K%(Col%),(Col%-1) MOD 2+15+12*Col%,15,7)
    Col% =Col%-1
  END SELECT
  IF Col% > 5 THEN
    Col% =0
  ELSEIF Col% < 0 THEN
    Col% =5
  END IF
  IF K%(Col%) > 15 THEN
    K%(Col%) =0
  ELSEIF K%(Col%) < 0 THEN
    K%(Col%) =15
  END IF

  GOSUB ColourBoxes
LOOP

RETURN

'**********************************************************************
END SUB


SUB s.GetVideoInfo

%Videostatus = &H40
%MonoSeg = &HB000
%ColorSeg = &HB800
%StandardRows = 25
%MonoPorts = &H3BF
Reg %AX, &HF00
CALL Interrupt &H10

Video.Mode% =(Reg(%AX) AND &HFF)
Video.Cols% =Reg(%AX)\256
Video.Page% =Reg(%BX)\256
Reg %AX, &H1130
Reg %BX, 0
Reg %DX, 0
CALL Interrupt &H10
Video.Rows% =(Reg(%DX) AND &HFF)
IF Video.Rows% THEN
  Video.Rows% = Video.Rows% + 1
ELSE 'functie niet ondersteund
  Video.Rows% = %StandardRows
END IF
Reg %AX, &H1B00
Reg %BX, 0
Buffer$ = SPACE$(64)
Reg %ES, STRSEG(Buffer$)
Reg %DI, STRPTR(Buffer$)
CALL Interrupt &H10

IF (Reg(%AX) AND &HFF) = &H1B THEN

  DEF SEG = Reg (%ES)
  adress% = Reg (%DI) +4
ELSE

  DEF SEG = %Videostatus
  adress% =&H49
END IF




Video.Offs% =256*PEEK(adress%+6)+PEEK(adress%+5)
Video.Port% =256*PEEK(adress%+27)+PEEK(adress%+26)
DEF SEG
'PC MAGAZINE - DOS Power Tools, Techniques, Tricks and Utilities -
'by Paul Somerson, Bantam Books, 1989, Page. 776.
Reg %AX, &H1200
Reg %BX, &H10
CALL Interrupt &H10

Reg %AX, &H1A00
CALL Interrupt &H10
IF (Reg (%AX) AND &HFF) =&H1A THEN
  SELECT CASE (Reg(%BX) AND &HFF)
  CASE 1
    Video.CRT% = %MDA
  CASE 2
    Video.CRT% = %CGA
  CASE 4,5
    Video.CRT% = %EGA
  CASE 7,8
    Video.CRT% = %VGA
  CASE 10 TO 12
    Video.CRT% = %MCGA
  CASE ELSE
    Video.CRT% = %OTHER
  END SELECT
  Video.Colour% = Reg(%BX)\256-1
ELSEIF ((Reg(%BX) AND &HFF) <> (Reg(%BX) AND &HFF)) THEN

  Video.CRT% = %EGA
  Video.Colour% = Reg(%BX)\256-1
ELSE

  Video.Colour% =(Video.Port% > %MonoPorts)
  IF Video.Colour% THEN
    Video.CRT% = %CGA
  ELSE
    Video.CRT% = %MDA
  END IF
END IF

IF Video.Colour% THEN
  Video.Segment% = %ColorSeg
ELSE
  Video.Segment% = %MonoSeg
END IF
END SUB

SUB s.Colour (Fore%, Back%)
LOCAL f%
LOCAL B%

IF Back% AND 8 THEN
  f% = Fore% OR 16
  B% = Back% XOR 8
ELSE

  f% = Fore%
  B% = Back%
END IF
COLOR f%,B%
END SUB

SUB s.Result (LastKey%)

CALL s.Colour( GFG%,GBG%)
CLS
CALL s.Box (1,1,3,80,MFG%,MBG%,2,"Menu" )
LOCATE 2,3
PRINT "File Edit View Search Options";
LOCATE 2,74
PRINT "Help";
CALL s.Box (4,1,25,80,GFG%,GBG%,2,"")
CALL s.Colour (GFG%,GBG%)
LOCATE 5,3
PRINT "Article : PC-Active 40.";
LOCATE 6,3
PRINT "From : juli 1992.";
LOCATE 7,3
PRINT "The Netherlands";
LOCATE 8,3
PRINT "Authors : Joop Blokker & Hans Lunsing.";
LOCATE 9,3
PRINT "Who needs blinking? If i want to draw attention i find it more usefull"
LOCATE 10,3
PRINT "to change the color attributes. Blinking only makes you very nervous, so why"
LOCATE 11,3
PRINT "not get rid of it. The technique is very simple and certainly not something"
LOCATE 12,3
PRINT "new. The 256 color routine is just a part of this set of routines, wich are"
LOCATE 13,3
PRINT "primarily intended to show userdefinable colors after compilation."
LOCATE 15,3
print "This program also contains an extensive Monitor /CRT determination Subroutine,"
LOCATE 16,3
PRINT "wich will deal with most Monitortypes except For SVGA."
LOCATE 17,3
PRINT "We use the routines even during programdevelopement to choose the colors"
LOCATE 18,3
PRINT "we like for a certain (part of an) application."
LOCATE 19,3
PRINT "We hope you will find it usefull in your programs."
LOCATE 20,3
PRINT "PowerBasic Users group the Netherlands"
LOCATE 21,3
PRINT "This program is an Authorised translation from a Q(uick)Basic program"

LOCATE 22,3
PRINT "originally developed For PC-Active By BLOKKER & BLOKKER"
LOCATE 23,3
PRINT ""
LOCATE 24,3
PRINT "";
call s.Box (4,60,10,80,MFG%,MBG%,2,"")

call s.FillArea (2,72,2,78,BFG%,BBG%)

LOCATE 5,62
PRINT "Index"
LOCATE 6,62
PRINT "Contents"
LOCATE 7,62
PRINT "How to..."
LOCATE 8,61
PRINT STRING$(18,196)
LOCATE 9,62
PRINT "Copyright."
CALL s.FillArea (6,61,6,78,BFG%,BBG%)

CALL s.Box (18,40,23,78,MFG%,MBG%,2,"")

LOCATE 19,42
PRINT "This is the result of the new"
LOCATE 20,42
PRINT "Color settings. Press Escape"
LOCATE 21,42
PRINT "to Stop or any other key"
LOCATE 22,42
PRINT "to continue"
LastKey%= f.Key%
END SUB

SUB s.ToggleBlinkBit (Blinkit%)
IF Video.Mode% > 3 THEN
  EXIT SUB
END IF
IF Video.CRT% = %CGA THEN
  ' CGA: Peter Norton's programmer's guide to
  ' "The IBM PC & PS/2", Page. 96, 39
  '
  DEF SEG =0
  IF Blinkit% THEN
    BIOSSTATUS% =(PEEK(&H465) OR &H20) 'bit 5 van 0-7 wordt 1
  ELSE
    BIOSSTATUS% =(PEEK(&H465) AND NOT &H20) 'bit 5 van 0-7 wordt 0
  END IF
  POKE &H465,BIOSSTATUS%          'update BIOS status variable
  OUT Video.Port%+4,PEEK(&H465)   'update hardware register
  DEF SEG
ELSEIF Video.CRT% > %CGA THEN

  ' Works ONLY for PCJr MCGA EGA VGA
  '
  Reg %AX, &H1003
  Reg %BX, (0-Blinkit%)         ' 0 or 1
  CALL Interrupt &H10
END IF
END SUB

SUB s.FillArea (R1%, K1%, R2%, K2%, FG%, BG%) static
LOCAL Colour%
LOCAL X%
LOCAL XX%
LOCAL Y%
Colour% = 16 * BG% + FG%
IF Video.colour% THEN
  DEF SEG = &HB800
ELSE
  DEF SEG = &HB000
END IF
FOR X% = R1% TO R2%               ' Row

  XX% = (X% - 1) * 160            ' Calculate full Rows
  FOR Y% = K1% TO K2%             ' Col

	 POKE (XX% + (Y% * 2) - 1), Colour%
  NEXT Y%
  ' poke$ x%-1,string$(k2%-k1%,chr$(Colour%))
NEXT X%
DEF SEG
END SUB

SUB s.FillChar(Row1%,Col1%,Row2%,Col2%,Char%)

LOCAL x%

FOR x% = Row1% TO Row2%

  locate x%,Col1%
  print string$(Col2%-Col1%+1,chr$(Char%));
NEXT x%
END SUB