Microsoft Programmer's Library 1.3

home *** CD-ROM | disk | FTP | other *** search

/ Microsoft Programmer's Library 1.3 / Microsoft-Programers-Library-v1.3.iso / books / bassc.db < prev next >

Wrap

Text File | 1991-03-01 | 2.0 MB | 46,339 lines

Text Truncated. Only the first 1MB is shown below. Download the file for the complete contents. %@1@%%@AH@%Microsoft BASIC (Professional Development System) Sample Code%@EH@%%@AE@% %@NL@% %@NL@% %@2@%%@AH@%BALLPSET.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\BALLPSET.BAS%@AE@%%@NL@% %@NL@% DECLARE FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom)%@NL@% %@NL@% SCREEN 2%@NL@% %@NL@% %@AB@%' Define a viewport and draw a border around it:%@AE@%%@NL@% VIEW (20, 10)-(620, 190),,1%@NL@% %@NL@% CONST PI = 3.141592653589#%@NL@% %@NL@% %@AB@%' Redefine the coordinates of the viewport with view%@AE@%%@NL@% %@AB@%' coordinates:%@AE@%%@NL@% WINDOW (-3.15, -.14)-(3.56, 1.01)%@NL@% %@NL@% %@AB@%' Arrays in program are now dynamic:%@AE@%%@NL@% %@AB@%' $DYNAMIC%@AE@%%@NL@% %@NL@% %@AB@%' Calculate the view coordinates for the top and bottom of a%@AE@%%@NL@% %@AB@%' rectangle large enough to hold the image that will be%@AE@%%@NL@% %@AB@%' drawn with CIRCLE and PAINT:%@AE@%%@NL@% WLeft = -.21%@NL@% WRight = .21%@NL@% WTop = .07%@NL@% WBottom = -.07%@NL@% %@NL@% %@AB@%' Call the GetArraySize function,%@AE@%%@NL@% %@AB@%' passing it the rectangle's view coordinates:%@AE@%%@NL@% ArraySize% = GetArraySize(WLeft, WRight, WTop, WBottom)%@NL@% %@NL@% DIM Array (1 TO ArraySize%) AS INTEGER%@NL@% %@NL@% %@AB@%' Draw and paint the circle:%@AE@%%@NL@% CIRCLE (0, 0), .18%@NL@% PAINT (0, 0)%@NL@% %@NL@% %@AB@%' Store the rectangle in Array:%@AE@%%@NL@% GET (WLeft, WTop)-(WRight, WBottom), Array%@NL@% CLS%@NL@% %@AB@%' Draw a box and fill it with a pattern:%@AE@%%@NL@% LINE (-3, .8)-(3.4, .2), , B%@NL@% Pattern$ = CHR$(126) + CHR$(0) + CHR$(126) + CHR$(126)%@NL@% PAINT (0, .5), Pattern$%@NL@% %@NL@% LOCATE 21, 29%@NL@% PRINT "Press any key to end."%@NL@% %@NL@% %@AB@%' Initialize loop variables:%@AE@%%@NL@% StepSize = .02%@NL@% StartLoop = -PI%@NL@% Decay = 1%@NL@% %@NL@% DO%@NL@% EndLoop = -StartLoop%@NL@% FOR X = StartLoop TO EndLoop STEP StepSize%@NL@% %@NL@% %@AB@% ' Each time the ball "bounces" (hits the bottom of the%@AE@%%@NL@% %@AB@% ' viewport), the Decay variable gets smaller, making%@AE@%%@NL@% %@AB@% ' the height of the next bounce smaller:%@AE@%%@NL@% Y = ABS(COS(X)) * Decay - .14%@NL@% IF Y < -.13 THEN Decay = Decay * .9%@NL@% %@NL@% %@AB@% ' Stop if key pressed or Decay less than .01:%@AE@%%@NL@% Esc$ = INKEY$%@NL@% IF Esc$ <> "" OR Decay < .01 THEN EXIT FOR%@NL@% %@NL@% %@AB@% ' Put the image on the screen. The StepSize offset is%@AE@%%@NL@% %@AB@% ' smaller than the border around the circle. Thus,%@AE@%%@NL@% %@AB@% ' each time the image moves, it erases any traces%@AE@%%@NL@% %@AB@% ' left from the previous PUT (and also erases anything%@AE@%%@NL@% %@AB@% ' else on the screen):%@AE@%%@NL@% PUT (X, Y), Array, PSET%@NL@% NEXT X%@NL@% %@NL@% %@AB@% ' Reverse direction:%@AE@%%@NL@% StepSize = -StepSize%@NL@% StartLoop = -StartLoop%@NL@% LOOP UNTIL Esc$ <> "" OR Decay < .01%@NL@% %@NL@% END%@NL@% %@NL@% FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom) STATIC%@NL@% %@NL@% %@AB@% ' Map the view coordinates passed to this function to%@AE@%%@NL@% %@AB@% ' their physical-coordinate equivalents:%@AE@%%@NL@% VLeft = PMAP(WLeft, 0)%@NL@% VRight = PMAP(WRight, 0)%@NL@% VTop = PMAP(WTop, 1)%@NL@% VBottom = PMAP(WBottom, 1)%@NL@% %@AB@%' Calculate the height and width in pixels%@AE@%%@NL@% %@AB@% ' of the enclosing rectangle:%@AE@%%@NL@% RectHeight = ABS(VBottom - VTop) + 1%@NL@% RectWidth = ABS(VRight - VLeft) + 1%@NL@% %@NL@% %@AB@% ' Calculate size in bytes of array:%@AE@%%@NL@% ByteSize = 4 + RectHeight * INT((RectWidth + 7) / 8)%@NL@% %@NL@% %@AB@% ' Array is integer, so divide bytes by two:%@AE@%%@NL@% GetArraySize = ByteSize \ 2 + 1%@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%BALLXOR.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\BALLXOR.BAS%@AE@%%@NL@% %@NL@% DECLARE FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom)%@NL@% %@NL@% SCREEN 2%@NL@% %@NL@% %@AB@%' Define a viewport and draw a border around it:%@AE@%%@NL@% VIEW (20, 10)-(620, 190), , 1%@NL@% %@NL@% CONST PI = 3.141592653589#%@NL@% %@NL@% %@AB@%' Redefine the coordinates of the viewport with view%@AE@%%@NL@% %@AB@%' coordinates:%@AE@%%@NL@% WINDOW (-3.15, -.14)-(3.56, 1.01)%@NL@% %@NL@% %@AB@%' Arrays in program are now dynamic:%@AE@%%@NL@% %@AB@%' $DYNAMIC%@AE@%%@NL@% %@NL@% %@AB@%' Calculate the view coordinates for the top and bottom of a%@AE@%%@NL@% %@AB@%' rectangle large enough to hold the image that will be%@AE@%%@NL@% %@AB@%' drawn with CIRCLE and PAINT:%@AE@%%@NL@% WLeft = -.18%@NL@% WRight = .18%@NL@% WTop = .05%@NL@% WBottom = -.05%@NL@% %@NL@% %@AB@%' Call the GetArraySize function,%@AE@%%@NL@% %@AB@%' passing it the rectangle's view coordinates:%@AE@%%@NL@% ArraySize% = GetArraySize(WLeft, WRight, WTop, WBottom)%@NL@% %@NL@% DIM Array(1 TO ArraySize%) AS INTEGER%@NL@% %@NL@% %@AB@%' Draw and paint the circle:%@AE@%%@NL@% CIRCLE (0, 0), .18%@NL@% PAINT (0, 0)%@NL@% %@NL@% %@AB@%' Store the rectangle in Array:%@AE@%%@NL@% GET (WLeft, WTop)-(WRight, WBottom), Array%@NL@% CLS%@NL@% %@AB@%' Draw a box and fill it with a pattern:%@AE@%%@NL@% LINE (-3, .8)-(3.4, .2), , B%@NL@% Pattern$ = CHR$(126) + CHR$(0) + CHR$(126) + CHR$(126)%@NL@% PAINT (0, .5), Pattern$%@NL@% %@NL@% LOCATE 21, 29%@NL@% PRINT "Press any key to end."%@NL@% %@NL@% %@AB@%' Initialize loop variables:%@AE@%%@NL@% StepSize = .02%@NL@% StartLoop = -PI%@NL@% Decay = 1%@NL@% %@NL@% DO%@NL@% EndLoop = -StartLoop%@NL@% FOR X = StartLoop TO EndLoop STEP StepSize%@NL@% Y = ABS(COS(X)) * Decay - .14%@NL@% %@NL@% %@AB@% ' The first PUT statement places the image%@AE@%%@NL@% %@AB@% ' on the screen:%@AE@%%@NL@% PUT (X, Y), Array, XOR%@NL@% %@NL@% %@AB@% ' Use an empty FOR...NEXT loop to delay%@AE@%%@NL@% %@AB@% ' the program and reduce image flicker:%@AE@%%@NL@% FOR I = 1 TO 5: NEXT I%@NL@% %@NL@% IF Y < -.13 THEN Decay = Decay * .9%@NL@% Esc$ = INKEY$%@NL@% IF Esc$ <> "" OR Decay < .01 THEN EXIT FOR%@NL@% %@NL@% %@AB@% ' The second PUT statement erases the image and%@AE@%%@NL@% %@AB@% ' restores the background:%@AE@%%@NL@% PUT (X, Y), Array, XOR%@NL@% NEXT X%@NL@% %@NL@% StepSize = -StepSize%@NL@% StartLoop = -StartLoop%@NL@% LOOP UNTIL Esc$ <> "" OR Decay < .01%@NL@% %@NL@% END%@NL@% %@AB@%' .%@AE@%%@NL@% %@AB@%' .%@AE@%%@NL@% %@AB@%' .%@AE@%%@NL@% %@NL@% FUNCTION GetArraySize (WLeft, WRight, WTop, WBottom) STATIC%@NL@% %@NL@% %@AB@% ' Map the view coordinates passed to this function to%@AE@%%@NL@% %@AB@% ' their physical-coordinate equivalents:%@AE@%%@NL@% VLeft = PMAP(WLeft, 0)%@NL@% VRight = PMAP(WRight, 0)%@NL@% VTop = PMAP(WTop, 1)%@NL@% VBottom = PMAP(WBottom, 1)%@NL@% %@AB@%' Calculate the height and width in pixels%@AE@%%@NL@% %@AB@% ' of the enclosing rectangle:%@AE@%%@NL@% RectHeight = ABS(VBottom - VTop) + 1%@NL@% RectWidth = ABS(VRight - VLeft) + 1%@NL@% %@NL@% %@AB@% ' Calculate size in bytes of array:%@AE@%%@NL@% ByteSize = 4 + RectHeight * INT((RectWidth + 7) / 8)%@NL@% %@NL@% %@AB@% ' Array is integer, so divide bytes by two:%@AE@%%@NL@% GetArraySize = ByteSize \ 2 + 1%@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%BAR.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\BAR.BAS%@AE@%%@NL@% %@NL@% %@AB@%' Define type for the titles:%@AE@%%@NL@% TYPE TitleType%@NL@% MainTitle AS STRING * 40%@NL@% XTitle AS STRING * 40%@NL@% YTitle AS STRING * 18%@NL@% END TYPE%@NL@% %@NL@% DECLARE SUB InputTitles (T AS TitleType)%@NL@% DECLARE FUNCTION DrawGraph$ (T AS TitleType, Label$(), Value!(), N%)%@NL@% DECLARE FUNCTION InputData% (Label$(), Value!())%@NL@% %@NL@% %@AB@%' Variable declarations for titles and bar data:%@AE@%%@NL@% DIM Titles AS TitleType, Label$(1 TO 5), Value(1 TO 5)%@NL@% %@NL@% CONST FALSE = 0, TRUE = NOT FALSE%@NL@% %@NL@% DO%@NL@% InputTitles Titles%@NL@% N% = InputData%(Label$(), Value())%@NL@% IF N% <> FALSE THEN%@NL@% NewGraph$ = DrawGraph$(Titles, Label$(), Value(), N%)%@NL@% END IF%@NL@% LOOP WHILE NewGraph$ = "Y"%@NL@% %@NL@% END%@NL@% %@NL@% %@AB@%' ======================== DRAWGRAPH ======================%@AE@%%@NL@% %@AB@%' Draws a bar graph from the data entered in the%@AE@%%@NL@% %@AB@%' INPUTTITLES and INPUTDATA procedures.%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% FUNCTION DrawGraph$ (T AS TitleType, Label$(), Value(), N%) STATIC%@NL@% %@NL@% %@AB@% ' Set size of graph:%@AE@%%@NL@% CONST GRAPHTOP = 24, GRAPHBOTTOM = 171%@NL@% CONST GRAPHLEFT = 48, GRAPHRIGHT = 624%@NL@% CONST YLENGTH = GRAPHBOTTOM - GRAPHTOP%@NL@% %@NL@% %@AB@% ' Calculate maximum and minimum values:%@AE@%%@NL@% YMax = 0%@NL@% YMin = 0%@NL@% FOR I% = 1 TO N%%@NL@% IF Value(I%) < YMin THEN YMin = Value(I%)%@NL@% IF Value(I%) > YMax THEN YMax = Value(I%)%@NL@% NEXT I%%@NL@% %@NL@% %@AB@% ' Calculate width of bars and space between them:%@AE@%%@NL@% BarWidth = (GRAPHRIGHT - GRAPHLEFT) / N%%@NL@% BarSpace = .2 * BarWidth%@NL@% BarWidth = BarWidth - BarSpace%@NL@% %@NL@% SCREEN 2%@NL@% CLS%@NL@% %@NL@% %@AB@% ' Draw y-axis:%@AE@%%@NL@% LINE (GRAPHLEFT, GRAPHTOP)-(GRAPHLEFT, GRAPHBOTTOM), 1%@NL@% %@NL@% %@AB@% ' Draw main graph title:%@AE@%%@NL@% Start% = 44 - (LEN(RTRIM$(T.MainTitle)) / 2)%@NL@% LOCATE 2, Start%%@NL@% PRINT RTRIM$(T.MainTitle);%@NL@% %@NL@% %@AB@% ' Annotate y-axis:%@AE@%%@NL@% Start% = CINT(13 - LEN(RTRIM$(T.YTitle)) / 2)%@NL@% FOR I% = 1 TO LEN(RTRIM$(T.YTitle))%@NL@% LOCATE Start% + I% - 1, 1%@NL@% PRINT MID$(T.YTitle, I%, 1);%@NL@% NEXT I%%@NL@% %@NL@% %@AB@% ' Calculate scale factor so labels aren't bigger than four digits:%@AE@%%@NL@% IF ABS(YMax) > ABS(YMin) THEN%@NL@% Power = YMax%@NL@% ELSE%@NL@% Power = YMin%@NL@% END IF%@NL@% Power = CINT(LOG(ABS(Power) / 100) / LOG(10))%@NL@% IF Power < 0 THEN Power = 0%@NL@% %@NL@% %@AB@% ' Scale minimum and maximum values down:%@AE@%%@NL@% ScaleFactor = 10 ^ Power%@NL@% YMax = CINT(YMax / ScaleFactor)%@NL@% YMin = CINT(YMin / ScaleFactor)%@NL@% %@AB@% ' If power isn't zero then put scale factor on chart:%@AE@%%@NL@% IF Power <> 0 THEN%@NL@% LOCATE 3, 2%@NL@% PRINT "x 10^"; LTRIM$(STR$(Power))%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Put tic mark and number for Max point on y-axis:%@AE@%%@NL@% LINE (GRAPHLEFT - 3, GRAPHTOP) -STEP(3, 0)%@NL@% LOCATE 4, 2%@NL@% PRINT USING "####"; YMax%@NL@% %@NL@% %@AB@% ' Put tic mark and number for Min point on y-axis:%@AE@%%@NL@% LINE (GRAPHLEFT - 3, GRAPHBOTTOM) -STEP(3, 0)%@NL@% LOCATE 22, 2%@NL@% PRINT USING "####"; YMin%@NL@% %@NL@% YMax = YMax * ScaleFactor ' Scale minimum and maximum back%@NL@% YMin = YMin * ScaleFactor ' up for charting calculations.%@NL@% %@NL@% %@AB@% ' Annotate x-axis:%@AE@%%@NL@% Start% = 44 - (LEN(RTRIM$(T.XTitle)) / 2)%@NL@% LOCATE 25, Start%%@NL@% PRINT RTRIM$(T.XTitle);%@NL@% %@NL@% %@AB@% ' Calculate the pixel range for the y-axis:%@AE@%%@NL@% YRange = YMax - YMin%@NL@% %@NL@% %@AB@% ' Define a diagonally striped pattern:%@AE@%%@NL@% Tile$ = CHR$(1)+CHR$(2)+CHR$(4)+CHR$(8)+CHR$(16)+CHR$(32)+CHR$(64)+CHR$(128)%@NL@% %@NL@% %@AB@% ' Draw a zero line if appropriate:%@AE@%%@NL@% IF YMin < 0 THEN%@NL@% Bottom = GRAPHBOTTOM - ((-YMin) / YRange * YLENGTH)%@NL@% LOCATE INT((Bottom - 1) / 8) + 1, 5%@NL@% PRINT "0";%@NL@% ELSE%@NL@% Bottom = GRAPHBOTTOM%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Draw x-axis:%@AE@%%@NL@% LINE (GRAPHLEFT - 3, Bottom)-(GRAPHRIGHT, Bottom)%@NL@% %@AB@% ' Draw bars and labels:%@AE@%%@NL@% Start% = GRAPHLEFT + (BarSpace / 2)%@NL@% FOR I% = 1 TO N%%@NL@% %@NL@% %@AB@% ' Draw a bar label:%@AE@%%@NL@% BarMid = Start% + (BarWidth / 2)%@NL@% CharMid = INT((BarMid - 1) / 8) + 1%@NL@% LOCATE 23, CharMid - INT(LEN(RTRIM$(Label$(I%))) / 2)%@NL@% PRINT Label$(I%);%@NL@% %@NL@% %@AB@% ' Draw the bar and fill it with the striped pattern:%@AE@%%@NL@% BarHeight = (Value(I%) / YRange) * YLENGTH%@NL@% LINE (Start%, Bottom) -STEP(BarWidth, -BarHeight), , B%@NL@% PAINT (BarMid, Bottom - (BarHeight / 2)), Tile$, 1%@NL@% %@NL@% Start% = Start% + BarWidth + BarSpace%@NL@% NEXT I%%@NL@% LOCATE 1, 1%@NL@% PRINT "New graph? ";%@NL@% DrawGraph$ = UCASE$(INPUT$(1))%@NL@% %@NL@% END FUNCTION%@NL@% %@AB@%' ======================== INPUTDATA ======================%@AE@%%@NL@% %@AB@%' Gets input for the bar labels and their values%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% FUNCTION InputData% (Label$(), Value()) STATIC%@NL@% %@NL@% %@AB@% ' Initialize the number of data values:%@AE@%%@NL@% NumData% = 0%@NL@% %@NL@% %@AB@% ' Print data-entry instructions:%@AE@%%@NL@% CLS%@NL@% PRINT "Enter data for up to 5 bars:"%@NL@% PRINT " * Enter the label and value for each bar."%@NL@% PRINT " * Values can be negative."%@NL@% PRINT " * Enter a blank label to stop."%@NL@% PRINT%@NL@% PRINT "After viewing the graph, press any key ";%@NL@% PRINT "to end the program."%@NL@% %@NL@% %@AB@% ' Accept data until blank label or 5 entries:%@AE@%%@NL@% Done% = FALSE%@NL@% DO%@NL@% NumData% = NumData% + 1%@NL@% PRINT%@NL@% PRINT "Bar("; LTRIM$(STR$(NumData%)); "):"%@NL@% INPUT ; " Label? ", Label$(NumData%)%@NL@% %@NL@% %@AB@% ' Only input value if label isn't blank:%@AE@%%@NL@% IF Label$(NumData%) <> "" THEN%@NL@% LOCATE , 35%@NL@% INPUT "Value? ", Value(NumData%)%@NL@% %@NL@% %@AB@% ' If label is blank, decrement data counter%@AE@%%@NL@% %@AB@% ' and set Done flag equal to TRUE:%@AE@%%@NL@% ELSE%@NL@% NumData% = NumData% - 1%@NL@% Done% = TRUE%@NL@% END IF%@NL@% LOOP UNTIL (NumData% = 5) OR Done%%@NL@% %@NL@% %@AB@% ' Return the number of data values input:%@AE@%%@NL@% InputData% = NumData%%@NL@% %@NL@% END FUNCTION%@NL@% %@AB@%' ====================== INPUTTITLES ======================%@AE@%%@NL@% %@AB@%' Accepts input for the three different graph titles%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% SUB InputTitles (T AS TitleType) STATIC%@NL@% SCREEN 0, 0 ' Set text screen.%@NL@% DO ' Input titles.%@NL@% CLS%@NL@% INPUT "Enter main graph title: ", T.MainTitle%@NL@% INPUT "Enter x-axis title : ", T.XTitle%@NL@% INPUT "Enter y-axis title : ", T.YTitle%@NL@% %@NL@% %@AB@% ' Check to see if titles are OK:%@AE@%%@NL@% LOCATE 7, 1%@NL@% PRINT "OK (Y to continue, N to change)? ";%@NL@% LOCATE , , 1%@NL@% OK$ = UCASE$(INPUT$(1))%@NL@% LOOP UNTIL OK$ = "Y"%@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%BIGSTRIN.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\BIGSTRIN.BAS%@AE@%%@NL@% %@NL@% %@AB@%'Define arrays which will be passed to each new level%@AE@%%@NL@% %@AB@%' of recursion.%@AE@%%@NL@% DECLARE SUB BigStrings (n%, s1$(), s2$(), s3$(), s4$())%@NL@% DEFINT A-Z%@NL@% DIM s1$(1 TO 2), s2$(1 TO 2), s3$(1 TO 2), s4$(1 TO 2)%@NL@% %@AB@%' Compute the # of 64K blocks available in far memory.%@AE@%%@NL@% n = FRE(-1) \ 65536%@NL@% CLS%@NL@% %@AB@%'Quit if not enough memory.%@AE@%%@NL@% IF n < 1 THEN%@NL@% PRINT "Not enough memory for operation."%@NL@% END%@NL@% END IF%@NL@% %@NL@% %@AB@%' Start the recursion.%@AE@%%@NL@% CALL BigStrings(n, s1$(), s2$(), s3$(), s4$())%@NL@% %@NL@% SUB BigStrings (n, s1$(), s2$(), s3$(), s4$())%@NL@% %@AB@%' Create a new array (up to 64K) for each level of recursion.%@AE@%%@NL@% DIM a$(1 TO 2)%@NL@% %@AB@%' Have n keep track of recursion level.%@AE@%%@NL@% SELECT CASE n%@NL@% %@AB@%' When at highest recusion level, process the strings.%@AE@%%@NL@% CASE 0%@NL@% PRINT s1$(1); s1$(2); s2$(1); s2$(2); s3$(1); s3$(2); s4$(1); s4$(2)%@NL@% CASE 1%@NL@% a$(1) = "Each "%@NL@% a$(2) = "word "%@NL@% s1$(1) = a$(1)%@NL@% s1$(2) = a$(2)%@NL@% CASE 2%@NL@% a$(1) = "pair "%@NL@% a$(2) = "comes "%@NL@% s2$(1) = a$(1)%@NL@% s2$(2) = a$(2)%@NL@% CASE 3%@NL@% a$(1) = "from "%@NL@% a$(2) = "separate "%@NL@% s3$(1) = a$(1)%@NL@% s3$(2) = a$(2)%@NL@% CASE 4%@NL@% a$(1) = "recursive "%@NL@% a$(2) = "procedures."%@NL@% s4$(1) = a$(1)%@NL@% s4$(2) = a$(2)%@NL@% END SELECT%@NL@% %@NL@% %@AB@%' Keep going until we're out of memory.%@AE@%%@NL@% IF n > 0 THEN%@NL@% n = n - 1%@NL@% %@AB@%' For each recursion, pass in previously created arrays.%@AE@%%@NL@% CALL BigStrings(n, s1$(), s2$(), s3$(), s4$())%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%BOOKLOOK.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\BOOKLOOK.BAS%@AE@%%@NL@% %@NL@% %@AB@%'****************************** Main Module *******************************%@AE@%%@NL@% %@AB@%'* This window contains the module-level code of BOOKLOOK.BAS, a program *%@AE@%%@NL@% %@AB@%'* used to manage the database of a hypothethical library (BOOKS.MDB). The *%@AE@%%@NL@% %@AB@%'* program requires the following additional modules: BOOKMOD1.BAS, *%@AE@%%@NL@% %@AB@%'* BOOKMOD2.BAS, and BOOKMOD3.BAS, all named in the file BOOKLOOK.MAK. The *%@AE@%%@NL@% %@AB@%'* include file BOOKLOOK.BI and the database file BOOKS.MDB must also be *%@AE@%%@NL@% %@AB@%'* accessible. The program is discussed in Chapter 10, Database Programming*%@AE@%%@NL@% %@AB@%'* with ISAM in the BASIC 7.0 Programmer's Guide. *%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'* If you do NOT have expanded memory available, you should have invoked *%@AE@%%@NL@% %@AB@%'* the PROISAM.EXE TSR as PROISAM /Ib:n, where n can be between 10-20. *%@AE@%%@NL@% %@AB@%'* The /Ib: option specifies the number of buffers ISAM needs. Higher n *%@AE@%%@NL@% %@AB@%'* values improve performance. Too few buffers, and the program will fail *%@AE@%%@NL@% %@AB@%'* with an "Out of Memory" error. However if /Ib: is set too high, there *%@AE@%%@NL@% %@AB@%'* may not be enough memory to load and run the program. If you do HAVE *%@AE@%%@NL@% %@AB@%'* expanded memory, ISAM automatically uses up to 1.2 megabytes, even if *%@AE@%%@NL@% %@AB@%'* you set Ib: to a low value. With a program the size of BOOKLOOK, use the*%@AE@%%@NL@% %@AB@%'* /Ie: option to reserve some expanded memory for QBX. This indirectly *%@AE@%%@NL@% %@AB@%'* limits the amount of expanded memory ISAM uses, but make sure ISAM gets *%@AE@%%@NL@% %@AB@%'* enough EMS for at least 15 buffers (each buffer = 2K). As a last resort,*%@AE@%%@NL@% %@AB@%'* you can start QBX with the /NOF switch to make more memory available. *%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'* BOOKLOOK manages 3 tables, BookStock, CardHolders, and BooksOut. The *%@AE@%%@NL@% %@AB@%'* data in the BookStock and CardHolders tables is displayed as forms on *%@AE@%%@NL@% %@AB@%'* screen. The user can switch between table displays by pressing "V" (for *%@AE@%%@NL@% %@AB@%'* View Other Table). Each table is defined as a separate structure. The *%@AE@%%@NL@% %@AB@%'* structure for BookStock is Books, for CardHolders it is Borrowers, and *%@AE@%%@NL@% %@AB@%'* for BooksOut it is BookStatus. Each of these is incorporated as an *%@AE@%%@NL@% %@AB@%'* element of the structure RecStruct. RecStruct also has an element of *%@AE@%%@NL@% %@AB@%'* INTEGER type called TableNum (to keep track of which table is being *%@AE@%%@NL@% %@AB@%'* displayed), and a STRING element called WhichIndex that holds the name *%@AE@%%@NL@% %@AB@%'* of the index by which the user chooses to order presentation of records.*%@AE@%%@NL@% %@AB@%'* Press F2 to see a list of procedures called by the program. *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@AB@%'$INCLUDE: 'BOOKLOOK.BI'%@AE@%%@NL@% SCREEN 0%@NL@% CLS ' TempRec is for editing and adding records%@NL@% DIM TempRec AS RecStruct ' Used only to blank out a TempRec%@NL@% DIM EmptyRec AS RecStruct ' See BOOKLOOK.BI for declaration of%@NL@% DIM BigRec AS RecStruct ' this structure and its elements%@NL@% DIM Marker(25) AS INTEGER ' Array to hold SAVEPOINT returns%@NL@% %@NL@% %@AB@%' Open the database and the BookStock, CardHolders, and BooksOut tables%@AE@%%@NL@% %@NL@% ON ERROR GOTO MainHandler%@NL@% OPEN "BOOKS.MDB" FOR ISAM Books "BookStock" AS cBookStockTableNum%@NL@% OPEN "BOOKS.MDB" FOR ISAM Borrowers "CardHolders" AS cCardHoldersTableNum%@NL@% OPEN "BOOKS.MDB" FOR ISAM BookStatus "BooksOut" AS cBooksOutTableNum%@NL@% ON ERROR GOTO 0%@NL@% %@NL@% BigRec.TableNum = cBookStockTableNum ' Decide which table to show first%@NL@% %@NL@% %@AB@% ' Since the database has multiple tables, this outer DO loop is used to%@AE@%%@NL@% %@AB@% ' reset the number associated with the table the user wants to%@AE@%%@NL@% %@AB@% ' to access, then draw the screen appropriate to that table, etc.%@AE@%%@NL@% DO%@NL@% EraseMessage ' Show the interface%@NL@% CALL DrawScreen(BigRec.TableNum)%@NL@% Checked = CheckIndex%(BigRec, TRUE) ' Show current index%@NL@% CALL Retriever(BigRec, DimN, DimP, Answer) ' Retrieve and show a record%@NL@% CALL ShowMessage(" Press V to View other table", 0)%@NL@% CALL ShowStatus(" Total records in table: ", CDBL(LOF(BigRec.TableNum)))%@NL@% %@NL@% %@AB@% ' This loop lets the user traverse BigRec.TableNum and insert, delete,%@AE@%%@NL@% %@AB@% ' or modify records.%@AE@%%@NL@% DO ' At start of each loop, show%@NL@% %@AB@% ' the user valid operations%@AE@%%@NL@% CALL Retriever(BigRec, DimN, DimP, Answer) ' and display current record%@NL@% %@NL@% STACK 4000 ' Set large stack for recursions-it%@NL@% %@AB@% ' also resets FRE(-2) to stack 4000.%@AE@%%@NL@% %@NL@% Answer% = GetInput%(BigRec) ' Find out what the user wants to do%@NL@% %@NL@% IF Answer < UNDO THEN ' Excludes UNDOALL & INVALIDKEY too%@NL@% CALL EditCheck(PendingFlag, Answer, BigRec)%@NL@% END IF%@NL@% %@NL@% SELECT CASE Answer ' Process valid user requests%@NL@% CASE QUIT%@NL@% CALL ShowMessage(" You chose Quit. So long! ", 0)%@NL@% END%@NL@% %@NL@% %@AB@% ' If user picks "N" (Next Record), MOVENEXT.%@AE@%%@NL@% %@AB@% ' CheckPosition handles end-of-file (i.e. the%@AE@%%@NL@% CASE GOAHEAD, ENDK ' position just past the last record). If EOF%@NL@% %@AB@% ' or BOF = TRUE, CheckPosition holds position%@AE@%%@NL@% MOVENEXT BigRec.TableNum%@NL@% CALL CheckPosition(BigRec, Answer, DimN, DimP)%@NL@% %@NL@% %@AB@% ' Same logic as GOAHEAD, but reversed%@AE@%%@NL@% CASE GOBACK, HOME%@NL@% %@NL@% MOVEPREVIOUS BigRec.TableNum%@NL@% CALL CheckPosition(BigRec, Answer, DimN, DimP)%@NL@% %@NL@% %@AB@% ' If user chooses "E", let him edit a field.%@AE@%%@NL@% %@AB@% ' Assign the value returned by SAVEPOINT to%@AE@%%@NL@% %@AB@% ' an array element, then update the table and%@AE@%%@NL@% %@AB@% ' show the changed field. Trap any "duplicate%@AE@%%@NL@% CASE EDITRECORD ' value for unique index" (error 86) and%@NL@% %@AB@% ' handle it. The value returned by SAVEPOINT%@AE@%%@NL@% %@AB@% ' allows rollbacks so the user can undo edits%@AE@%%@NL@% %@NL@% IF LOF(BigRec.TableNum) THEN%@NL@% IF EditField(Argument%, BigRec, Letter$, EDITRECORD, Answer%) THEN%@NL@% %@NL@% %@AB@% ' You save a sequence of savepoint identifiers in an array so%@AE@%%@NL@% %@AB@% ' you can let the user roll the state of the file back to a%@AE@%%@NL@% %@AB@% ' specific point. The returns from SAVEPOINT aren't guaranteed%@AE@%%@NL@% %@AB@% ' to be sequential.%@AE@%%@NL@% n = n + 1 ' Increment counter first so savepoint%@NL@% Marker(n) = SAVEPOINT ' is synced with array-element subscript%@NL@% %@NL@% Alert$ = "Setting Savepoint number " + STR$(Marker(n))%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% ON ERROR GOTO MainHandler%@NL@% SELECT CASE BigRec.TableNum ' Update the table being displayed%@NL@% CASE cBookStockTableNum%@NL@% UPDATE BigRec.TableNum, BigRec.Inventory%@NL@% CASE cCardHoldersTableNum%@NL@% UPDATE BigRec.TableNum, BigRec.Lendee%@NL@% END SELECT%@NL@% ON ERROR GOTO 0%@NL@% ELSE%@NL@% COMMITTRANS ' Use COMMITTRANS abort transaction if%@NL@% PendingFlag = FALSE ' the user presses ESC%@NL@% n = 0 ' Reset array counter%@NL@% END IF%@NL@% ELSE%@NL@% CALL ShowMessage("Sorry, no records in this table to edit", 0): SLEEP%@NL@% END IF%@NL@% %@AB@% ' If choice is "A", get the values the user wants%@AE@%%@NL@% %@AB@% ' in each of the fields (with AddOne). If there%@AE@%%@NL@% %@AB@% ' is no ESCAPE from the edit, INSERT the record.%@AE@%%@NL@% %@AB@% ' Trap "Duplicate value for unique index" errors%@AE@%%@NL@% %@AB@% ' and handle them in MainHandler (error 86).%@AE@%%@NL@% CASE ADDRECORD%@NL@% added = AddOne(BigRec, EmptyRec, TempRec, Answer%)%@NL@% IF added THEN%@NL@% Alert$ = "A new record assumes proper place in current index"%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% ON ERROR GOTO MainHandler%@NL@% SELECT CASE BigRec.TableNum ' Insert into table being shown%@NL@% CASE cBookStockTableNum%@NL@% INSERT BigRec.TableNum, TempRec.Inventory%@NL@% CASE cCardHoldersTableNum%@NL@% INSERT BigRec.TableNum, TempRec.Lendee%@NL@% END SELECT%@NL@% ON ERROR GOTO 0%@NL@% END IF%@NL@% TempRec = EmptyRec%@NL@% %@NL@% %@AB@% ' If choice is "D" --- prompt for confirmation.%@AE@%%@NL@% %@AB@% ' If so, delete it and show new current record.%@AE@%%@NL@% CASE TOSSRECORD%@NL@% AnyRecords = LOF(BigRec.TableNum)%@NL@% IF BigRec.TableNum = cBookStockTableNum THEN CheckedOut = GetStatus(BigRec, 0#)%@NL@% IF BigRec.TableNum = cCardHoldersTableNum THEN%@NL@% SETINDEX cBooksOutTableNum, "CardNumIndexBO"%@NL@% SEEKEQ cBooksOutTableNum, BigRec.Lendee.CardNum%@NL@% IF NOT EOF(cBooksOutTableNum) THEN CheckedOut = TRUE%@NL@% END IF%@NL@% IF AnyRecords AND CheckedOut = FALSE THEN%@NL@% Alert$ = "Press D again to Delete this record, ESC to escape"%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% DeleteIt% = GetInput%(BigRec)%@NL@% IF DeleteIt% = TOSSRECORD THEN ' Delete currently-displayed record%@NL@% DELETE BigRec.TableNum%@NL@% CALL ShowMessage("Record deleted...Press a key to continue", 0)%@NL@% ELSE%@NL@% CALL ShowMessage("Record not deleted. Press a key to continue", 0)%@NL@% CALL ShowRecord(BigRec)%@NL@% END IF%@NL@% %@AB@% ' The following code checks whether the record deleted was the last%@AE@%%@NL@% %@AB@% ' record in the index, then makes the new last record current%@AE@%%@NL@% IF EOF(BigRec.TableNum) THEN%@NL@% MOVELAST BigRec.TableNum%@NL@% END IF%@NL@% ELSE%@NL@% IF BigRec.TableNum = cBookStockTableNum THEN%@NL@% IF AnyRecords = 0 THEN Alert$ = "Sorry, no records in this table to delete"%@NL@% IF CheckedOut THEN Alert$ = "Can't delete --- this book currently checked out!"%@NL@% ELSEIF BigRec.TableNum = cCardHoldersTableNum THEN%@NL@% IF AnyRecords = 0 THEN Alert$ = "Sorry, no records in this table to delete"%@NL@% IF CheckedOut THEN Alert$ = "Can't delete --- this cardholder still has books out!"%@NL@% END IF%@NL@% CALL ShowMessage(Alert$, 0): SLEEP%@NL@% END IF%@NL@% CheckedOut = FALSE%@NL@% %@NL@% %@AB@% ' If user chooses "R", walk the fields so he%@AE@%%@NL@% %@AB@% ' can choose new index to order presentation%@AE@%%@NL@% CASE REORDER%@NL@% Letter$ = CHR$(TABKEY)%@NL@% GotOne = ChooseOrder(BigRec, EmptyRec, TempRec, Letter$, REORDER)%@NL@% %@NL@% %@AB@% ' If a choice of indexes was made, retrieve%@AE@%%@NL@% %@AB@% ' the index name, set an error trap, and try%@AE@%%@NL@% %@AB@% ' to set the index, then display new index.%@AE@%%@NL@% IF GotOne THEN%@NL@% IndexName$ = LTRIM$(RTRIM$(TempRec.WhichIndex))%@NL@% ON ERROR GOTO MainHandler%@NL@% IF IndexName$ <> "NULL" THEN ' This string is placed in%@NL@% SETINDEX BigRec.TableNum, IndexName$ ' TempRec.WhichIndex if%@NL@% ELSE ' user chooses "Default."%@NL@% SETINDEX BigRec.TableNum, "" ' "" is valid index name%@NL@% END IF 'representing NULL index%@NL@% ON ERROR GOTO 0 '(i.e. the default order)%@NL@% CALL AdjustIndex(BigRec)%@NL@% LSET TempRec = EmptyRec%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If choice is "F", first set current index%@AE@%%@NL@% CASE SEEKFIELD ' using same procedure as REORDER. Then do seek.%@NL@% %@NL@% Letter$ = CHR$(TABKEY) ' Pass TABKEY for PlaceCursor%@NL@% GotOne = ChooseOrder(BigRec, EmptyRec, TempRec, Letter$, SEEKFIELD)%@NL@% %@NL@% IF GotOne AND TEXTCOMP(TempRec.WhichIndex, "NULL") THEN%@NL@% CALL SeekRecord(BigRec, TempRec, Letter$)%@NL@% FirstLetter$ = ""%@NL@% DimN = EOF(BigRec.TableNum): DimP = BOF(BigRec.TableNum)%@NL@% END IF%@NL@% %@NL@% %@AB@% ' STATUS gets the due date of a book & displays it%@AE@%%@NL@% CASE STATUS%@NL@% IF BigRec.TableNum = cBookStockTableNum THEN%@NL@% CALL ShowStatus("", 0#) ' Explicitly type the 0%@NL@% GotIt = GetStatus(BigRec, DateToShow#) ' to avoid type mismatch%@NL@% IF GotIt THEN%@NL@% Alert$ = "Press B for information on Borrower of this book"%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% CALL ShowStatus("Due Date: ", DateToShow#)%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' LendeeProfile displays borrower of displayed book%@AE@%%@NL@% CASE BORROWER%@NL@% CALL LendeeProfile(BigRec)%@NL@% %@NL@% %@AB@% ' BooksBorrowed shows books borrowed by CardHolder%@AE@%%@NL@% CASE WHICHBOOKS%@NL@% IF Borrowed THEN CALL BooksBorrowed(BigRec)%@NL@% %@NL@% %@AB@% ' If user hits "V" cycle through displayable tables%@AE@%%@NL@% CASE OTHERTABLE%@NL@% IF BigRec.TableNum < cDisplayedTables THEN%@NL@% BigRec.TableNum = BigRec.TableNum + 1%@NL@% ELSE%@NL@% BigRec.TableNum = 1%@NL@% END IF%@NL@% EXIT DO%@NL@% %@AB@% ' If user picks "I" to check current book back in,%@AE@%%@NL@% %@AB@% ' make sure it is out, then check it back in%@AE@%%@NL@% CASE CHECKIN%@NL@% IF Borrowed THEN%@NL@% GotIt = GetStatus(BigRec, DateToShow#)%@NL@% IF DateToShow# THEN%@NL@% CALL ReturnBook(BigRec, DateToShow#)%@NL@% END IF%@NL@% END IF%@NL@% %@AB@% ' If user picks "O" to check current book out,%@AE@%%@NL@% %@AB@% ' make sure it is available, then check it out%@AE@%%@NL@% CASE CHECKOUT%@NL@% GotIt = GetStatus(BigRec, DateToShow#)%@NL@% IF DateToShow# = 0# THEN%@NL@% CALL BorrowBook(BigRec)%@NL@% ELSE%@NL@% CALL ShowMessage("Sorry, this book is already checked out...", 0)%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If user wants to Undo all or some of a series of%@AE@%%@NL@% %@AB@% ' uncommitted edits, make sure there is a pending%@AE@%%@NL@% %@AB@% ' transaction to undo, then restore the state of the%@AE@%%@NL@% %@AB@% ' file one step at a time, or altogether, depending%@AE@%%@NL@% %@AB@% ' on whether U or ^U was entered.%@AE@%%@NL@% CASE UNDO, UNDOALL%@NL@% IF PendingFlag = TRUE THEN%@NL@% IF n < 1 THEN%@NL@% CALL ShowMessage("No pending edits left to Undo...", 0)%@NL@% ELSE%@NL@% IF Answer = UNDO THEN%@NL@% Alert$ = "Restoring back to Savepoint # " + STR$(Marker(n))%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% ROLLBACK Marker(n)%@NL@% n = n - 1%@NL@% ELSE ' If it's not UNDO, it must be UNDOALL%@NL@% CALL ShowMessage("Undoing the whole last series of edits", 0)%@NL@% ROLLBACK ALL%@NL@% n = 0%@NL@% END IF%@NL@% END IF%@NL@% ELSE%@NL@% CALL ShowMessage("There are no pending edits left to Undo...", 0)%@NL@% END IF%@NL@% %@NL@% CASE INVALIDKEY ' Alert user if wrong key is pressed%@NL@% CALL ShowMessage(KEYSMESSAGE, 0)%@NL@% IF PendingFlag = TRUE THEN CALL DrawIndexBox(BigRec.TableNum, EDITRECORD)%@NL@% END SELECT%@NL@% CALL DrawHelpKeys(BigRec.TableNum)%@NL@% CALL ShowKeys(BigRec, BRIGHT + FOREGROUND, DimN, DimP)%@NL@% LOOP%@NL@% LOOP%@NL@% CLOSE%@NL@% END%@NL@% %@NL@% %@AB@%' This error handler takes care of the most common ISAM errors%@AE@%%@NL@% %@NL@% MainHandler:%@NL@% %@NL@% IF ERR = 73 THEN ' 73 = Feature unavailable%@NL@% CALL ShowMessage("You forgot to load the ISAM TSR program", 0)%@NL@% END%@NL@% ELSEIF ERR = 88 THEN ' 88 = Database inconsistent%@NL@% %@AB@% ' If you have text files corresponding to each of the tables, then%@AE@%%@NL@% %@AB@% ' MakeOver prompts for their names and creates an ISAM file from them.%@AE@%%@NL@% CALL MakeOver(BigRec)%@NL@% RESUME NEXT%@NL@% %@NL@% ELSEIF ERR = 83 THEN ' 83 = Index not found%@NL@% CALL DrawScreen(BigRec.TableNum)%@NL@% CALL ShowMessage("Unable to set the index. Need more buffers?", 0)%@NL@% RESUME NEXT%@NL@% ELSEIF ERR = 86 THEN ' 86 = Duplicate value for unique index%@NL@% %@AB@% ' Trap errors when a user tries to enter a value for the Card Number or%@AE@%%@NL@% %@AB@% ' ID fields that duplicates a value already in the table%@AE@%%@NL@% CALL DupeFixer(BigRec)%@NL@% RESUME%@NL@% ELSE%@NL@% Alert$ = "Sorry, not able to handle this error in BOOKLOOK: " + STR$(ERR)%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% END%@NL@% END IF%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The AddOne FUNCTION is called once for each field when the user wants *%@AE@%%@NL@% %@AB@%'* to add a record to the displayed table. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* BigRec RecStruct variable containing information on all tables *%@AE@%%@NL@% %@AB@%'* EmptyRec Empty record of same type as BigRec *%@AE@%%@NL@% %@AB@%'* TempRec Temporary record record of same type as BigRec *%@AE@%%@NL@% %@AB@%'* Answer Integer passed through to EditField; tells task to perform *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION AddOne (BigRec AS RecStruct, EmptyRec AS RecStruct, TempRec AS RecStruct, Answer%)%@NL@% CALL ClearEm(BigRec.TableNum, 1, 1, 1, 1, 1, 1)%@NL@% LSET TempRec = EmptyRec%@NL@% CALL ShowMessage("Enter the first field of the new record", 0)%@NL@% TempRec.TableNum = BigRec.TableNum%@NL@% Edited = EditField(Argument%, TempRec, FirstLetter$, ADDRECORD, Answer%)%@NL@% IF Edited THEN%@NL@% AddOne = -1%@NL@% ELSE%@NL@% AddOne = 0%@NL@% END IF%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The CheckPosition SUB checks the table position after the requested user*%@AE@%%@NL@% %@AB@%'* action is completed. If EOF follows a MOVENEXT or the user has chosen *%@AE@%%@NL@% %@AB@%'* MOVELAST, the Keys for Database Viewing/Editing box is updated to say *%@AE@%%@NL@% %@AB@%'* "No Next Record." If BOF follows a MOVEPREVIOUS or user has chosen a *%@AE@%%@NL@% %@AB@%'* MOVEFIRST, "No Previous Record" is displayed. *%@AE@%%@NL@% %@AB@%'* In either case, the position is held by executing MOVELAST or MOVEFIRST.*%@AE@%%@NL@% %@AB@%'* Parameters: *%@AE@%%@NL@% %@AB@%'* Big Rec User-defined type containing all table information *%@AE@%%@NL@% %@AB@%'* Answer Tells what operation retrieve results from *%@AE@%%@NL@% %@AB@%'* DimN & DimP Flags telling which menu items should be dimmed/changed *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB CheckPosition (BigRec AS RecStruct, Answer, DimN%, DimP%)%@NL@% SELECT CASE Answer%@NL@% CASE GOAHEAD, ENDK%@NL@% IF EOF(BigRec.TableNum) OR (Answer = ENDK) THEN%@NL@% CALL ShowMessage("This is the last record in this index", 0)%@NL@% DimN = TRUE: DimP = FALSE%@NL@% MOVELAST BigRec.TableNum%@NL@% ELSE ' If not EOF, turn on N%@NL@% DimN = FALSE: DimP = FALSE%@NL@% CALL EraseMessage%@NL@% END IF%@NL@% CASE GOBACK, HOME%@NL@% IF BOF(BigRec.TableNum) OR (Answer = HOME) THEN%@NL@% CALL ShowMessage("This is the first record in this index", 0)%@NL@% DimP = TRUE: DimN = FALSE%@NL@% MOVEFIRST BigRec.TableNum%@NL@% ELSE%@NL@% DimP = FALSE: DimN = FALSE%@NL@% CALL EraseMessage%@NL@% END IF%@NL@% END SELECT%@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The ChooseOrder FUNCTION calls PlaceCursor so the user can move around *%@AE@%%@NL@% %@AB@%'* the form to pick the index to set. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* BigRec BigRec has all the table information in updated form *%@AE@%%@NL@% %@AB@%'* EmptyRec EmptyRec is same template as BigRec, but fields are empty *%@AE@%%@NL@% %@AB@%'* TempRec Holds intermediate and temporary data *%@AE@%%@NL@% %@AB@%'* FirstLetter Catches letter if user starts typing during SEEKFIELD *%@AE@%%@NL@% %@AB@%'* Task Either REORDER or SEEKFIELD - passed on to PlaceCursor *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION ChooseOrder (BigRec AS RecStruct, EmptyRec AS RecStruct, TempRec AS RecStruct, FirstLetter$, Task%)%@NL@% CALL DrawTable(BigRec.TableNum)%@NL@% CALL DrawIndexBox(BigRec.TableNum, Task)%@NL@% Argument = TITLEFIELD ' Always start with first field%@NL@% TempRec = EmptyRec: TempRec.TableNum = BigRec.TableNum%@NL@% %@NL@% %@AB@% ' Pass temporary RecStruct variable so user can't trash BigRec%@AE@%%@NL@% value = PlaceCursor(Argument, TempRec, FirstLetter$, 1, Task)%@NL@% %@NL@% %@AB@% ' If the user chooses ESC, redraw everything, then exit to module level%@AE@%%@NL@% IF ASC(TempRec.WhichIndex) = 0 THEN%@NL@% CALL DrawIndexBox(BigRec.TableNum, Task)%@NL@% CALL ShowRecord(BigRec)%@NL@% CALL ShowMessage(KEYSMESSAGE, 0)%@NL@% ChooseOrder = 0%@NL@% EXIT FUNCTION%@NL@% ELSE ' Otherwise, if user makes a choice%@NL@% ChooseOrder = -1 ' of Indexes, signal success to the%@NL@% END IF ' module-level code%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'* The DupeFixer SUB is called when the tries to enter a duplicate value *%@AE@%%@NL@% %@AB@%'* for the BookStock table's IDnum column or the the CardHolders table's *%@AE@%%@NL@% %@AB@%'* CardNum column, because their indexes are Unique. The procedure prompts*%@AE@%%@NL@% %@AB@%'* the user to enter a new value. *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB DupeFixer (BigRec AS RecStruct)%@NL@% IF BigRec.TableNum = cBookStockTableNum THEN%@NL@% DO%@NL@% Alert$ = STR$(BigRec.Inventory.IDnum) + " is not unique. "%@NL@% CALL ShowMessage(Alert$, 1)%@NL@% COLOR YELLOW + BRIGHT, BACKGROUND%@NL@% INPUT "Try another number: ", TempString$%@NL@% BigRec.Inventory.IDnum = VAL(TempString$)%@NL@% LOOP UNTIL BigRec.Inventory.IDnum%@NL@% ELSEIF BigRec.TableNum = cCardHoldersTableNum THEN%@NL@% DO%@NL@% Alert$ = STR$(BigRec.Lendee.CardNum) + " is not unique. "%@NL@% CALL ShowMessage(Alert$, 1)%@NL@% COLOR YELLOW + BRIGHT, BACKGROUND%@NL@% INPUT "Try another number: ", TempString$%@NL@% BigRec.Lendee.CardNum = VAL(TempString$)%@NL@% LOOP UNTIL BigRec.Lendee.CardNum%@NL@% END IF%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END SUB%@NL@% %@NL@% %@AB@%'********************************* EditCheck SUB ***************************%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'* The EditCheck procedure monitors what the user wants to do, and if the *%@AE@%%@NL@% %@AB@%'* choice is EDITRECORD, makes sure that a transaction is begun, or if it *%@AE@%%@NL@% %@AB@%'* already has begun, continues it. If a transaction has been pending, and *%@AE@%%@NL@% %@AB@%'* the user chooses anything except EDITRECORD, then the transaction is *%@AE@%%@NL@% %@AB@%'* committed. *%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'* Parameters: *%@AE@%%@NL@% %@AB@%'* Pending A flag that indicates whether transaction is pending *%@AE@%%@NL@% %@AB@%'* Task Tells what operation the user wants to perform now *%@AE@%%@NL@% %@AB@%'* TablesRec Structure containing information about the tables *%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB EditCheck (Pending, Task, TablesRec AS RecStruct)%@NL@% %@AB@% ' First, decide if this is a new or pending transaction, or not one at all%@AE@%%@NL@% %@AB@% ' The only transaction in this program keeps edits to the current record%@AE@%%@NL@% %@AB@% ' pending until the user moves on to a new record or a new operation%@AE@%%@NL@% %@AB@% ' (for example a Reorder).%@AE@%%@NL@% SHARED n ' n is index to array of savepoint ids%@NL@% %@NL@% IF Task = EDITRECORD THEN%@NL@% IF Pending = FALSE THEN%@NL@% BEGINTRANS%@NL@% Pending = TRUE%@NL@% END IF%@NL@% ELSEIF Pending = TRUE THEN ' Equivalent to Task<>EDITRECORD AND%@NL@% COMMITTRANS ' Pending=TRUE%@NL@% Pending = FALSE%@NL@% n = 0 ' Reset array index for savepoint ids%@NL@% CALL DrawIndexBox(TablesRec.TableNum, 0)%@NL@% END IF%@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The GetInput FUNCTION takes the keystroke input by the user and returns*%@AE@%%@NL@% %@AB@%'* a constant indicating what the user wants to do. If the keystroke rep- *%@AE@%%@NL@% %@AB@%'* resents a valid operation, the choice is echoed to the screen. *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION GetInput% (BigRec AS RecStruct)%@NL@% DO%@NL@% Answer$ = INKEY$%@NL@% LOOP WHILE Answer$ = EMPTYSTRING%@NL@% IF LEN(Answer$) > 1 THEN%@NL@% RightSide = HighKeys%(Answer$)%@NL@% GetInput = RightSide%@NL@% ELSE%@NL@% SELECT CASE Answer$%@NL@% CASE "A", "a"%@NL@% CALL UserChoice(BigRec, ALINE, 7, "Add Record")%@NL@% GetInput% = ADDRECORD%@NL@% CASE "B", "b"%@NL@% IF BigRec.TableNum = cBookStockTableNum THEN%@NL@% CALL UserChoice(BigRec, WLINE, 28, "Borrower")%@NL@% GetInput% = BORROWER%@NL@% ELSE%@NL@% CALL UserChoice(BigRec, WLINE, 13, "Books Outstanding")%@NL@% GetInput% = WHICHBOOKS%@NL@% END IF%@NL@% CASE "O", "o"%@NL@% CALL UserChoice(BigRec, CLINE, 7, "Check Book Out")%@NL@% GetInput% = CHECKOUT%@NL@% CASE "I", "i"%@NL@% CALL UserChoice(BigRec, CLINE, 28, "Check In")%@NL@% GetInput% = CHECKIN%@NL@% CASE "D", "d"%@NL@% CALL UserChoice(BigRec, ALINE, 28, "Drop Record")%@NL@% GetInput% = TOSSRECORD%@NL@% CASE "N", "n"%@NL@% GetInput% = GOAHEAD%@NL@% CASE "P", "p"%@NL@% GetInput% = GOBACK%@NL@% CASE "Q", "q"%@NL@% CALL UserChoice(BigRec, ELINE, 28, "Quit")%@NL@% GetInput% = QUIT%@NL@% CASE "E", "e"%@NL@% CALL UserChoice(BigRec, ELINE, 7, "Edit Record")%@NL@% GetInput% = EDITRECORD%@NL@% CASE "F", "f"%@NL@% CALL UserChoice(BigRec, RLINE, 28, "Find Record")%@NL@% GetInput% = SEEKFIELD%@NL@% CASE "R", "r"%@NL@% CALL UserChoice(BigRec, RLINE, 7, "Reorder Records")%@NL@% GetInput% = REORDER%@NL@% CASE "V", "v"%@NL@% GetInput% = OTHERTABLE%@NL@% CASE "W", "w"%@NL@% CALL UserChoice(BigRec, WLINE, 7, "When Due Back")%@NL@% GetInput% = STATUS%@NL@% CASE CHR$(ESCAPE)%@NL@% GetInput% = ESCAPE%@NL@% CASE "U", "u"%@NL@% GetInput = UNDO ' U signals rollback request after editing%@NL@% CASE CHR$(CTRLU) ' ^U = rollback a whole series of edits%@NL@% GetInput = UNDOALL%@NL@% CASE ELSE%@NL@% GetInput% = INVALIDKEY%@NL@% BEEP%@NL@% END SELECT%@NL@% END IF%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% %@AB@%'* The HighKeys FUNCTION handles common two-byte keys input by the user. *%@AE@%%@NL@% %@AB@%'* The Answer parameter is the keystroke entered by the user. * *%@AE@%%@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% FUNCTION HighKeys (Answer AS STRING)%@NL@% SELECT CASE ASC(RIGHT$(Answer$, 1)) ' Look at code for right byte%@NL@% CASE UP%@NL@% HighKeys = GOBACK ' UP is the up-arrow key%@NL@% CASE DOWN%@NL@% HighKeys = GOAHEAD ' DOWN is the down-arrow key%@NL@% CASE HOME%@NL@% HighKeys = HOME ' etc.%@NL@% CASE ENDK%@NL@% HighKeys = ENDK%@NL@% CASE LEFT%@NL@% HighKeys = OTHERTABLE%@NL@% CASE RIGHT%@NL@% HighKeys = OTHERTABLE%@NL@% CASE PGUP%@NL@% CALL ShowMessage("You could program so PGUP moves back n records", 0): SLEEP%@NL@% HighKeys = INVALIDKEY%@NL@% CASE PGDN%@NL@% CALL ShowMessage("You could program so PGDN moves forward n records", 0): SLEEP%@NL@% HighKeys = INVALIDKEY%@NL@% CASE ELSE%@NL@% CALL ShowMessage("Sorry, that key isn't handled yet.", 0): SLEEP%@NL@% HighKeys = INVALIDKEY%@NL@% END SELECT%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'****************************** Retriever SUB ******************************%@AE@%%@NL@% %@AB@%'* The Retriever SUB retrieves records from the database file and puts *%@AE@%%@NL@% %@AB@%'* them into the appropriate recordvariable for the table being displayed. *%@AE@%%@NL@% %@AB@%'* An error trap is set in case the retrieve fails, in which case a message*%@AE@%%@NL@% %@AB@%'* is displayed. Note that if a preceding SEEKoperand fails, EOF is TRUE. *%@AE@%%@NL@% %@AB@%'* In that case, position is set to the last record, which is retrieved. *%@AE@%%@NL@% %@AB@%'* Parameters: *%@AE@%%@NL@% %@AB@%'* Big Rec User-defined type containing all table information *%@AE@%%@NL@% %@AB@%'* DimN & DimP Flags telling which menu items should be dimmed/changed *%@AE@%%@NL@% %@AB@%'* Task Tells what operation retrieve results from *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB Retriever (BigRec AS RecStruct, DimN, DimP, Task)%@NL@% STATIC PeekFlag ' Set this if user is just peeking at other table%@NL@% LOCATE , , 0 ' Turn off the cursor%@NL@% %@AB@% ' Show the user which choice was made, and whether EOF or BOF%@AE@%%@NL@% CALL ShowKeys(BigRec, FOREGROUND + BRIGHT, DimN, DimP)%@NL@% %@AB@% ' If table is empty, don't try to retrieve anything%@AE@%%@NL@% IF LOF(BigRec.TableNum) = 0 THEN%@NL@% DrawTable (BigRec.TableNum)%@NL@% CALL ShowMessage("There are no records in this table", 0): EXIT SUB%@NL@% END IF%@NL@% %@NL@% IF Task <> ENDK AND Task <> HOME THEN%@NL@% IF Task < EDITRECORD THEN ' Edit needs its%@NL@% CALL Indexbox(BigRec, CheckIndex%(BigRec, 0)) ' own prompts. Show%@NL@% ELSEIF Task > INVALIDKEY THEN ' indexbox otherwise%@NL@% IF Task <> ESC THEN CALL DrawIndexBox(BigRec.TableNum, 0)%@NL@% CALL Indexbox(BigRec, CheckIndex%(BigRec, 0))%@NL@% END IF%@NL@% END IF%@NL@% IF BOF(BigRec.TableNum) THEN MOVEFIRST (BigRec.TableNum)%@NL@% ON LOCAL ERROR GOTO LocalHandler ' Trap errors on the retrieve.%@NL@% IF NOT EOF(BigRec.TableNum) THEN ' Retrieve current record%@NL@% SELECT CASE BigRec.TableNum ' from table being displayed%@NL@% CASE cBookStockTableNum ' if EOF is not true%@NL@% RETRIEVE BigRec.TableNum, BigRec.Inventory%@NL@% CASE cCardHoldersTableNum%@NL@% RETRIEVE BigRec.TableNum, BigRec.Lendee%@NL@% END SELECT%@NL@% ELSE ' If EOF is true, set position%@NL@% MOVELAST BigRec.TableNum ' to the last record in table,%@NL@% SELECT CASE BigRec.TableNum ' then retrieve the record%@NL@% CASE cBookStockTableNum%@NL@% RETRIEVE BigRec.TableNum, BigRec.Inventory%@NL@% CASE cCardHoldersTableNum%@NL@% RETRIEVE BigRec.TableNum, BigRec.Lendee%@NL@% END SELECT%@NL@% DimN = TRUE%@NL@% END IF%@NL@% ON LOCAL ERROR GOTO 0 ' Turn off error trap%@NL@% CALL ClearEm(BigRec.TableNum, 1, 1, 1, 1, 1, 1)%@NL@% CALL ShowRecord(BigRec)%@NL@% IF Task = OTHERTABLE THEN ' If user is just peeking at the other table%@NL@% IF PeekFlag = 0 THEN ' remind him how to get back to first table%@NL@% CALL ShowMessage("Press V to return to the other table", 0)%@NL@% PeekFlag = 1%@NL@% END IF%@NL@% ELSE%@NL@% PeekFlag = 0%@NL@% END IF%@NL@% EXIT SUB%@NL@% %@NL@% LocalHandler:%@NL@% IF ERR = 85 THEN%@NL@% CALL ShowMessage("Unable to retrieve your record...", 0)%@NL@% END IF%@NL@% RESUME NEXT%@NL@% END SUB%@NL@% %@NL@% %@AB@%'********************************* SeekRecord SUB *************************%@AE@%%@NL@% %@AB@%'* SeekRecord takes the name of the user's chosen index, sets it as the *%@AE@%%@NL@% %@AB@%'* current index, then prompts the user to enter the value to seek. A *%@AE@%%@NL@% %@AB@%'* minimal editor, MakeString, gets user input. If the SEEK is on a com- *%@AE@%%@NL@% %@AB@%'* bined index, GetKeyVals is called to get the input. Input is checked *%@AE@%%@NL@% %@AB@%'* for minimal acceptability by ValuesOK. If it is OK, GetOperand is *%@AE@%%@NL@% %@AB@%'* called to let the user specify how to conduct the SEEK. *%@AE@%%@NL@% %@AB@%'* Parameters: *%@AE@%%@NL@% %@AB@%'* TablesRec Contains current record information for all tables *%@AE@%%@NL@% %@AB@%'* TempRec Contains the name of the index on which to seek (in *%@AE@%%@NL@% %@AB@%'* TempRec.WhichIndex element) *%@AE@%%@NL@% %@AB@%'* Letter$ If the user starts typing instead of pressing ENTER *%@AE@%%@NL@% %@AB@%'* Letter$ catches the keystroke, passes it to MakeString *%@AE@%%@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% SUB SeekRecord (TablesRec AS RecStruct, TempRec AS RecStruct, Letter$)%@NL@% DIM EmptyRec AS RecStruct ' Make an empty record.%@NL@% IF LEFT$(Letter$, 1) < " " THEN ' Exit if value is not a valid%@NL@% %@AB@% ' character, then redraw%@AE@%%@NL@% CALL DrawIndexBox(TablesRec.TableNum, SEEKFIELD)%@NL@% CALL Indexbox(TablesRec, CheckIndex%(TablesRec, TRUE))%@NL@% CALL ShowMessage("You must enter a valid string or numeric value", 0)%@NL@% EXIT SUB%@NL@% END IF%@NL@% TheTable = TablesRec.TableNum%@NL@% IndexName$ = RTRIM$(TempRec.WhichIndex)%@NL@% IF GETINDEX$(TheTable) <> IndexName$ THEN ' If index to seek on is not%@NL@% ON LOCAL ERROR GOTO SeekHandler ' current, set it now. Trap%@NL@% SETINDEX TheTable, IndexName$ ' possible failure of SETINDEX%@NL@% ON LOCAL ERROR GOTO 0 ' then turn off error trap.%@NL@% END IF%@NL@% CALL AdjustIndex(TablesRec) ' Show the current index%@NL@% TablesRec.WhichIndex = TempRec.WhichIndex%@NL@% TempRec = EmptyRec ' Clear TempRec for data%@NL@% TempRec.TableNum = TablesRec.TableNum%@NL@% %@AB@% ' Get the value to SEEK for from the user. The data type you assign the%@AE@%%@NL@% %@AB@% ' input to must be the same as the data in the database, so get it as a%@AE@%%@NL@% %@AB@% ' string with MakeString, then convert it to proper type for index. If%@AE@%%@NL@% %@AB@% ' the index is the combined index BigIndex, use GetKeyVals for input...%@AE@%%@NL@% %@NL@% SELECT CASE RTRIM$(LTRIM$(IndexName$))%@NL@% CASE "TitleIndexBS", "AuthorIndexBS", "PubIndexBS", "NameIndexCH", "StateIndexCH"%@NL@% Prompt$ = "Value To Seek: "%@NL@% Key1$ = MakeString$(ASC(Letter$), Prompt$): IF Key1$ = "" THEN EXIT SUB%@NL@% CASE "IDIndex", "CardNumIndexCH", "ZipIndexCH"%@NL@% ValueToSeek$ = MakeString$(ASC(Letter$), Prompt$)%@NL@% IF ValueToSeek$ = "" THEN EXIT SUB%@NL@% IF IndexName$ = "IDIndex" THEN%@NL@% NumberToSeek# = VAL(ValueToSeek$)%@NL@% Key1$ = ValueToSeek$%@NL@% ELSE%@NL@% NumberToSeek& = VAL(ValueToSeek$)%@NL@% Key1$ = ValueToSeek$%@NL@% END IF%@NL@% CASE "BigIndex"%@NL@% CALL GetKeyVals(TempRec, Key1$, Key2$, Key3#, Letter$)%@NL@% ValueToSeek$ = STR$(Key3#)%@NL@% CASE ""%@NL@% Alert$ = "Sorry, can't search for field values on the default index"%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% CASE ELSE%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Make sure the input values are minimally acceptable%@AE@%%@NL@% %@NL@% IF NOT ValuesOK(TablesRec, Key1$, Key2$, ValueToSeek$) THEN%@NL@% CALL ShowMessage("Sorry, problem with your entry. Try again!", 0)%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Show the user the values he entered in their appropriate fields%@AE@%%@NL@% CALL ClearEm(TablesRec.TableNum, 1, 1, 1, 1, 1, 1)%@NL@% CALL ShowIt(TempRec, IndexName$, TheTable, Key1$)%@NL@% %@NL@% %@AB@% ' GetOperand lets user specify the way the SEEK is to be conducted ---%@AE@%%@NL@% %@AB@% ' either =, >, >=, <, or <= the value that was entered above%@AE@%%@NL@% %@NL@% DidIt = GetOperand%(Operand$)%@NL@% %@NL@% %@AB@% ' The actual SEEK has to be done according to two factors, the Index on%@AE@%%@NL@% %@AB@% ' which it is conducted, and the condition chosen in GetOperand. In the%@AE@%%@NL@% %@AB@% ' next section, case on the Operand returned, then IF and ELSEIF on the%@AE@%%@NL@% %@AB@% ' basis of the index on which the search is being conducted%@AE@%%@NL@% %@NL@% IF Operand$ <> "<>" THEN ' "<>" represents user ESC choice%@NL@% %@NL@% SELECT CASE Operand$%@NL@% CASE "", "=" ' If operand ="" or "=", use =%@NL@% IF IndexName$ = "BigIndex" THEN%@NL@% IF INSTR(Key2$, ",") = 0 THEN Key2$ = TransposeName(Key2$) ' a name%@NL@% SEEKEQ TheTable, Key1$, Key2$, Key3#%@NL@% ELSEIF IndexName$ = "NameIndexCH" OR IndexName$ = "AuthorIndexBS" THEN%@NL@% IF INSTR(Key1$, ",") = 0 THEN Key1$ = TransposeName(Key1$) ' a name%@NL@% SEEKEQ TheTable, LTRIM$(RTRIM$(Key1$))%@NL@% ELSEIF IndexName$ = "IDIndex" THEN%@NL@% SEEKEQ TheTable, NumberToSeek#%@NL@% ELSEIF IndexName$ = "CardNumIndexCH" OR IndexName$ = "ZipIndexCH" THEN%@NL@% SEEKEQ TheTable, NumberToSeek&%@NL@% ELSE%@NL@% SEEKEQ TheTable, Key1$%@NL@% END IF%@NL@% CASE ">=" ' at least gets them close%@NL@% IF IndexName$ = "BigIndex" THEN%@NL@% IF INSTR(Key2$, ",") = 0 THEN Key2$ = TransposeName(Key2$) ' a name%@NL@% SEEKGE TheTable, Key1$, Key2$, Key3#%@NL@% ELSEIF IndexName$ = "NameIndexCH" OR IndexName$ = "AuthorIndexBS" THEN%@NL@% IF INSTR(Key1$, ",") = 0 THEN Key1$ = TransposeName(Key1$)%@NL@% SEEKGE TheTable, Key1$%@NL@% ELSEIF IndexName$ = "IDIndex" THEN%@NL@% SEEKGE TheTable, NumberToSeek#%@NL@% ELSEIF IndexName$ = "CardNumIndexCH" OR IndexName$ = "ZipIndexCH" THEN%@NL@% SEEKGE TheTable, NumberToSeek&%@NL@% ELSE%@NL@% SEEKGE TheTable, Key1$%@NL@% END IF%@NL@% CASE ">"%@NL@% IF IndexName$ = "BigIndex" THEN%@NL@% IF INSTR(Key2$, ",") = 0 THEN Key2$ = TransposeName(Key2$)%@NL@% SEEKGT TheTable, Key1$, Key2$, Key3#%@NL@% ELSEIF IndexName$ = "NameIndexCH" OR IndexName$ = "AuthorIndexBS" THEN%@NL@% IF INSTR(Key1$, ",") = 0 THEN Key1$ = TransposeName(Key1$)%@NL@% SEEKGT TheTable, Key1$%@NL@% ELSEIF IndexName$ = "IDIndex" THEN%@NL@% SEEKGT TheTable, NumberToSeek#%@NL@% ELSEIF IndexName$ = "CardNumIndexCH" OR IndexName$ = "ZipIndexCH" THEN%@NL@% SEEKGT TheTable, NumberToSeek&%@NL@% ELSE%@NL@% SEEKGT TheTable, Key1$%@NL@% END IF%@NL@% CASE "<="%@NL@% IF IndexName$ = "BigIndex" THEN%@NL@% IF INSTR(Key2$, ",") = 0 THEN Key2$ = TransposeName(Key2$)%@NL@% SEEKGT TheTable, Key1$, Key2$, Key3#%@NL@% MOVEPREVIOUS TheTable%@NL@% ELSEIF IndexName$ = "NameIndexCH" OR IndexName$ = "AuthorIndexBS" THEN%@NL@% IF INSTR(Key1$, ",") = 0 THEN Key1$ = TransposeName(Key1$)%@NL@% SEEKGT TheTable, Key1$%@NL@% MOVEPREVIOUS TheTable%@NL@% ELSEIF IndexName$ = "IDIndex" THEN%@NL@% SEEKGT TheTable, NumberToSeek#%@NL@% MOVEPREVIOUS TheTable%@NL@% ELSEIF IndexName$ = "CardNumIndexCH" OR IndexName$ = "ZipIndexCH" THEN%@NL@% SEEKGT TheTable, NumberToSeek&%@NL@% MOVEPREVIOUS TheTable%@NL@% ELSE%@NL@% SEEKGT TheTable, Key1$%@NL@% MOVEPREVIOUS TheTable%@NL@% END IF%@NL@% CASE "<"%@NL@% IF IndexName$ = "BigIndex" THEN%@NL@% IF INSTR(Key2$, ",") = 0 THEN Key2$ = TransposeName(Key2$)%@NL@% SEEKGE TheTable, Key1$, Key2$, Key3#%@NL@% MOVEPREVIOUS TheTable%@NL@% ELSEIF IndexName$ = "NameIndexCH" OR IndexName$ = "AuthorIndexBS" THEN%@NL@% IF INSTR(Key1$, ",") = 0 THEN Key1$ = TransposeName(Key1$)%@NL@% SEEKGE TheTable, Key1$%@NL@% MOVEPREVIOUS TheTable%@NL@% ELSEIF IndexName$ = "IDIndex" THEN%@NL@% SEEKGE TheTable, NumberToSeek#%@NL@% MOVEPREVIOUS TheTable%@NL@% ELSEIF IndexName$ = "CardNumIndexCH" OR IndexName$ = "ZipIndexCH" THEN%@NL@% SEEKGE TheTable, NumberToSeek&%@NL@% MOVEPREVIOUS TheTable%@NL@% ELSE%@NL@% SEEKGE TheTable, Key1$%@NL@% MOVEPREVIOUS TheTable%@NL@% END IF%@NL@% CASE ELSE%@NL@% Alert$ = "The returned operand was " + Operand$%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% SLEEP%@NL@% END SELECT%@NL@% ELSE ' If they choose ESC, go back to module level%@NL@% CALL DrawScreen(TheTable)%@NL@% CALL ShowRecord(TablesRec)%@NL@% Alert$ = "You've escaped. " + KEYSMESSAGE%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% SLEEP%@NL@% Operand$ = ""%@NL@% END IF%@NL@% CALL EraseMessage%@NL@% CALL DrawScreen(TheTable)%@NL@% CALL Indexbox(TablesRec, CheckIndex%(TablesRec, FALSE))%@NL@% IF EOF(TablesRec.TableNum) THEN%@NL@% Alert$ = "Sorry, unable to match value you entered with any field value"%@NL@% CALL ShowMessage(Alert$, 0): ' SLEEP: EraseMessage%@NL@% END IF%@NL@% %@NL@% EXIT SUB%@NL@% %@NL@% SeekHandler:%@NL@% IF ERR = 83 THEN ' 83 = Index not found%@NL@% CALL DrawScreen(TablesRec.TableNum)%@NL@% Alert$ = "SETINDEX for " + IndexName$ + " failed. Need more buffers?"%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% END SUB ' End of SeekRecord procedure%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%BOOKMOD1.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\BOOKMOD1.BAS%@AE@%%@NL@% %@NL@% %@AB@%'***********************************************************************%@AE@%%@NL@% %@AB@%'* This is module level code for BOOKMOD2.BAS, and contains screen*%@AE@%%@NL@% %@AB@%'* drawing and user interface maintenance routines. This module *%@AE@%%@NL@% %@AB@%'* doesn't contain ISAM statements. *%@AE@%%@NL@% %@AB@%'***********************************************************************%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@AB@%'$INCLUDE: 'booklook.bi'%@AE@%%@NL@% KeysBox:%@NL@% DATA "╔══════════════════════════════════════╗"%@NL@% DATA "║ ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ ║"%@NL@% DATA "╚═╡ Keys for Database Viewing/Editing ╞╝"%@NL@% %@NL@% HelpKeys1:%@NL@% DATA ""%@NL@% DATA "N = Next Record P = Previous "%@NL@% DATA "R = Reorder Records F = Find Record"%@NL@% DATA "W = When Due Back B = Borrower "%@NL@% DATA " V = View Other Table "%@NL@% DATA "A = Add Record D = Drop Record"%@NL@% DATA "E = Edit Record Q = Quit "%@NL@% DATA "O = Check Book Out I = Check In "%@NL@% DATA ""%@NL@% %@NL@% HelpKeys2:%@NL@% DATA ""%@NL@% DATA "N = Next Record P = Previous "%@NL@% DATA "R = Reorder Records F = Find Record"%@NL@% DATA " B = Books Outstanding "%@NL@% DATA " V = View Other Table "%@NL@% DATA "A = Add Record D = Drop Record"%@NL@% DATA "E = Edit Record Q = Quit "%@NL@% DATA " "%@NL@% DATA ""%@NL@% %@NL@% Indexbox1:%@NL@% DATA "╔═══════════════════════════╗"%@NL@% DATA "║ By Titles ║"%@NL@% DATA "║ By Authors ║"%@NL@% DATA "║ By Publishers ║"%@NL@% DATA "║ By ID numbers ║"%@NL@% DATA "║ By Title + Author + ID ║"%@NL@% DATA "║ Default = Insertion order ║"%@NL@% DATA "║ ║"%@NL@% DATA "╚═╡ Current Sorting Order ╞═╝"%@NL@% Indexbox2:%@NL@% DATA "╔═══════════════════════════╗"%@NL@% DATA "║ By Name ║"%@NL@% DATA "║ By State ║"%@NL@% DATA "║ By Zip code ║"%@NL@% DATA "║ By Card number ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ Default = Insertion order ║"%@NL@% DATA "║ ║"%@NL@% DATA "╚═╡ Current Sorting Order ╞═╝"%@NL@% %@NL@% %@NL@% BooksTable:%@NL@% DATA "╔════════════════════════════════════════════════════════════════════╗"%@NL@% DATA "║ ║"%@NL@% DATA "║ Title: ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ Author: ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ Publisher: ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ Edition: ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ Price: ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ ID number: ║"%@NL@% DATA "╚════════════════════════════════════════════════════════════════════╝"%@NL@% %@NL@% %@NL@% LendeesTable:%@NL@% DATA "╔════════════════════════════════════════════════════════════════════╗"%@NL@% DATA "║ ║"%@NL@% DATA "║ Name: ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ Street: ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ City: ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ State: ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ Zipcode: ║"%@NL@% DATA "║ ║"%@NL@% DATA "║ Card number: ║"%@NL@% DATA "╚════════════════════════════════════════════════════════════════════╝"%@NL@% %@NL@% OperandBox:%@NL@% DATA "╔═══════════════════════════╗"%@NL@% DATA "║ ║"%@NL@% DATA "║ Greater Than ║"%@NL@% DATA "║ or ║"%@NL@% DATA "║ Equal To Value Entered║"%@NL@% DATA "║ or ║"%@NL@% DATA "║ Less Than ║"%@NL@% DATA "║ ║"%@NL@% DATA "╚══╡ Relationship to Key ╞══╝"%@NL@% %@NL@% EditMessage:%@NL@% DATA "╔═══════════════════════════╗"%@NL@% DATA "║ A log is being kept while ║"%@NL@% DATA "║ you edit fields in this ║"%@NL@% DATA "║ record. Press U to undo ║"%@NL@% DATA "║ each preceding edit, or ║"%@NL@% DATA "║ CTRL+U to undo all of the ║"%@NL@% DATA "║ pending edits as a group. ║"%@NL@% DATA "║ ║"%@NL@% DATA "╚═════╡ To Undo Edits ╞═════╝"%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The ClearEm SUB erases the parts of the screen where table record col- *%@AE@%%@NL@% %@AB@%'* umn information is displayed, depending on which fields are specified. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TableNum Integer specifying the table being displayed *%@AE@%%@NL@% %@AB@%'* Field? Boolean values specifying which fields to erase *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB ClearEm (TableNum%, Field1%, Field2%, Field3%, Field4%, Field5%, Field6%)%@NL@% %@NL@% DIM ToClear(10) AS INTEGER%@NL@% %@NL@% ToClear(0) = Field1: ToClear(1) = Field2: ToClear(2) = Field3%@NL@% ToClear(3) = Field4: ToClear(4) = Field5: ToClear(5) = Field6%@NL@% %@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% %@NL@% FOR Index = 0 TO 5%@NL@% IF ToClear(Index) THEN%@NL@% SELECT CASE Index%@NL@% CASE 0%@NL@% LOCATE TITLEFIELD, 18%@NL@% PRINT " "%@NL@% CASE 1%@NL@% LOCATE AUTHORFIELD, 18%@NL@% PRINT " "%@NL@% CASE 2%@NL@% LOCATE PUBFIELD, 18%@NL@% PRINT " "%@NL@% CASE 3%@NL@% LOCATE EDFIELD, 18%@NL@% PRINT " "%@NL@% CASE 4%@NL@% IF TableNum% = cCardHoldersTableNum THEN%@NL@% LOCATE PRICEFIELD, 18%@NL@% PRINT " "%@NL@% ELSE%@NL@% LOCATE PRICEFIELD, 19%@NL@% PRINT " "%@NL@% END IF%@NL@% CASE 5%@NL@% LOCATE IDFIELD, 18%@NL@% PRINT " "%@NL@% END SELECT%@NL@% END IF%@NL@% NEXT Index%@NL@% END SUB%@NL@% %@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% %@AB@%'* The ConfirmEntry FUNCTION echoes the user's input and processes his *%@AE@%%@NL@% %@AB@%'* response to make sure the proper action is taken. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* Letter$ Contains the input that the user has just entered. *%@AE@%%@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% FUNCTION ConfirmEntry% (Letter$)%@NL@% Alert$ = "Press ENTER to confirm choice, type value, or TAB to move on"%@NL@% CALL ShowMessage(Alert$, 1)%@NL@% DO%@NL@% Answer$ = INKEY$%@NL@% LOOP WHILE Answer$ = EMPTYSTRING%@NL@% Reply% = ASC(Answer$)%@NL@% %@NL@% SELECT CASE Reply%%@NL@% CASE ENTER%@NL@% ConfirmEntry% = -1%@NL@% Letter$ = ""%@NL@% CASE TABKEY%@NL@% ConfirmEntry% = 0%@NL@% Letter$ = Answer$%@NL@% CASE ASC(" ") TO ASC("~")%@NL@% Letter$ = Answer$%@NL@% ConfirmEntry = -1%@NL@% CASE ELSE%@NL@% ConfirmEntry% = 0%@NL@% Letter$ = "eScApE"%@NL@% CALL ShowMessage("Invalid key --- Try again", 0)%@NL@% END SELECT%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The DrawHelpBoox SUB draws the menu box that links a key to a task. *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB DrawHelpBox%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% RESTORE KeysBox%@NL@% FOR Row = BOXTOP TO BOXEND%@NL@% LOCATE Row, 1%@NL@% READ Temp$%@NL@% PRINT Temp$%@NL@% IF Row = BOXEND THEN%@NL@% COLOR BACKGROUND, FOREGROUND + BRIGHT%@NL@% LOCATE Row, HELPCOL + 3%@NL@% PRINT " Keys for Database Viewing/Editing "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END IF%@NL@% NEXT Row%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The DrawHelpKeys SUB refills the menu box that links a key to a task.*%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TableNum Integer identifying the table being displayed *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB DrawHelpKeys (TableNum AS INTEGER)%@NL@% %@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% IF TableNum = cBookStockTableNum THEN RESTORE HelpKeys1 ELSE RESTORE HelpKeys2%@NL@% FOR Row = BOXTOP TO BOXEND%@NL@% LOCATE Row, HELPCOL + 2%@NL@% READ Temp$%@NL@% PRINT Temp$%@NL@% IF Row = BOXEND THEN%@NL@% COLOR BACKGROUND, FOREGROUND + BRIGHT%@NL@% LOCATE Row, HELPCOL + 3%@NL@% PRINT " Keys for Database Viewing/Editing "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END IF%@NL@% NEXT Row%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The DrawIndexBox procedure draws the appropriate index box, depending *%@AE@%%@NL@% %@AB@%'* the table being displayed. If the task is EDITRECORD, the index box *%@AE@%%@NL@% %@AB@%'* information is replaced with information about Undo and Undo All *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TableNum Integer identifying the table being displayed *%@AE@%%@NL@% %@AB@%'* Task Integer identifying the task the user is involved in *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB DrawIndexBox (TableNum AS INTEGER, Task%)%@NL@% %@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% %@NL@% IF Task = EDITRECORD THEN%@NL@% RESTORE EditMessage%@NL@% ELSE%@NL@% IF TableNum = 1 THEN RESTORE Indexbox1 ELSE RESTORE Indexbox2%@NL@% END IF%@NL@% %@NL@% FOR Row = BOXTOP TO BOXEND%@NL@% LOCATE Row, 42%@NL@% READ Temp$%@NL@% PRINT Temp$%@NL@% IF Row = BOXEND THEN%@NL@% IF Task = EDITRECORD THEN%@NL@% COLOR FOREGROUND + BRIGHT, BACKGROUND%@NL@% LOCATE 19, INDBOX + 16%@NL@% PRINT "U"%@NL@% LOCATE 21, INDBOX + 2%@NL@% PRINT "CTRL+U"%@NL@% LOCATE Row, INDBOX + 7%@NL@% PRINT " To Undo Edits "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% ELSE%@NL@% COLOR BACKGROUND, FOREGROUND + BRIGHT%@NL@% LOCATE Row, INDBOX + 3%@NL@% PRINT " Current Sorting Order "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END IF%@NL@% END IF%@NL@% NEXT Row%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The DrawScreen SUB calls other procedures to draw the appropriate parts*%@AE@%%@NL@% %@AB@%'* of the screen for the table to be displayed. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TableNum Integer telling which table is to be shown *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB DrawScreen (TableNum AS INTEGER)%@NL@% CALL DrawTable(TableNum)%@NL@% CALL DrawHelpBox%@NL@% CALL DrawHelpKeys(TableNum)%@NL@% CALL DrawIndexBox(TableNum, Task)%@NL@% CALL ShowMessage("", 0)%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The DrawTable SUB draws and lables the table being displayed. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TableNum The number of the table currently being displayed *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB DrawTable (TableNum AS INTEGER)%@NL@% CALL ClearEm(TableNum, 1, 1, 1, 1, 1, 1)%@NL@% VIEW PRINT%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% SELECT CASE TableNum%@NL@% CASE 1%@NL@% TableName$ = " Book Stock Table "%@NL@% CASE 2%@NL@% TableName$ = " Card Holders Table "%@NL@% END SELECT%@NL@% %@NL@% HowLong = LEN(TableName$)%@NL@% NameSpace$ = "╡" + STRING$(HowLong, 32) + "╞"%@NL@% PlaceName = (72 \ 2) - (HowLong \ 2)%@NL@% %@NL@% IF TableNum = 1 THEN RESTORE BooksTable ELSE RESTORE LendeesTable%@NL@% %@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% %@NL@% FOR Row = TABLETOP TO TABLEEND%@NL@% LOCATE Row, 1%@NL@% READ Temp$%@NL@% PRINT Temp$%@NL@% IF Row = TABLETOP THEN%@NL@% LOCATE TABLETOP, PlaceName%@NL@% PRINT NameSpace$%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE 1, PlaceName + 1%@NL@% PRINT TableName$%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END IF%@NL@% NEXT Row%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The EraseMessage SUB erases the message in the message box between the *%@AE@%%@NL@% %@AB@%'* displayed table and the menus at the bottom of the screen. It replaces *%@AE@%%@NL@% %@AB@%'* the corners of the table and menus that may have been overwritten *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB EraseMessage%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE MESBOXTOP, 1%@NL@% PRINT "╚"; STRING$(68, CHR$(205)); "╝"%@NL@% LOCATE MESFIELD, 1%@NL@% PRINT SPACE$(70)%@NL@% LOCATE MESBOXEND, 1%@NL@% PRINT "╔"; STRING$(38, CHR$(205)); "╗ ╔"; STRING$(27, CHR$(205)); "╗"%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'**************************** MakeString FUNCTION **************************%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'* The MakeString FUNCTION provides a minimal editor to operate in the *%@AE@%%@NL@% %@AB@%'* BOOKLOOK message box. A prompt is shown. The user can enter numbers, *%@AE@%%@NL@% %@AB@%'* letters, punctuation, the ENTER, BACKSPACE and ESC keys. *%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'* Parameters: *%@AE@%%@NL@% %@AB@%'* FilterTrap Brings in a keystroke or letter by ASCII value *%@AE@%%@NL@% %@AB@%'* ThisString Prompt passed in depends on calling function *%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION MakeString$ (FilterTrap AS INTEGER, ThisString$)%@NL@% %@NL@% MessageLen = LEN(ThisString$) ' Save length of the prompt%@NL@% IF FilterTrap THEN ' then, if a letter was%@NL@% ThisString$ = ThisString$ + CHR$(FilterTrap) ' passed in, add it to the%@NL@% NewString$ = CHR$(FilterTrap) ' prompt and use it to start%@NL@% END IF ' string to be returned.%@NL@% CALL ShowMessage(ThisString$, 1) ' Show the string and turn%@NL@% DO ' on cursor at end.%@NL@% DO%@NL@% Answer$ = INKEY$%@NL@% LOOP WHILE Answer$ = EMPTYSTRING%@NL@% SELECT CASE Answer$%@NL@% CASE CHR$(ESCAPE)%@NL@% FilterTrap = ESCAPE%@NL@% CALL ShowMessage(KEYSMESSAGE, 0)%@NL@% EXIT FUNCTION%@NL@% CASE " " TO "~"%@NL@% NewString$ = NewString$ + Answer$%@NL@% ThisString$ = ThisString$ + Answer$%@NL@% CALL ShowMessage(ThisString$, 1)%@NL@% CASE CHR$(BACKSPACE)%@NL@% ShortLen = LEN(ThisString$) - 1%@NL@% ThisString$ = MID$(ThisString$, 1, ShortLen)%@NL@% NewString$ = MID$(ThisString$, MessageLen + 1)%@NL@% CALL ShowMessage(ThisString$, 1)%@NL@% CASE CHR$(ENTER)%@NL@% LOCATE , , 0%@NL@% MakeString$ = LTRIM$(RTRIM$(NewString$))%@NL@% EXIT FUNCTION%@NL@% CASE ELSE%@NL@% BEEP%@NL@% CALL ShowMessage("Not a valid key --- press Space bar", 0)%@NL@% END SELECT%@NL@% LOOP%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The ReturnKey$ FUNCTION gets a key from the user and returns its value *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION ReturnKey$%@NL@% DO%@NL@% Answer$ = INKEY$%@NL@% LOOP WHILE Answer$ = EMPTYSTRING%@NL@% ReturnKey$ = Answer$%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'******************************** ShowIt SUB ******************************%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'* After the user enters a value to search for in a specific index, *%@AE@%%@NL@% %@AB@%'* this SUB places the value in the proper element of the temporary *%@AE@%%@NL@% %@AB@%'* record variable, then displays the value in the field. Finally, *%@AE@%%@NL@% %@AB@%'* the user is prompted to choose the relationship the indexed value *%@AE@%%@NL@% %@AB@%'* should have to the key that has been entered. *%@AE@%%@NL@% %@AB@%'* Parameters: *%@AE@%%@NL@% %@AB@%'* TabesRec: A temporary recordvariable - same as BigRec *%@AE@%%@NL@% %@AB@%'* WhichIndex: Tells name of Index on which key should be sought *%@AE@%%@NL@% %@AB@%'* WhichTable: The number of the table currently being displayed *%@AE@%%@NL@% %@AB@%'* StringTo Show: Value user wants to search for in index *%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% SUB ShowIt (TablesRec AS RecStruct, WhichIndex$, WhichTable%, StringToShow$)%@NL@% TablesRec.TableNum = WhichTable%@NL@% TablesRec.WhichIndex = WhichIndex$%@NL@% COLOR BRIGHT + FOREGROUND, BACKGROUND%@NL@% SELECT CASE WhichIndex$%@NL@% CASE "TitleIndexBS"%@NL@% TablesRec.Inventory.Title = StringToShow$%@NL@% CASE "AuthorIndexBS"%@NL@% TablesRec.Inventory.Author = StringToShow$%@NL@% CASE "PubIndexBS"%@NL@% TablesRec.Inventory.Publisher = StringToShow$%@NL@% CASE "IDIndex"%@NL@% TablesRec.Inventory.IDnum = VAL(StringToShow$)%@NL@% CASE "NameIndexCH"%@NL@% TablesRec.Lendee.TheName = StringToShow$%@NL@% CASE "StateIndexCH"%@NL@% TablesRec.Lendee.State = StringToShow$%@NL@% CASE "ZipIndexCH"%@NL@% TablesRec.Lendee.Zip = VAL(StringToShow$)%@NL@% CASE "CardNumIndexCH"%@NL@% TablesRec.Lendee.CardNum = VAL(StringToShow$)%@NL@% END SELECT%@NL@% CALL ShowRecord(TablesRec)%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The ShowKeys SUB presents the key the user should press for a desired *%@AE@%%@NL@% %@AB@%'* operation associated with a description of the task. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TablesRec RecStruct type variable containing table information *%@AE@%%@NL@% %@AB@%'* ForeGrnd Integer indicating whether key is highlighted or not *%@AE@%%@NL@% %@AB@%'* TableDone 1 for No Next Record, 0 otherwise (usually DimN) *%@AE@%%@NL@% %@AB@%'* TableStart 1 for No Previous Record, 0 otherwise (usually DimP) *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB ShowKeys (TablesRec AS RecStruct, ForeGrnd%, TableDone%, TableStart%)%@NL@% COLOR ForeGrnd, BACKGROUND 'foreground bright%@NL@% LOCATE NLINE, 3%@NL@% PRINT "N"%@NL@% LOCATE NLINE, 24%@NL@% PRINT "P"%@NL@% LOCATE RLINE, 3%@NL@% PRINT "R"%@NL@% LOCATE RLINE, 24%@NL@% PRINT "F"%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% LOCATE WLINE, 3%@NL@% PRINT "W"%@NL@% LOCATE WLINE, 24%@NL@% PRINT "B"%@NL@% ELSE%@NL@% LOCATE WLINE, 9%@NL@% PRINT "B"%@NL@% END IF%@NL@% LOCATE VLINE, 9%@NL@% PRINT "V"%@NL@% LOCATE ALINE, 3%@NL@% PRINT "A"%@NL@% LOCATE ALINE, 24%@NL@% PRINT "D"%@NL@% LOCATE ELINE, 3%@NL@% PRINT "E"%@NL@% LOCATE ELINE, 24%@NL@% PRINT "Q"%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% LOCATE CLINE, 3%@NL@% PRINT "O"%@NL@% LOCATE CLINE, 24%@NL@% PRINT "I"%@NL@% END IF%@NL@% IF TableDone = TRUE THEN%@NL@% %@NL@% LOCATE NLINE, 3%@NL@% PRINT " No Next Record"%@NL@% ELSE%@NL@% LOCATE NLINE, 3%@NL@% PRINT "N "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE NLINE, 5%@NL@% PRINT "= "%@NL@% LOCATE NLINE, 6%@NL@% PRINT " Next Record"%@NL@% END IF%@NL@% IF TableStart = TRUE THEN%@NL@% COLOR ForeGrnd, BACKGROUND%@NL@% LOCATE NLINE, 20%@NL@% PRINT " No Previous Record"%@NL@% ELSE%@NL@% COLOR ForeGrnd, BACKGROUND%@NL@% LOCATE NLINE, 20%@NL@% PRINT " P "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE NLINE, 26%@NL@% PRINT "= "%@NL@% LOCATE NLINE, 27%@NL@% PRINT " Previous "%@NL@% END IF%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END SUB%@NL@% %@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% %@AB@%'* The ShowMessage SUB displays the message string passed in the message *%@AE@%%@NL@% %@AB@%'* box between the displayed table and the menus. If the Cursor parameter*%@AE@%%@NL@% %@AB@%'* is 0, no cursor appears in the box; if it is 1, a cursor is displaed. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* Message$ Prompt or message to display *%@AE@%%@NL@% %@AB@%'* Cursor Boolean value telling whether or not to show a cursor *%@AE@%%@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% SUB ShowMessage (Message$, Cursor)%@NL@% CALL EraseMessage%@NL@% IF (LEN(Message$) MOD 2) THEN%@NL@% Borderlen = 1%@NL@% END IF%@NL@% MesLen = LEN(Message$)%@NL@% SELECT CASE Cursor ' No cursor request means to%@NL@% CASE FALSE ' center the message in box%@NL@% HalfMes = (MesLen \ 2) + 1 ' and display without cursor%@NL@% Start = (SCREENWIDTH \ 2) - HalfMes%@NL@% CASE ELSE%@NL@% Start = 4 ' Message is part of an edit%@NL@% END SELECT ' so display flush left, and%@NL@% LOCATE MESBOXTOP, 2 ' keep cursor visible%@NL@% PRINT "╔"; STRING$(66, CHR$(205)); "╗"%@NL@% LOCATE MESFIELD, 2%@NL@% PRINT "║"; SPACE$(66); "║"%@NL@% LOCATE MESBOXEND, 2%@NL@% PRINT "╚"; STRING$(37, CHR$(205)); "╦"; "═╦"; STRING$(26, CHR$(205)); "╝"%@NL@% COLOR BRIGHT + FOREGROUND, BACKGROUND%@NL@% LOCATE MESFIELD, Start, Cursor%@NL@% PRINT Message$;%@NL@% LOCATE MESFIELD, Start + MesLen, Cursor%@NL@% PRINT "";%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END SUB%@NL@% %@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% %@AB@%'* The ShowRecord SUB displays the columns of the current record of the *%@AE@%%@NL@% %@AB@%'* table being displayed. Numerics are only displayed if they are <> 0. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TablesRec RecStruct type variable containing table information *%@AE@%%@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% SUB ShowRecord (TablesRec AS RecStruct)%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% SELECT CASE TablesRec.TableNum%@NL@% CASE cBookStockTableNum%@NL@% LOCATE TITLEFIELD, 18: PRINT TablesRec.Inventory.Title%@NL@% LOCATE AUTHORFIELD, 18: PRINT TablesRec.Inventory.Author%@NL@% LOCATE PUBFIELD, 18: PRINT TablesRec.Inventory.Publisher%@NL@% IF TablesRec.Inventory.Edition <> 0 THEN LOCATE EDFIELD, 17: PRINT STR$(TablesRec.Inventory.Edition)%@NL@% IF TablesRec.Inventory.Price <> 0 THEN LOCATE PRICEFIELD, 17: PRINT " $"; STR$(TablesRec.Inventory.Price)%@NL@% IF TablesRec.Inventory.IDnum <> 0 THEN LOCATE IDFIELD, 17: PRINT STR$(TablesRec.Inventory.IDnum)%@NL@% CASE cCardHoldersTableNum%@NL@% LOCATE NAMEFIELD, 18: PRINT TablesRec.Lendee.TheName%@NL@% LOCATE STREETFIELD, 18: PRINT TablesRec.Lendee.Street%@NL@% LOCATE CITYFIELD, 18: PRINT TablesRec.Lendee.City%@NL@% LOCATE STATEFIELD, 18: PRINT TablesRec.Lendee.State%@NL@% IF TablesRec.Lendee.Zip <> 0 THEN LOCATE ZIPFIELD, 17: PRINT STR$(TablesRec.Lendee.Zip)%@NL@% IF TablesRec.Lendee.CardNum <> 0 THEN LOCATE CARDNUMFIELD, 17: PRINT STR$(TablesRec.Lendee.CardNum)%@NL@% CASE ELSE%@NL@% CALL ShowMessage("There are no other forms defined", 0)%@NL@% END SELECT%@NL@% END SUB%@NL@% %@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% %@AB@%'* The UserChoice SUB is used to echo back to the user the most recent *%@AE@%%@NL@% %@AB@%'* menu selection he has made. Not all menu choices are echoed back. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* BigRec RecStruct type variable containing table information *%@AE@%%@NL@% %@AB@%'* Row Row on which to put the Feedback$ *%@AE@%%@NL@% %@AB@%'* Column Column at which to start the Feedback$ *%@AE@%%@NL@% %@AB@%'* Feedback$ Menu-choice string to highlight *%@AE@%%@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% SUB UserChoice (BigRec AS RecStruct, Row, Column, Feedback$)%@NL@% CALL DrawHelpKeys(BigRec.TableNum)%@NL@% CALL ShowKeys(BigRec, BRIGHT + FOREGROUND, DimN, DimP)%@NL@% COLOR FOREGROUND + BRIGHT, BACKGROUND%@NL@% LOCATE Row, Column%@NL@% PRINT Feedback$%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%BOOKMOD2.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\BOOKMOD2.BAS%@AE@%%@NL@% %@NL@% %@AB@%'***********************************************************************%@AE@%%@NL@% %@AB@%'* This is module level code for BOOKMOD2.BAS. It contains procedures *%@AE@%%@NL@% %@AB@%'* that use ISAM statements as well as procedures that support them. *%@AE@%%@NL@% %@AB@%'* It is the third module of the BOOKLOOK program. *%@AE@%%@NL@% %@AB@%'***********************************************************************%@AE@%%@NL@% DEFINT A-Z%@NL@% %@AB@%'$INCLUDE: 'booklook.bi'%@AE@%%@NL@% %@NL@% EditMessage:%@NL@% DATA "╔═══════════════════════════╗"%@NL@% DATA "║ A log is being kept while ║"%@NL@% DATA "║ you edit fields in this ║"%@NL@% DATA "║ record. Press U to undo ║"%@NL@% DATA "║ each preceding edit, or ║"%@NL@% DATA "║ CTRL+U to undo all of the ║"%@NL@% DATA "║ pending edits as a group. ║"%@NL@% DATA "║ ║"%@NL@% DATA "╚═════╡ To Undo Edits ╞═════╝"%@NL@% %@NL@% OperandBox:%@NL@% DATA "╔═══════════════════════════╗"%@NL@% DATA "║ ║"%@NL@% DATA "║ Greater Than ║"%@NL@% DATA "║ or ║"%@NL@% DATA "║ Equal To Value Entered║"%@NL@% DATA "║ or ║"%@NL@% DATA "║ Less Than ║"%@NL@% DATA "║ ║"%@NL@% DATA "╚══╡ Relationship to Key ╞══╝"%@NL@% %@NL@% %@AB@%'************************************************************************%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'* This SUB checks the real current index after a try to set an index. *%@AE@%%@NL@% %@AB@%'* If the index was successfully set, it's name is displayed, other- *%@AE@%%@NL@% %@AB@%'* wise the current index is displayed. IndexBox is called to update *%@AE@%%@NL@% %@AB@%'* Current Sorting Order box on the screen. *%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'************************************************************************%@AE@%%@NL@% SUB AdjustIndex (TablesRec AS RecStruct)%@NL@% RealIndexName$ = GETINDEX$(TablesRec.TableNum)%@NL@% CALL Indexbox(TablesRec, CheckIndex%(TablesRec, 0))%@NL@% IF RealIndexName$ <> EMPTYSTRING THEN%@NL@% Alert$ = "Records are now ordered by the index called " + RealIndexName$%@NL@% ELSE%@NL@% Alert$ = "Records now ordered by the default (NULL) index"%@NL@% END IF%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The ChangeRecord FUNCTION gets the new field value with MakeString. It *%@AE@%%@NL@% %@AB@%'* then assigns the value (converted if necessary) to its proper element *%@AE@%%@NL@% %@AB@%'* in the recordvariable (TablesRec) used to update the table. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* FirstLetter If the user has started typing, this contains a letter *%@AE@%%@NL@% %@AB@%'* Argument Tells what field the cursor is currently in *%@AE@%%@NL@% %@AB@%'* TablesRec RecStruct type variable holding all table information *%@AE@%%@NL@% %@AB@%'* Task Tells which operation is being performed *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION ChangeRecord (FirstLetter$, Argument, TablesRec AS RecStruct, Task AS INTEGER)%@NL@% STATIC SaveTitle AS STRING%@NL@% Prompt$ = "New Field Value: "%@NL@% %@NL@% IF Task <> SEEKFIELD THEN ' Adjust the Argument --- It is in-%@NL@% IF Argument = TITLEFIELD THEN ' cremented as part of PlaceCursor.%@NL@% Argument = IDFIELD ' But it needs the user's original%@NL@% ELSE ' choice in this function.%@NL@% Argument = Argument - 2%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% Filter% = ASC(FirstLetter$) ' Convert FirstLetter$ to ascii%@NL@% Remainder$ = MakeString$(Filter%, Prompt$) ' number to pass to MakeString.%@NL@% IF Filter% = ESCAPE THEN ' This lets the user press ESC%@NL@% ChangeRecord = 0 ' to abandon function.%@NL@% CALL ShowRecord(TablesRec)%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@AB@% ' Select for proper assignment of%@AE@%%@NL@% SELECT CASE Argument ' string user makes with MakeString%@NL@% CASE TITLEFIELD, NAMEFIELD%@NL@% IF Task = EDITRECORD OR Task = ADDRECORD OR Task = SEEKFIELD THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% TablesRec.Inventory.Title = Remainder$%@NL@% ELSE%@NL@% TablesRec.Lendee.TheName = Remainder$%@NL@% END IF%@NL@% END IF%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% CASE AUTHORFIELD, STREETFIELD%@NL@% IF Task = EDITRECORD OR Task = ADDRECORD THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% TablesRec.Inventory.Author = Remainder$%@NL@% ELSE%@NL@% TablesRec.Lendee.Street = Remainder$%@NL@% END IF%@NL@% END IF%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% CASE PUBFIELD, CITYFIELD%@NL@% IF Task = EDITRECORD OR Task = ADDRECORD THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% TablesRec.Inventory.Publisher = Remainder$%@NL@% ELSE%@NL@% TablesRec.Lendee.City = Remainder$%@NL@% END IF%@NL@% END IF%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% CASE EDFIELD, STATEFIELD%@NL@% IF Task = EDITRECORD OR Task = ADDRECORD THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% TablesRec.Inventory.Edition = VAL(Remainder$)%@NL@% ELSE%@NL@% TablesRec.Lendee.State = Remainder$%@NL@% END IF%@NL@% END IF%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% CASE PRICEFIELD, ZIPFIELD%@NL@% IF Task = EDITRECORD OR Task = ADDRECORD THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% TablesRec.Inventory.Price = VAL(Remainder$)%@NL@% ELSE%@NL@% TablesRec.Lendee.Zip = VAL(Remainder$)%@NL@% END IF%@NL@% END IF%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% CASE IDFIELD, CARDNUMFIELD%@NL@% IF Task = EDITRECORD OR Task = ADDRECORD THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% size = LEN(Remainder$)%@NL@% FOR counter = 1 TO size%@NL@% IF ASC(MID$(Remainder$, counter, 1)) = 0 THEN%@NL@% Remainder$ = MID$(Remainder$, (counter + 1), size)%@NL@% END IF%@NL@% NEXT counter%@NL@% TablesRec.Inventory.IDnum = VAL(LTRIM$(RTRIM$(Remainder$)))%@NL@% ELSE%@NL@% TablesRec.Lendee.CardNum = VAL(Remainder$)%@NL@% END IF%@NL@% END IF%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% CASE ELSE%@NL@% CALL ShowMessage(" Can't change that field ", 0)%@NL@% BEEP%@NL@% SLEEP 1%@NL@% END SELECT%@NL@% ChangeRecord = 1%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The CheckIndex uses the GETINDEX function to find the current index. *%@AE@%%@NL@% %@AB@%'* Since only some displayed fields correspond to indexes, the number *%@AE@%%@NL@% %@AB@%'* returned is a code indicating what to do, not the index name *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TablesRec RecStuct type variable holding all table information *%@AE@%%@NL@% %@AB@%'* FirstTime If first time is TRUE, Index is NULL index *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION CheckIndex% (TablesRec AS RecStruct, FirstTime)%@NL@% Check$ = GETINDEX$(TablesRec.TableNum)%@NL@% SELECT CASE Check$%@NL@% CASE "TitleIndexBS", "NameIndexCH"%@NL@% CheckIndex% = 0%@NL@% CASE "AuthorIndexBS"%@NL@% CheckIndex% = 1%@NL@% CASE "PubIndexBS"%@NL@% CheckIndex% = 2%@NL@% CASE "StateIndexCH"%@NL@% CheckIndex% = 3%@NL@% CASE "ZipIndexCH"%@NL@% CheckIndex% = 4%@NL@% CASE "IDIndex", "CardNumIndexCH"%@NL@% CheckIndex% = 5%@NL@% CASE "BigIndex" ' There's no combined index on%@NL@% CheckIndex% = 6 ' CardHolders table%@NL@% CASE ""%@NL@% CheckIndex% = 7 ' This is a special case for the%@NL@% %@AB@% ' Blank line in CardHolders table%@AE@%%@NL@% IF FirstTime% THEN%@NL@% CALL Indexbox(TablesRec, 7)%@NL@% END IF%@NL@% END SELECT%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The EdAddCursor function is used to place the cursor in the proper *%@AE@%%@NL@% %@AB@%'* when the task is to Edit or Add a record. Note when printing numeric *%@AE@%%@NL@% %@AB@%'* fields LOCATE 1 column left to compensate for the implicit "+" sign. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* NextField Tells which field is to be highlighted next *%@AE@%%@NL@% %@AB@%'* Job Tells operation user wants to engage in *%@AE@%%@NL@% %@AB@%'* TablesRec RecStruct type variable holding all table information *%@AE@%%@NL@% %@AB@%'* FirstShot Nonzero value indicates this is first time through *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION EdAddCursor (NextField%, Job%, TablesRec AS RecStruct, FirstShot%)%@NL@% SELECT CASE TablesRec.TableNum%@NL@% CASE cBookStockTableNum ' BookStock table is 1%@NL@% SELECT CASE NextField%@NL@% CASE TITLEFIELD, NAMEFIELD%@NL@% LOCATE IDFIELD, 17%@NL@% IF FirstShot THEN COLOR FOREGROUND, BACKGROUND%@NL@% PRINT TablesRec.Inventory.IDnum%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE TITLEFIELD, 18%@NL@% PRINT TablesRec.Inventory.Title%@NL@% NextField% = AUTHORFIELD%@NL@% CASE AUTHORFIELD, STREETFIELD%@NL@% LOCATE TITLEFIELD, 18%@NL@% PRINT TablesRec.Inventory.Title%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE AUTHORFIELD, 18%@NL@% PRINT TablesRec.Inventory.Author%@NL@% NextField% = PUBFIELD%@NL@% CASE PUBFIELD, CITYFIELD%@NL@% LOCATE AUTHORFIELD, 18%@NL@% PRINT TablesRec.Inventory.Author%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE PUBFIELD, 18%@NL@% PRINT TablesRec.Inventory.Publisher%@NL@% NextField% = EDFIELD%@NL@% CASE EDFIELD, STATEFIELD%@NL@% LOCATE PUBFIELD, 18%@NL@% PRINT TablesRec.Inventory.Publisher%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE EDFIELD, 17%@NL@% PRINT TablesRec.Inventory.Edition%@NL@% NextField% = PRICEFIELD%@NL@% CASE PRICEFIELD, ZIPFIELD%@NL@% LOCATE EDFIELD, 17%@NL@% PRINT TablesRec.Inventory.Edition%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE PRICEFIELD, 19%@NL@% PRINT ; TablesRec.Inventory.Price%@NL@% NextField% = IDFIELD%@NL@% CASE IDFIELD, CARDNUMFIELD%@NL@% LOCATE PRICEFIELD, 18%@NL@% PRINT "$"; TablesRec.Inventory.Price%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE IDFIELD, 17%@NL@% PRINT TablesRec.Inventory.IDnum%@NL@% NextField% = TITLEFIELD%@NL@% END SELECT%@NL@% CASE cCardHoldersTableNum ' CardHolders table is 2%@NL@% SELECT CASE NextField%@NL@% CASE NAMEFIELD%@NL@% LOCATE CARDNUMFIELD, 17%@NL@% IF FirstShot THEN COLOR FOREGROUND, BACKGROUND%@NL@% PRINT TablesRec.Lendee.CardNum%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE NAMEFIELD, 18%@NL@% PRINT TablesRec.Lendee.TheName%@NL@% NextField% = STREETFIELD%@NL@% CASE STREETFIELD%@NL@% LOCATE NAMEFIELD, 18%@NL@% PRINT TablesRec.Lendee.TheName%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE STREETFIELD, 18%@NL@% PRINT TablesRec.Lendee.Street%@NL@% NextField% = CITYFIELD%@NL@% CASE CITYFIELD%@NL@% LOCATE STREETFIELD, 18%@NL@% PRINT TablesRec.Lendee.Street%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE CITYFIELD, 18%@NL@% PRINT TablesRec.Lendee.City%@NL@% NextField% = STATEFIELD%@NL@% CASE STATEFIELD%@NL@% LOCATE CITYFIELD, 18%@NL@% PRINT TablesRec.Lendee.City%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE STATEFIELD, 18%@NL@% PRINT TablesRec.Lendee.State%@NL@% NextField% = PRICEFIELD%@NL@% CASE ZIPFIELD%@NL@% LOCATE STATEFIELD, 18%@NL@% PRINT TablesRec.Lendee.State%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE ZIPFIELD, 17%@NL@% PRINT TablesRec.Lendee.Zip%@NL@% NextField% = IDFIELD%@NL@% CASE CARDNUMFIELD%@NL@% LOCATE ZIPFIELD, 17%@NL@% PRINT TablesRec.Lendee.Zip%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE CARDNUMFIELD, 17%@NL@% PRINT TablesRec.Lendee.CardNum%@NL@% NextField% = TITLEFIELD%@NL@% END SELECT%@NL@% END SELECT%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The EditField function lets the user choose whether or not to actually *%@AE@%%@NL@% %@AB@%'* change the current field (by calling ChangeRecord) or move on to the *%@AE@%%@NL@% %@AB@%'* next field. It also displays a message telling how to Undo edits. If *%@AE@%%@NL@% %@AB@%'* EditField returns TRUE, a SAVEPOINT is set at module level. If the task*%@AE@%%@NL@% %@AB@%'* is ADDRECORD, the user is taken through the fields one at a time until *%@AE@%%@NL@% %@AB@%'* they have all been entered. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* Argument Tells which field is currently being dealt with *%@AE@%%@NL@% %@AB@%'* TablesRec RecStruct type variable holding current table information *%@AE@%%@NL@% %@AB@%'* FirstLetter If the user has started typing, the letter is passed in *%@AE@%%@NL@% %@AB@%'* Task Tells what type of operation the user is performing *%@AE@%%@NL@% %@AB@%'* Answer Same as Task, but passed to ChangeRecord%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION EditField (Argument%, TablesRec AS RecStruct, FirstLetter$, Task%, Answer%)%@NL@% %@AB@% ' Show the transaction block message dealing with undoing edits:%@AE@%%@NL@% IF Task = EDITRECORD THEN CALL DrawIndexBox(1, Task)%@NL@% %@NL@% STATIC NextField%@NL@% FirstLetter$ = ""%@NL@% IF Task = EDITRECORD THEN CALL ShowMessage("Edit this field or TAB to another", 0)%@NL@% Argument = TITLEFIELD%@NL@% Value = PlaceCursor(Argument, TablesRec, FirstLetter$, 1, Task%)%@NL@% IF Argument THEN%@NL@% IF Task = EDITRECORD THEN CALL ShowMessage("Edit this field or TAB to another", 0)%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% WasFieldChanged = ChangeRecord(FirstLetter$, Argument, TablesRec, Answer)%@NL@% %@NL@% IF Task = EDITRECORD AND WasFieldChanged <> 0 THEN%@NL@% CALL ShowMessage("Press E to Edit another field ", 0)%@NL@% EditField = TRUE ' If True is returned, a SAVEPOINT is set%@NL@% ELSEIF Task = EDITRECORD AND WasFieldChanged = 0 THEN%@NL@% CALL ShowRecord(TablesRec)%@NL@% CALL ShowMessage("Please try again...", 0)%@NL@% EditField = FALSE 'Don't set SAVEPOINT if user escapes from edit%@NL@% ELSEIF Task = SEEKFIELD THEN%@NL@% EditField = FALSE: EXIT FUNCTION%@NL@% END IF%@NL@% IF Task = ADDRECORD THEN%@NL@% NextField = 1%@NL@% DO WHILE NextField <> 0 AND Argument <> 0%@NL@% CALL ShowMessage("Enter value for field or ESC to abandon addition ", 0)%@NL@% SELECT CASE NextField%@NL@% CASE 1%@NL@% Argument = AUTHORFIELD%@NL@% FieldsDone = FieldsDone + 1%@NL@% CASE 2%@NL@% Argument = PUBFIELD%@NL@% FieldsDone = FieldsDone + 1%@NL@% CASE 3%@NL@% Argument = EDFIELD%@NL@% FieldsDone = FieldsDone + 1%@NL@% CASE 4%@NL@% Argument = PRICEFIELD%@NL@% FieldsDone = FieldsDone + 1%@NL@% CASE 5%@NL@% Argument = IDFIELD%@NL@% FieldsDone = FieldsDone + 1%@NL@% NextField = 0%@NL@% CASE ELSE%@NL@% CALL ShowMessage("Problem in the CASE assignments to Argument", 0): SLEEP%@NL@% END SELECT%@NL@% FirstLetter$ = ""%@NL@% Value = PlaceCursor(Argument, TablesRec, FirstLetter$, 1, Task%)%@NL@% IF Argument THEN%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% WasFieldChanged = ChangeRecord(FirstLetter$, Argument, TablesRec, Answer)%@NL@% NextField = NextField + 1%@NL@% IF FieldsDone = 5 THEN EditField% = 1: EXIT FUNCTION%@NL@% END IF%@NL@% LOOP%@NL@% EditField = FALSE 'No need for SAVEPOINT with ADDRECORD%@NL@% END IF%@NL@% ELSE%@NL@% CALL ShowRecord(TablesRec)%@NL@% CALL ShowMessage("Please try again...", 0)%@NL@% SLEEP: CALL EraseMessage%@NL@% CALL DrawIndexBox(TablesRec.TableNum, 0)' Replace Edit stuff with Index stuff%@NL@% EditField = FALSE 'Don't set SAVEPOINT if user escapes from edit%@NL@% END IF%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The GetKeyVals SUB gathers the Keys for searching on a combined index. *%@AE@%%@NL@% %@AB@%'* It shows the fields as they are entered. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TablesRec Contains all the information for the tables *%@AE@%%@NL@% %@AB@%'* Key1 Represents the Title field of BookStock table *%@AE@%%@NL@% %@AB@%'* Key2 Represents the Author field of BookStock table *%@AE@%%@NL@% %@AB@%'* Key3 Represents the IDnum field of BookStock table *%@AE@%%@NL@% %@AB@%'* Letter Holds the first letter the user tries to enter at prompt *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB GetKeyVals (TablesRec AS RecStruct, Key1$, Key2$, Key3#, Letter$)%@NL@% WhichTable = TablesRec.TableNum%@NL@% Prompt$ = "Value to Seek: "%@NL@% %@NL@% CALL DrawScreen(WhichTable)%@NL@% DO%@NL@% %@AB@% ' Have the user ENTER the Title value to search for%@AE@%%@NL@% COLOR BACKGROUND, FOREGROUND%@NL@% LOCATE TITLEFIELD, 18%@NL@% PRINT "Please enter the Title to find"%@NL@% Key1$ = MakeString$(ASC(Letter$), Prompt$)%@NL@% CALL ShowIt(TablesRec, "TitleIndexBS", WhichTable, Key1$)%@NL@% LOOP UNTIL Key1$ <> ""%@NL@% %@NL@% Letter$ = " " ' Set it to a blank space for typing%@NL@% %@NL@% %@AB@% ' Have the user ENTER the Author value to search for%@AE@%%@NL@% DO%@NL@% COLOR BACKGROUND, FOREGROUND%@NL@% LOCATE AUTHORFIELD, 18%@NL@% PRINT "Please enter the Author name to find"%@NL@% Key2$ = MakeString$(ASC(Letter$), Prompt$)%@NL@% %@AB@% ' Show it just shows the input user has entered, not a record from file%@AE@%%@NL@% CALL ShowIt(TablesRec, "AuthorIndexBS", WhichTable, Key2$)%@NL@% LOOP UNTIL Key2$ <> ""%@NL@% %@NL@% Letter$ = " " ' Set it to a blank space for typing%@NL@% %@AB@% ' Have the user ENTER the ID number value to search for%@AE@%%@NL@% DO%@NL@% COLOR BACKGROUND, FOREGROUND%@NL@% LOCATE IDFIELD, 18%@NL@% PRINT "Please enter the ID number to find"%@NL@% ValueToSeek$ = MakeString$(ASC(Letter$), Prompt$)%@NL@% Key3# = CDBL(VAL(ValueToSeek$)) ' CURRENCY field%@NL@% CALL ShowIt(TablesRec, "IDIndex", WhichTable, ValueToSeek$)%@NL@% LOOP UNTIL Key3# <> 0%@NL@% END SUB%@NL@% %@NL@% %@AB@%'****************************** GetOperand FUNCTION ************************%@AE@%%@NL@% %@AB@%'* The GetOperand FUNCTION displays a choice of operators to allow user a *%@AE@%%@NL@% %@AB@%'* choice in how a SEEKoperand search will be conducted. If the user makes *%@AE@%%@NL@% %@AB@%'* a valid choice, it is assigned to HoldOperand. An invalid choice or a *%@AE@%%@NL@% %@AB@%'* choice of ESC results in "<>" being passed back. This permits an exit *%@AE@%%@NL@% %@AB@%'* from the function (which is recursive). Otherwise, the user's choice is *%@AE@%%@NL@% %@AB@%'* trapped in HoldOperand when ENTER is pressed. *%@AE@%%@NL@% %@AB@%'* Note that this function is recursive so use the calls menu to keep *%@AE@%%@NL@% %@AB@%'* track of the nesting depth when stepping through it. Unlike PlaceCursor *%@AE@%%@NL@% %@AB@%'* GetOperand doesn't keep track of the stack - the stack set should be OK.*%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* HoldOperand Contains operand to check each time function calls *%@AE@%%@NL@% %@AB@%'* itself; Let's user ESC from function if desired. *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION GetOperand% (HoldOperand$)%@NL@% STATIC WhichOne ' Keep track of which case from call to call%@NL@% %@NL@% %@AB@% ' If user has chose ESC then exit back to caller%@AE@%%@NL@% IF HoldOperand$ = "<>" THEN WhichOne = 0: EXIT FUNCTION%@NL@% %@NL@% %@AB@% ' if this is the first time through the function then%@AE@%%@NL@% %@AB@% ' Replace the Sort Order box with box of operand choices%@AE@%%@NL@% IF WhichOne = 0 THEN%@NL@% RESTORE OperandBox%@NL@% FOR Row = BOXTOP TO BOXEND%@NL@% LOCATE Row, 42%@NL@% READ Temp$%@NL@% PRINT Temp$%@NL@% IF Row = BOXEND THEN%@NL@% COLOR FOREGROUND + BRIGHT, BACKGROUND%@NL@% LOCATE Row, INDBOX + 5%@NL@% PRINT "Relationship to Key"%@NL@% END IF%@NL@% NEXT Row%@NL@% LOCATE VLINE, 44%@NL@% PRINT "Equal To Value Entered" ' This is default --- if user%@NL@% COLOR FOREGROUND, BACKGROUND ' presses ENTER without tabbing,%@NL@% END IF ' SeekRecord sets the operand%@NL@% %@AB@% ' to = Note: a more flexible%@AE@%%@NL@% %@AB@% ' default choice might be >=%@AE@%%@NL@% %@NL@% Alert$ = "Now press TAB to select how search should be conducted"%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% DO%@NL@% Answer$ = INKEY$%@NL@% LOOP WHILE Answer$ <> CHR$(TABKEY) AND Answer$ <> CHR$(ENTER) AND Answer$ <> CHR$(ESCAPE)%@NL@% %@NL@% IF LEN(Answer$) = 1 THEN%@NL@% SELECT CASE ASC(Answer$)%@NL@% CASE TABKEY%@NL@% SELECT CASE WhichOne%@NL@% CASE 0%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE VLINE, 44%@NL@% PRINT "Equal To"%@NL@% COLOR BRIGHT + FOREGROUND, BACKGROUND%@NL@% LOCATE RLINE, 44%@NL@% PRINT "Greater Than"%@NL@% WhichOne = WhichOne + 1%@NL@% HoldOperand$ = ">"%@NL@% CASE 1%@NL@% COLOR BRIGHT + FOREGROUND, BACKGROUND%@NL@% LOCATE VLINE, 44%@NL@% PRINT "Equal To"%@NL@% LOCATE WLINE, 44%@NL@% PRINT "or"%@NL@% WhichOne = WhichOne + 1%@NL@% HoldOperand$ = ">="%@NL@% CASE 2%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE RLINE, 44%@NL@% PRINT "Greater Than"%@NL@% LOCATE WLINE, 44%@NL@% PRINT "or"%@NL@% COLOR BRIGHT + FOREGROUND, BACKGROUND%@NL@% LOCATE ALINE, 44%@NL@% PRINT "or"%@NL@% LOCATE ELINE, 44%@NL@% PRINT "Less Than"%@NL@% WhichOne = WhichOne + 1%@NL@% HoldOperand$ = "<="%@NL@% CASE 3%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE VLINE, 44%@NL@% PRINT "Equal To"%@NL@% LOCATE ALINE, 44%@NL@% PRINT "or"%@NL@% WhichOne = WhichOne + 1%@NL@% HoldOperand$ = "<"%@NL@% SLEEP%@NL@% CASE 4%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE ELINE, 44%@NL@% PRINT "Less Than"%@NL@% COLOR BRIGHT + FOREGROUND, BACKGROUND%@NL@% LOCATE VLINE, 44%@NL@% PRINT "Equal To Value Entered"%@NL@% WhichOne = WhichOne + 1%@NL@% HoldOperand$ = "="%@NL@% CASE ELSE%@NL@% END SELECT ' If no choice was made, call%@NL@% IF WhichOne > 4 THEN WhichOne = 0 ' GetOperand again%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% OK = GetOperand%(HoldOperand$)%@NL@% CASE ENTER%@NL@% WhichOne = 0%@NL@% EXIT FUNCTION%@NL@% CASE ESCAPE ' If user chooses ESC, signal the function%@NL@% HoldOperand$ = "<>" ' to exit and keep exiting back through%@NL@% GetOperand% = 0 ' all levels of recursion%@NL@% WhichOne = 0%@NL@% CASE ELSE ' If user chooses invalid key, try again%@NL@% BEEP%@NL@% CALL ShowMessage("Use TAB to select relationship to search for...", 0)%@NL@% COLOR white, BACKGROUND%@NL@% OK = GetOperand%(HoldOperand$)%@NL@% END SELECT%@NL@% ELSE%@NL@% END IF%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The IndexBox SUB highlights the proper index name in the Current Index *%@AE@%%@NL@% %@AB@%'* box at the bottom right section of the screen. *%@AE@%%@NL@% %@AB@%' *%@AE@%%@NL@% %@AB@%'* TablesRec RecStruct type variable containing all table information *%@AE@%%@NL@% %@AB@%'* MoveDown Integer representing line on which index name resides *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB Indexbox (TablesRec AS RecStruct, MoveDown)%@NL@% Table = TablesRec.TableNum%@NL@% COLOR BRIGHT + FOREGROUND, BACKGROUND%@NL@% LOCATE 17 + MoveDown, 44%@NL@% SELECT CASE MoveDown%@NL@% CASE 0%@NL@% IF Table = cBookStockTableNum THEN PRINT "By Titles " ELSE PRINT "By Name "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE ELINE, 44%@NL@% PRINT "Default = Insertion Order"%@NL@% CASE 1%@NL@% IF Table = cBookStockTableNum THEN PRINT "By Authors "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE NLINE, 44%@NL@% IF Table = cBookStockTableNum THEN PRINT "By Titles " ELSE PRINT "By Name "%@NL@% CASE 2%@NL@% IF Table = cBookStockTableNum THEN PRINT "By Publishers "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE RLINE, 44%@NL@% IF Table = cBookStockTableNum THEN PRINT "By Authors "%@NL@% CASE 3%@NL@% IF Table = cCardHoldersTableNum THEN%@NL@% LOCATE RLINE, 44%@NL@% PRINT "By States "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE NLINE, 44%@NL@% PRINT "By Names "%@NL@% ELSE%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE WLINE, 44%@NL@% PRINT "By Publishers"%@NL@% END IF%@NL@% CASE 4%@NL@% IF Table = cCardHoldersTableNum THEN%@NL@% LOCATE WLINE, 44%@NL@% PRINT "By Zipcodes "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE RLINE, 44%@NL@% PRINT "By States "%@NL@% END IF%@NL@% CASE 5%@NL@% LOCATE VLINE, 44%@NL@% IF Table = cBookStockTableNum THEN%@NL@% PRINT "By ID Numbers "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% ELSE%@NL@% PRINT "By Card numbers "%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE WLINE, 44%@NL@% PRINT "By Zipcodes "%@NL@% END IF%@NL@% CASE 6%@NL@% IF Table = cBookStockTableNum THEN%@NL@% LOCATE ALINE, 44%@NL@% PRINT "By Title + Author + ID"%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% LOCATE VLINE, 44%@NL@% PRINT "By ID Numbers"%@NL@% ELSE%@NL@% LOCATE VLINE, 44%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% PRINT "By Card numbers "%@NL@% END IF%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% CASE 7%@NL@% LOCATE ELINE, 44%@NL@% PRINT "Default = Insertion Order"%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% IF Table = cBookStockTableNum THEN%@NL@% LOCATE ALINE, 44%@NL@% PRINT "By Title + Author + ID"%@NL@% ELSE%@NL@% LOCATE VLINE, 44%@NL@% PRINT "By Card numbers"%@NL@% END IF%@NL@% END SELECT%@NL@% IF MoveDown < 7 THEN%@NL@% MoveDown = MoveDown + 1%@NL@% ELSE%@NL@% MoveDown = 0%@NL@% END IF%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The OrderCursor FUNCTION returns TRUE or FALSE for user index choice. *%@AE@%%@NL@% %@AB@%'* Each time the user places the cursor on an Index to sort on, this *%@AE@%%@NL@% %@AB@%'* function displays an instruction message in the field(s) corresponding *%@AE@%%@NL@% %@AB@%'* to the Index, It then associates the highlighted index name (in the *%@AE@%%@NL@% %@AB@%'* Sorting Order box) with the name it is known by in the program, and *%@AE@%%@NL@% %@AB@%'* places that name in the .WhichIndex element of a structured variable of *%@AE@%%@NL@% %@AB@%'* RecStruct type. *%@AE@%%@NL@% %@AB@%'* Parameters: *%@AE@%%@NL@% %@AB@%'* Index Integer telling which index user has highlighted *%@AE@%%@NL@% %@AB@%'* NextField Manifest Constant telling big cursor field position *%@AE@%%@NL@% %@AB@%'* Job Manifest Constant indicating task being performed *%@AE@%%@NL@% %@AB@%'* TablesRec Variable of RecStruct type, whose .WhichInded element is *%@AE@%%@NL@% %@AB@%'* used to return the index name to be used by SETINDEX. *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION OrderCursor (Index%, NextField%, Job%, TablesRec AS RecStruct, Letter$)%@NL@% OrderCursor = FALSE%@NL@% CALL Indexbox(TablesRec, Index) ' Light up the new index%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND ' in Sorting Order box%@NL@% LOCATE NextField, 18%@NL@% IF Job = REORDER THEN ' Tell the user what is expected of him%@NL@% %@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% IF NextField <> PRICEFIELD AND NextField <> EDFIELD THEN%@NL@% PRINT "Press enter to resort, or TAB to move on"%@NL@% ELSE%@NL@% LOCATE NextField, 20 '19%@NL@% PRINT "Sorry, cannot sort on an unindexed field"%@NL@% END IF%@NL@% ELSE%@NL@% IF NextField <> STREETFIELD AND NextField <> CITYFIELD THEN%@NL@% PRINT "Press enter to resort, or TAB to move on"%@NL@% ELSE%@NL@% PRINT "Sorry, cannot sort on an unindexed field"%@NL@% END IF%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' The following places the name of the index to sort on in the%@AE@%%@NL@% %@AB@% ' WhichIndex element of the structured variable TablesRec --- it%@AE@%%@NL@% %@AB@% ' retrieved at the module-level code%@AE@%%@NL@% %@NL@% LOCATE NextField, 18%@NL@% SELECT CASE NextField%@NL@% CASE TITLEFIELD, NAMEFIELD%@NL@% IF Job = SEEKFIELD THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% PRINT "Type Title to search for, or press TAB to move on"%@NL@% ELSE%@NL@% PRINT "Type Name to search for, or press TAB to move on"%@NL@% END IF%@NL@% END IF%@NL@% IF ConfirmEntry%(Letter$) THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% TablesRec.WhichIndex = "TitleIndexBS"%@NL@% ELSE%@NL@% TablesRec.WhichIndex = "NameIndexCH"%@NL@% END IF%@NL@% OrderCursor = TRUE%@NL@% EXIT FUNCTION%@NL@% ELSE%@NL@% OrderCursor = FALSE%@NL@% NextField% = AUTHORFIELD%@NL@% END IF%@NL@% CASE AUTHORFIELD, STREETFIELD%@NL@% IF Job = SEEKFIELD THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% PRINT "Type Author name to search for, or TAB to move on"%@NL@% ELSE%@NL@% PRINT "Sorry, can't search on an unindexed field"%@NL@% END IF%@NL@% END IF%@NL@% IF ConfirmEntry%(Letter$) THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% TablesRec.WhichIndex = "AuthorIndexBS"%@NL@% END IF%@NL@% OrderCursor = TRUE%@NL@% EXIT FUNCTION%@NL@% ELSE%@NL@% OrderCursor = FALSE%@NL@% NextField% = PUBFIELD%@NL@% END IF%@NL@% CASE PUBFIELD, CITYFIELD%@NL@% IF Job = SEEKFIELD THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% PRINT "Type Publisher name to search for, or TAB to move on"%@NL@% ELSE%@NL@% PRINT "Sorry, can't search on an unindexed field"%@NL@% END IF%@NL@% END IF%@NL@% IF ConfirmEntry%(Letter$) THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% TablesRec.WhichIndex = "PubIndexBS"%@NL@% END IF%@NL@% OrderCursor = TRUE%@NL@% EXIT FUNCTION%@NL@% ELSE%@NL@% OrderCursor = FALSE%@NL@% NextField% = EDFIELD%@NL@% END IF%@NL@% CASE EDFIELD, STATEFIELD%@NL@% IF Job = SEEKFIELD THEN%@NL@% IF TablesRec.TableNum = cCardHoldersTableNum THEN%@NL@% PRINT "Type State (2 letters), or TAB to move on"%@NL@% ELSE%@NL@% PRINT "Sorry, can't search on an unindexed field"%@NL@% END IF%@NL@% END IF%@NL@% IF ConfirmEntry%(Letter$) THEN%@NL@% IF TablesRec.TableNum = cCardHoldersTableNum THEN%@NL@% TablesRec.WhichIndex = "StateIndexCH"%@NL@% END IF%@NL@% OrderCursor = TRUE%@NL@% EXIT FUNCTION%@NL@% ELSE%@NL@% OrderCursor = FALSE%@NL@% NextField% = PRICEFIELD%@NL@% END IF%@NL@% CASE PRICEFIELD, ZIPFIELD%@NL@% IF Job = SEEKFIELD THEN%@NL@% IF TablesRec.TableNum = cCardHoldersTableNum THEN%@NL@% PRINT "Type Zipcode to search for, or TAB to move on"%@NL@% ELSE%@NL@% LOCATE PRICEFIELD, 20%@NL@% PRINT "Sorry, can't search on an unindexed field"%@NL@% END IF%@NL@% END IF%@NL@% IF ConfirmEntry%(Letter$) THEN%@NL@% IF TablesRec.TableNum = cCardHoldersTableNum THEN%@NL@% TablesRec.WhichIndex = "ZipIndexCH"%@NL@% END IF%@NL@% OrderCursor = TRUE%@NL@% EXIT FUNCTION%@NL@% ELSE%@NL@% OrderCursor = FALSE%@NL@% NextField% = IDFIELD%@NL@% END IF%@NL@% CASE IDFIELD, CARDNUMFIELD%@NL@% IF Job = SEEKFIELD THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% PRINT "Type ID number to search for, or TAB to move on"%@NL@% ELSE%@NL@% PRINT "Type Card number to seek, or press TAB to move on"%@NL@% END IF%@NL@% END IF%@NL@% %@AB@% ' Setting Letter$ to "" may be unnecessary now%@AE@%%@NL@% Letter$ = ""%@NL@% IF ConfirmEntry%(Letter$) THEN%@NL@% IF TablesRec.TableNum = cBookStockTableNum THEN%@NL@% TablesRec.WhichIndex = "IDIndex"%@NL@% ELSE%@NL@% TablesRec.WhichIndex = "CardNumIndexCH"%@NL@% END IF%@NL@% OrderCursor = TRUE%@NL@% EXIT FUNCTION%@NL@% ELSE%@NL@% OrderCursor = FALSE%@NL@% NextField% = BIGINDEX%@NL@% END IF%@NL@% END SELECT%@NL@% IF Letter$ = "eScApE" THEN OrderCursor = 3: FirstLetter$ = ""%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The PlaceCursor FUNCTION lets the user tab around on the displayed form*%@AE@%%@NL@% %@AB@%'* when performing field-specific operations on the table. Since this *%@AE@%%@NL@% %@AB@%'* function is recursive it keeps track of available stack space. The two *%@AE@%%@NL@% %@AB@%'* major possibilities are SEEKs/REORDERs (for which OrderCursor is then *%@AE@%%@NL@% %@AB@%'* called) and EDIT/ADD records (for which EdAddCursor is called. Note *%@AE@%%@NL@% %@AB@%'* the combined index (BigIndex) and the default index are handled as *%@AE@%%@NL@% %@AB@%'* special cases, since they don't correspond to a single field.Recursive *%@AE@%%@NL@% %@AB@%'* construction lets the user cycle through the fields as long as *%@AE@%%@NL@% %@AB@%'* sufficient stack remains to keep calling PlaceCursor. Note that since *%@AE@%%@NL@% %@AB@%'* it is recursive, it may take while to step out while stepping with F8. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* WhichField Integer identifier specifying current field on form *%@AE@%%@NL@% %@AB@%'* TablesRec Variable of type RecStruct holding all table information *%@AE@%%@NL@% %@AB@%'* FirstLetter$ Carries user response to initial prompt shown *%@AE@%%@NL@% %@AB@%'* FirstTime Boolean telling whether this is first cal or recursion *%@AE@%%@NL@% %@AB@%'* Task Tells operation being performed *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION PlaceCursor% (WhichField, TablesRec AS RecStruct, FirstLetter$, FirstTime AS INTEGER, Task AS INTEGER)%@NL@% STATIC ReturnValue, InitialLetter$, GetOut, counter, WhichOne%@NL@% WhichTable = TablesRec.TableNum%@NL@% IF ExitFlag THEN EXIT FUNCTION%@NL@% %@NL@% ReturnValue = WhichField%@NL@% %@AB@%' Keep tabs on the stack and exit and reset it if it gets too low%@AE@%%@NL@% IF FRE(-2) < 400 THEN%@NL@% WhichField = 0%@NL@% PlaceCursor = 0%@NL@% GetOut = -1%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% %@AB@%' Set up for each of the possible operations that use PlaceCursor%@AE@%%@NL@% IF Task = REORDER THEN%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% CALL ShowMessage("Press TAB to choose field to sort on, ESC to escape", 0)%@NL@% IF WhichField = TITLEFIELD THEN WhichOne = 0%@NL@% ELSEIF Task = SEEKFIELD THEN%@NL@% CALL ShowMessage("TAB to a field, then enter a value to search", 0)%@NL@% ELSEIF Task = ADDRECORD THEN%@NL@% IF FirstTime THEN FirstLetter$ = CHR$(TABKEY) ELSE FirstLetter$ = ""%@NL@% END IF%@NL@% %@NL@% %@AB@%' The following IF... lets function handle either an entered letter or TAB%@AE@%%@NL@% IF FirstLetter$ <> "" THEN%@NL@% Answer$ = FirstLetter$%@NL@% ELSEIF FirstTime THEN%@NL@% IF Task = EDITRECORD THEN%@NL@% Answer$ = CHR$(TABKEY)%@NL@% END IF%@NL@% ELSE%@NL@% DO%@NL@% Answer$ = INKEY$%@NL@% LOOP WHILE Answer$ = EMPTYSTRING%@NL@% END IF%@NL@% %@NL@% IF LEN(Answer$) = 1 THEN%@NL@% %@NL@% %@AB@%' Clear the fields for the appropriate messages%@AE@%%@NL@% IF Task <> EDITRECORD AND Task <> ADDRECORD THEN%@NL@% CALL ClearEm(TablesRec.TableNum, 1, 1, 1, 1, 1, 1)%@NL@% END IF%@NL@% %@NL@% SELECT CASE ASC(Answer$)%@NL@% CASE IS = TABKEY, ENTER%@NL@% SELECT CASE WhichField%@NL@% CASE TITLEFIELD, AUTHORFIELD, PUBFIELD, EDFIELD, PRICEFIELD, IDFIELD%@NL@% IF Task = REORDER OR Task = SEEKFIELD THEN%@NL@% RetVal = OrderCursor(WhichOne, WhichField, Task, TablesRec, FirstLetter$)%@NL@% IF RetVal THEN%@NL@% %@AB@% ' trap a magic value for an escape here then call the Draw stuff%@AE@%%@NL@% IF RetVal <> 3 THEN%@NL@% WhichOne = 0: EXIT FUNCTION%@NL@% ELSE%@NL@% WhichOne = 0%@NL@% WhichField = 0%@NL@% PlaceCursor = 0%@NL@% CALL ShowRecord(TablesRec)%@NL@% CALL ShowMessage("You've escaped! Try again", 0)%@NL@% CALL DrawTable(WhichTable)%@NL@% CALL DrawHelpKeys(WhichTable)%@NL@% CALL ShowKeys(TablesRec, FOREGROUND + BRIGHT, 0, 0)%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% END IF%@NL@% ELSEIF Task = EDITRECORD OR Task = ADDRECORD THEN%@NL@% Placed = EdAddCursor(WhichField, Task, TablesRec, FirstTime)%@NL@% END IF%@NL@% %@NL@% CASE BIGINDEX%@NL@% CALL Indexbox(TablesRec, WhichOne)%@NL@% IF WhichTable = cBookStockTableNum THEN%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% IF Task = REORDER THEN%@NL@% LOCATE TITLEFIELD, 18%@NL@% PRINT "Press ENTER to sort first by Title..."%@NL@% LOCATE AUTHORFIELD, 18%@NL@% PRINT "... then subsort by Author..."%@NL@% LOCATE IDFIELD, 18%@NL@% PRINT "... then subsort again by ID "%@NL@% SLEEP%@NL@% ELSEIF Task = SEEKFIELD THEN%@NL@% LOCATE TITLEFIELD, 18%@NL@% PRINT "First, type in the Title to search for,"%@NL@% LOCATE AUTHORFIELD, 18%@NL@% PRINT "... then type in the Author's name"%@NL@% LOCATE IDFIELD, 18%@NL@% PRINT "... then type in the ID number "%@NL@% CALL ShowMessage("Typing in a value for a combined index is tricky...", 0)%@NL@% SLEEP%@NL@% END IF%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% IF ConfirmEntry%(FirstLetter$) THEN%@NL@% TablesRec.WhichIndex = "BigIndex"%@NL@% IF Task = SEEKFIELD THEN%@NL@% WhichOne = 0%@NL@% WhichField = TITLEFIELD%@NL@% END IF%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% END IF%@NL@% CALL ClearEm(TablesRec.TableNum, 1, 1, 0, 0, 1, 0)%@NL@% WhichField = NULLINDEX ' TITLEFIELD%@NL@% %@NL@% CASE NULLINDEX%@NL@% CALL Indexbox(TablesRec, WhichOne)%@NL@% IF Task = SEEKFIELD THEN%@NL@% CALL ShowMessage("Can't SEEK on the default index", 0)%@NL@% DO%@NL@% KeyIn$ = INKEY$%@NL@% IF KeyIn$ <> "" THEN%@NL@% IF ASC(KeyIn$) = ESCAPE THEN EXIT FUNCTION%@NL@% END IF%@NL@% LOOP WHILE KeyIn$ = ""%@NL@% %@AB@% 'SLEEP%@AE@%%@NL@% %@AB@% ' EXIT FUNCTION%@AE@%%@NL@% %@AB@% 'END IF%@AE@%%@NL@% ELSEIF ConfirmEntry%(FirstLetter$) THEN%@NL@% TablesRec.WhichIndex = "NULL"%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% WhichField = TITLEFIELD%@NL@% %@NL@% CASE ELSE%@NL@% EraseMessage%@NL@% CALL ShowMessage("Not a valid key --- press Space bar", 0)%@NL@% EXIT FUNCTION%@NL@% END SELECT%@NL@% %@AB@% ' Placecursor calls itself for next user response%@AE@%%@NL@% Value = PlaceCursor(WhichField, TablesRec, FirstLetter$, 0, Task)%@NL@% %@NL@% CASE ESCAPE%@NL@% WhichOne = 0%@NL@% WhichField = 0%@NL@% PlaceCursor = 0%@NL@% CALL ShowRecord(TablesRec)%@NL@% CALL ShowMessage("You've escaped! Try again", 0)%@NL@% CALL DrawTable(WhichTable)%@NL@% CALL DrawHelpKeys(WhichTable)%@NL@% CALL ShowKeys(TablesRec, FOREGROUND + BRIGHT, 0, 0)%@NL@% EXIT FUNCTION%@NL@% CASE 32 TO 127 ' Acceptable ASCII characters%@NL@% InitialLetter$ = Answer$%@NL@% FirstLetter$ = InitialLetter$%@NL@% EXIT FUNCTION%@NL@% CASE ELSE%@NL@% BEEP%@NL@% EraseMessage%@NL@% CALL ShowMessage("Not a valid key --- press Space bar", 0)%@NL@% WhichField = 0%@NL@% PlaceCursor = 0%@NL@% EXIT FUNCTION%@NL@% END SELECT%@NL@% ELSEIF Answer$ <> CHR$(9) THEN%@NL@% EraseMessage%@NL@% CALL ShowMessage("Not a valid key --- press Space bar", 0)%@NL@% WhichField = 0%@NL@% EXIT FUNCTION%@NL@% ELSE%@NL@% CALL ShowMessage(" Press TAB key or ENTER ", 0)%@NL@% END IF%@NL@% %@NL@% IF GetOut THEN%@NL@% counter = counter + 1%@NL@% IF counter < 15 THEN%@NL@% WhichField = 0%@NL@% WhichOne = 0%@NL@% EXIT FUNCTION%@NL@% ELSE%@NL@% GetOut = 0%@NL@% counter = 0%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The TransposeName FUNCTION takes a string and decideds whether it is *%@AE@%%@NL@% %@AB@%'* a comma-delimited, last-name-first name, a first-name-first name or a *%@AE@%%@NL@% %@AB@%'* single word name. In the last case, the string is returned unchanged. *%@AE@%%@NL@% %@AB@%'* In either of the other cases, the string is translated to the comple- *%@AE@%%@NL@% %@AB@%'* mentary format. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TheName A string representing a CardHolders table TheName element, *%@AE@%%@NL@% %@AB@%'* or a BookStock table Author Element *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION TransposeName$ (TheName AS STRING)%@NL@% SubStrLen = (INSTR(TheName, ","))%@NL@% IF SubStrLen = 0 THEN%@NL@% SubStrLen = INSTR(TheName, " ")%@NL@% IF SubStrLen = 0 THEN TransposeName$ = TheName: EXIT FUNCTION%@NL@% END IF%@NL@% TheName = LTRIM$(RTRIM$(TheName))%@NL@% IF INSTR(TheName, ",") THEN%@NL@% LastNameLen = INSTR(TheName, ",")%@NL@% LastName$ = LTRIM$(RTRIM$(LEFT$(TheName, LastNameLen - 1)))%@NL@% FirstName$ = LTRIM$(RTRIM$(MID$(TheName, LastNameLen + 1)))%@NL@% TransposeName$ = LTRIM$(RTRIM$(FirstName$ + " " + LastName$))%@NL@% ELSE%@NL@% FirstNameLen = INSTR(TheName, " ")%@NL@% IF FirstNameLen THEN%@NL@% FirstName$ = LTRIM$(RTRIM$(LEFT$(TheName, FirstNameLen - 1)))%@NL@% LastName$ = LTRIM$(RTRIM$(MID$(TheName, FirstNameLen + 1)))%@NL@% ELSE%@NL@% LastName$ = LTRIM$(RTRIM$(TheName))%@NL@% END IF%@NL@% TransposeName$ = LTRIM$(RTRIM$(LastName$ + ", " + FirstName$))%@NL@% END IF%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'****************************** ValuesOK FUNCTION **************************%@AE@%%@NL@% %@AB@%'* The ValuesOK FUNCTION checks the values input by the user for various *%@AE@%%@NL@% %@AB@%'* purposes. The checking is very minimal and checks the format of what is *%@AE@%%@NL@% %@AB@%'* entered. For example, the IDnum field needs a double value, but the form*%@AE@%%@NL@% %@AB@%'* (5 digits, followed by a decimal point, followed by 4 digits) is more *%@AE@%%@NL@% %@AB@%'* important than the data type. *%@AE@%%@NL@% %@AB@%'* Parameters: *%@AE@%%@NL@% %@AB@%'* Big Rec User-defined type containing all table information *%@AE@%%@NL@% %@AB@%'* Key1, Key2 Represent strings to check *%@AE@%%@NL@% %@AB@%'* ValueToSeek Represents the final value of a combined index *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION ValuesOK (BigRec AS RecStruct, Key1$, Key2$, ValueToSeek$)%@NL@% IndexName$ = BigRec.WhichIndex%@NL@% ValueToSeek$ = LTRIM$(RTRIM$(ValueToSeek$))%@NL@% SELECT CASE RTRIM$(LTRIM$(IndexName$))%@NL@% CASE "TitleIndexBS", "PubIndexBS" ' LEN <= 50%@NL@% IF LEN(Key1$) > 50 THEN ValuesOK = FALSE: EXIT FUNCTION%@NL@% %@NL@% CASE "AuthorIndexBS", "NameIndexCH" ' LEN <= 36%@NL@% IF LEN(Key1$) > 36 THEN ValuesOK = FALSE: EXIT FUNCTION%@NL@% %@NL@% CASE "StateIndexCH" ' LEN = 2%@NL@% IF LEN(Key1$) > 2 THEN ValuesOK = FALSE: EXIT FUNCTION%@NL@% %@NL@% CASE "IDIndex", "IDIndexBO" ' 5 digits befor d.p., 4 after%@NL@% IF LEN(ValueToSeek$) <> 10 THEN ValuesOK = FALSE: EXIT FUNCTION%@NL@% IF MID$(ValueToSeek$, 6, 1) <> "." THEN%@NL@% ValuesOK = FALSE: EXIT FUNCTION%@NL@% END IF%@NL@% CASE "CardNumIndexCH", "CardNumIndexBO" ' 5 digits, value <= LONG%@NL@% IF LEN(ValueToSeek$) <> 5 THEN ValuesOK = FALSE: EXIT FUNCTION%@NL@% %@NL@% CASE "ZipIndexCH" ' 5 digits, value <= LONG%@NL@% IF LEN(ValueToSeek$) <> 5 THEN ValuesOK = FALSE: EXIT FUNCTION%@NL@% %@NL@% CASE "BigIndex" ' Key1$ <= 50, Key2$ <= 36%@NL@% IF LEN(Key1$) > 50 THEN ValuesOK = FALSE: EXIT FUNCTION%@NL@% IF LEN(Key2$) > 36 THEN ValuesOK = FALSE: EXIT FUNCTION%@NL@% IF MID$(ValueToSeek$, 6, 1) <> "." THEN%@NL@% ValuesOK = FALSE: EXIT FUNCTION%@NL@% END IF%@NL@% END SELECT%@NL@% ValuesOK = TRUE%@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%BOOKMOD3.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\BOOKMOD3.BAS%@AE@%%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* This is module level code for BOOKMOD3.BAS, the fourth *%@AE@%%@NL@% %@AB@%'* module of BOOKLOOK.BAS. *%@AE@%%@NL@% %@AB@%'* *%@AE@%%@NL@% %@AB@%'* The module contains a procedure, MakeOver, you can use to convert text *%@AE@%%@NL@% %@AB@%'* files containing the right format and type of information for the tables*%@AE@%%@NL@% %@AB@%'* used by the BOOKLOOK program to a .MDB file. However, you need to call *%@AE@%%@NL@% %@AB@%'* MakeOver from the Immediate Window, and in order for it to work, you *%@AE@%%@NL@% %@AB@%'* must use the PROISAMD version of the TSR, because MakeOver needs the *%@AE@%%@NL@% %@AB@%'* data dictionary functionality for creating indexes, etc. *%@AE@%%@NL@% %@AB@%'* If you use the DTFMTER.QLB library functions you must include the files *%@AE@%%@NL@% %@AB@%'* DATIM.BI and FORMAT.BI at this level, using syntax as shown below. *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% DEFINT A-Z%@NL@% %@AB@%'$INCLUDE: 'booklook.bi'%@AE@%%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The BooksBorrowed SUB takes the CardNum in BooksOut associated with the*%@AE@%%@NL@% %@AB@%'* currently displayed CardHolder, then looks up each book in BooksOut *%@AE@%%@NL@% %@AB@%'* assigned to that CardNum. Note that you can use SEEKoperand to find the*%@AE@%%@NL@% %@AB@%'* first matching record, but thereafter you need to MOVENEXT and check *%@AE@%%@NL@% %@AB@%'* each succeeding record to see if the CardNum matches. When a match is *%@AE@%%@NL@% %@AB@%'* made, look up the IDnum in the BooksOut table and retrieve the title. *%@AE@%%@NL@% %@AB@%'* Put all the titles in the Titles array, then display with PeekWindow. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TablesRec Structure containing information on all database tables *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB BooksBorrowed (TablesRec AS RecStruct)%@NL@% DIM Titles(50) AS STRING%@NL@% %@AB@% ' First, get the card number of the current record in Bookstock - then%@AE@%%@NL@% %@AB@% ' at the end of this procedure, restore that book%@AE@%%@NL@% IF LOF(cBooksOutTableNum) = 0 THEN EXIT SUB%@NL@% IF GETINDEX$(cBooksOutTableNum) <> "CardNumIndexBO" THEN%@NL@% SETINDEX cBooksOutTableNum, "CardNumIndexBO"%@NL@% END IF%@NL@% RevName$ = TransposeName$(TablesRec.Lendee.TheName)%@NL@% SEEKEQ cBooksOutTableNum, TablesRec.Lendee.CardNum%@NL@% IF NOT EOF(cBooksOutTableNum) THEN%@NL@% DO%@NL@% RETRIEVE cBooksOutTableNum, TablesRec.OutBooks%@NL@% IF TablesRec.OutBooks.CardNum = TablesRec.Lendee.CardNum THEN%@NL@% IF GETINDEX$(cBookStockTableNum) <> "IDIndex" THEN%@NL@% SETINDEX cBookStockTableNum, "IDIndex"%@NL@% END IF%@NL@% SEEKEQ cBookStockTableNum, TablesRec.OutBooks.IDnum%@NL@% IF NOT EOF(cBookStockTableNum) THEN%@NL@% RETRIEVE cBookStockTableNum, TablesRec.Inventory%@NL@% Titles(Index) = RTRIM$(TablesRec.Inventory.Title)%@NL@% ThisSize = LEN(RTRIM$(Titles(Index)))%@NL@% IF ThisSize > Biggest THEN%@NL@% Biggest = ThisSize%@NL@% END IF%@NL@% Index = Index + 1%@NL@% END IF%@NL@% END IF%@NL@% MOVENEXT cBooksOutTableNum%@NL@% LOOP UNTIL EOF(cBooksOutTableNum)%@NL@% ELSE%@NL@% Alert$ = RevName$ + " currently has no books checked out"%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% END IF%@NL@% IF Index <> 0 THEN%@NL@% HeadMessage$ = " Books borrowed by " + RevName$ + " "%@NL@% FootMessage$ = " Press a key to continue "%@NL@% CALL PeekWindow(Titles(), HeadMessage$, FootMessage$, Biggest)%@NL@% CALL DrawTable(TablesRec.TableNum)%@NL@% CALL ShowMessage(KEYSMESSAGE, 0)%@NL@% END IF%@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The BorrowBook SUB prompts the user to enter the name of the Cardholder*%@AE@%%@NL@% %@AB@%'* who wants to borrow the book, then updates all the other tables accord-*%@AE@%%@NL@% %@AB@%'* ingly. The name or cardnumber can be entered --- if conversion to a *%@AE@%%@NL@% %@AB@%'* number fails, the user entered a name. If the name isn't of the right *%@AE@%%@NL@% %@AB@%'* format, it is transposed to last-first, comma delimited. If no exact *%@AE@%%@NL@% %@AB@%'* match is found, the next best match is attempted and presented for the *%@AE@%%@NL@% %@AB@%'* approval of the user.%@AE@%%@NL@% %@AB@%'* Parameter *%@AE@%%@NL@% %@AB@%'* TablesRec RecStruct type variable holding current table information *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB BorrowBook (TablesRec AS RecStruct)%@NL@% %@NL@% DIM SaveBook AS RecStruct%@NL@% DIM PeekString(10) AS STRING%@NL@% %@NL@% Prompt$ = "Name or Card Number to Seek: "%@NL@% SaveBook = TablesRec ' Save book information%@NL@% %@AB@% ' Prompt user and catch keystroke%@AE@%%@NL@% CALL ShowMessage("Enter borrower cardnumber or name: ", 1)%@NL@% FirstChar = ASC(ReturnKey$) ' ReturnKey$ is a function%@NL@% IF FirstChar = ESCAPE THEN CALL ShowMessage("", 0): EXIT SUB%@NL@% Answer$ = MakeString$(FirstChar, Prompt$)%@NL@% IF FirstChar = ESCAPE THEN CALL ShowMessage("", 0): EXIT SUB%@NL@% NumToCheck& = VAL(Answer$)%@NL@% IF NumToCheck& = 0 THEN%@NL@% IF INSTR(Answer$, ",") = 0 THEN%@NL@% StraightName$ = Answer$%@NL@% Answer$ = TransposeName$(Answer$)%@NL@% ELSE%@NL@% StraightName$ = TransposeName$(Answer$)%@NL@% END IF%@NL@% %@NL@% SETINDEX cCardHoldersTableNum, "NameIndexCH"%@NL@% SEEKEQ cCardHoldersTableNum, Answer$%@NL@% IF EOF(cCardHoldersTableNum) THEN%@NL@% MOVEFIRST cCardHoldersTableNum%@NL@% SEEKGE cCardHoldersTableNum, Answer$ ' If EQ fails, try GE%@NL@% IF EOF(cCardHoldersTableNum) THEN%@NL@% Alert$ = "Sorry, couldn't find " + StraightName$ + " in CardHolders table..."%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% EXIT SUB%@NL@% END IF%@NL@% END IF%@NL@% IF NOT EOF(cCardHoldersTableNum) THEN%@NL@% RETRIEVE cCardHoldersTableNum, SaveBook.Lendee%@NL@% IF TEXTCOMP(LEFT$(SaveBook.Lendee.TheName, 2), LEFT$(Answer$, 2)) = 0 THEN%@NL@% NumToCheck& = SaveBook.Lendee.CardNum%@NL@% ELSE%@NL@% Alert$ = "Sorry, couldn't match " + StraightName$ + " in CardHolders table..."%@NL@% CALL ShowMessage(Alert$, 0): ' SLEEP: EraseMessage%@NL@% EXIT SUB%@NL@% END IF%@NL@% END IF%@NL@% ELSE%@NL@% SETINDEX cCardHoldersTableNum, "CardNumIndexCH"%@NL@% SEEKEQ cCardHoldersTableNum, NumToCheck&%@NL@% IF EOF(cCardHoldersTableNum) THEN%@NL@% Alert$ = "Sorry, could not match " + Answer$%@NL@% CALL ShowMessage(Alert$, 0): ' SLEEP: EraseMessage%@NL@% EXIT SUB%@NL@% ELSE%@NL@% RETRIEVE cCardHoldersTableNum, SaveBook.Lendee%@NL@% NumToCheck& = SaveBook.Lendee.CardNum%@NL@% END IF%@NL@% END IF%@NL@% %@AB@% ' You can replace this phoney date with a call to%@AE@%%@NL@% DateDue# = 32950# ' the Date/Time library as shown on these 2 lines:%@NL@% %@AB@%'DateDue# = Now# + 30#%@AE@%%@NL@% %@AB@%'DateDue$ = STR$(Month&(DateDue#)) + "/" + LTRIM$(STR$(Day&(DateDue#))) + "/" + LTRIM$(STR$(Year&(DateDue#)))%@AE@%%@NL@% %@NL@% %@AB@%' Show the information on the Cardholder you found...%@AE@%%@NL@% DO%@NL@% PeekString(0) = " This book will be checked out to: "%@NL@% PeekString(1) = ""%@NL@% PeekString(2) = RTRIM$(SaveBook.Lendee.TheName)%@NL@% PeekString(3) = RTRIM$(SaveBook.Lendee.Street)%@NL@% PeekString(4) = RTRIM$(SaveBook.Lendee.City) + ", " + RTRIM$(SaveBook.Lendee.State)%@NL@% PeekString(5) = "Card number: " + STR$(SaveBook.Lendee.CardNum)%@NL@% PeekString(6) = ""%@NL@% PeekString(7) = "The Due Date will be " + STR$(DateDue# + 30)%@NL@% IF LEN(DateDue$) THEN PeekString(7) = "The Due Date will be " + DateDue$%@NL@% FOR Index = 0 TO 8%@NL@% ThisSize = LEN(RTRIM$(PeekString(Index)))%@NL@% IF ThisSize > Biggest THEN%@NL@% Biggest = ThisSize%@NL@% END IF%@NL@% NEXT Index%@NL@% %@NL@% HeadMessage$ = " Cardholder checking out this book "%@NL@% FootMessage$ = " Press ENTER to confirm this checkout "%@NL@% Alert$ = "Press N seek next similar match, ESC to abort checkout"%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% CALL PeekWindow(PeekString(), HeadMessage$, FootMessage$, Biggest)%@NL@% %@NL@% %@AB@% ' Let the user press "N" to see the next best match, ESC to abort checkout%@AE@%%@NL@% %@AB@% ' anything else to confirm this as person to whom to check book out to%@AE@%%@NL@% %@NL@% Reply$ = ReturnKey$%@NL@% SELECT CASE Reply$%@NL@% CASE CHR$(ESCAPE)%@NL@% DoneFlag = TRUE%@NL@% CASE "N", "n"%@NL@% MOVENEXT cCardHoldersTableNum%@NL@% IF EOF(cCardHoldersTableNum) THEN%@NL@% DoneFlag = TRUE%@NL@% ELSE%@NL@% RETRIEVE cCardHoldersTableNum, SaveBook.Lendee%@NL@% NumToCheck& = SaveBook.Lendee.CardNum%@NL@% IF LEFT$(SaveBook.Lendee.TheName, 2) <> LEFT$(Answer$, 2) THEN%@NL@% DoneFlag = TRUE%@NL@% END IF%@NL@% END IF%@NL@% CASE ELSE%@NL@% TablesRec.OutBooks.CardNum = NumToCheck&%@NL@% TablesRec.OutBooks.IDnum = SaveBook.Inventory.IDnum%@NL@% TablesRec.OutBooks.DueDate = DateDue#%@NL@% DoneFlag = TRUE%@NL@% MOVEFIRST (cBooksOutTableNum)%@NL@% INSERT cBooksOutTableNum, TablesRec.OutBooks%@NL@% CALL ShowMessage("", 0)%@NL@% END SELECT%@NL@% LOOP UNTIL DoneFlag%@NL@% %@NL@% CALL DrawTable(TablesRec.TableNum)%@NL@% CALL ShowMessage(KEYSMESSAGE, 0)%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% %@AB@%'* The Borrowed FUNCTION simply makes sure there are records in the *%@AE@%%@NL@% %@AB@%'* BooksOut table. If there are none, a message is displayed *%@AE@%%@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% FUNCTION Borrowed%@NL@% IF LOF(cBooksOutTableNum) = 0 THEN%@NL@% CALL ShowMessage("Sorry, no records in the BooksOut table", 0): SLEEP%@NL@% Borrowed = FALSE%@NL@% ELSE%@NL@% Borrowed = TRUE%@NL@% END IF%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The CatchKey function gets a keystroke and returns TRUE if it was ENTER,*%@AE@%%@NL@% %@AB@%'* otherwise it returns FALSE. *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION CatchKey%%@NL@% DO%@NL@% Answer$ = INKEY$%@NL@% LOOP WHILE Answer$ = ""%@NL@% SELECT CASE ASC(Answer$)%@NL@% CASE ENTER%@NL@% CatchKey% = -1%@NL@% CASE ELSE%@NL@% CatchKey% = 0%@NL@% END SELECT%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The GetStatus FUNCTION looks up the status of a book in the BooksOut *%@AE@%%@NL@% %@AB@%'* table. If the SEEK fails it means the book isn't checked out, and that *%@AE@%%@NL@% %@AB@%'* message is displayed. Otherwise, it is placed in DateToShow parameter. *%@AE@%%@NL@% %@AB@%'* The final message about retrieving borrow info relates to LendeeProfile*%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TablesRec Structure containing the information about all the tables*%@AE@%%@NL@% %@AB@%'* DateToShow The due date to show in the ShowStatus SUB *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION GetStatus (TablesRec AS RecStruct, DateToShow#)%@NL@% IF GETINDEX$(cBooksOutTableNum) <> "IDIndexBO" THEN%@NL@% SETINDEX cBooksOutTableNum, "IDIndexBO"%@NL@% END IF%@NL@% SEEKEQ cBooksOutTableNum, TablesRec.Inventory.IDnum%@NL@% IF NOT EOF(cBooksOutTableNum) THEN%@NL@% RETRIEVE cBooksOutTableNum, TablesRec.OutBooks%@NL@% ELSE%@NL@% Alert$ = "This book is not checked out" ' the book wasn't in BooksOut%@NL@% CALL ShowMessage(Alert$, 0) ' table, so it wasn't out%@NL@% DateToShow# = 0: GetStatus = FALSE%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% DateToShow# = TablesRec.OutBooks.DueDate#%@NL@% GetStatus = TRUE%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The LendeeProfile takes the IDnum of the currently displayed book, then*%@AE@%%@NL@% %@AB@%'* looks that up in the BooksOut table and fetches the CardHolder record *%@AE@%%@NL@% %@AB@%'* that corresponds to the CardNum entry in BooksOut. Then the CardNum is *%@AE@%%@NL@% %@AB@%'* looked up in the CardHolders table and the borrower information shown. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TablesRec Contains information on all the tables in the database *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB LendeeProfile (TablesRec AS RecStruct)%@NL@% %@AB@% ' Make sure the CardHolders table actually has records%@AE@%%@NL@% IF LOF(cCardHoldersTableNum) = 0 THEN%@NL@% CALL ShowMessage("Sorry, there are no cardholder records", 0): SLEEP%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@AB@% ' Create an array to hold information from CardHolders table%@AE@%%@NL@% DIM LendeeInfo(10) AS STRING%@NL@% %@AB@% ' Set the index if it is not the one you want%@AE@%%@NL@% IF GETINDEX$(cBooksOutTableNum) <> "IDIndexBO" THEN%@NL@% SETINDEX cBooksOutTableNum, "IDIndexBO"%@NL@% END IF%@NL@% SEEKEQ cBooksOutTableNum, TablesRec.Inventory.IDnum ' Seek the record.%@NL@% IF EOF(cBooksOutTableNum) THEN ' If you find it,%@NL@% CALL ShowMessage("This book is not checked out", 0) ' the book is out,%@NL@% EXIT SUB ' otherwise not.%@NL@% ELSE ' If it's there,%@NL@% RETRIEVE cBooksOutTableNum, TablesRec.OutBooks ' fetch it.%@NL@% %@NL@% %@AB@% ' If the CardNum exists, set an index in CardHolders and SEEK the%@AE@%%@NL@% %@AB@% ' CardNum. If SEEK fails, print a warning; if it succeeds, get the%@AE@%%@NL@% %@AB@% ' information about the borrower, and display it using PeekWindow%@AE@%%@NL@% %@NL@% IF TablesRec.OutBooks.CardNum <> 0 THEN%@NL@% IF GETINDEX$(cCardHoldersTableNum) <> "CardNumIndexCH" THEN%@NL@% SETINDEX cCardHoldersTableNum, "CardNumIndexCH"%@NL@% END IF%@NL@% SEEKEQ cCardHoldersTableNum, TablesRec.OutBooks.CardNum%@NL@% IF EOF(cBooksOutTableNum) THEN%@NL@% Alert$ = "Cardholder number associated with book ID is not valid"%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% EXIT SUB%@NL@% ELSE%@NL@% RETRIEVE cCardHoldersTableNum, TablesRec.Lendee%@NL@% LendeeInfo(0) = RTRIM$(TablesRec.Lendee.TheName)%@NL@% LendeeInfo(1) = ""%@NL@% LendeeInfo(2) = RTRIM$(TablesRec.Lendee.Street)%@NL@% LendeeInfo(3) = RTRIM$(TablesRec.Lendee.City)%@NL@% LendeeInfo(4) = RTRIM$(TablesRec.Lendee.State)%@NL@% LendeeInfo(5) = LTRIM$(STR$(TablesRec.Lendee.Zip))%@NL@% LendeeInfo(7) = STR$(TablesRec.Lendee.CardNum)%@NL@% LendeeInfo(6) = ""%@NL@% LendeeInfo(7) = "Card number: " + LendeeInfo(7)%@NL@% LendeeInfo(8) = ""%@NL@% FOR Index = 1 TO 6%@NL@% ThisBig = LEN(LendeeInfo(Index))%@NL@% IF ThisBig > BiggestYet THEN%@NL@% BiggestYet = ThisBig%@NL@% END IF%@NL@% NEXT Index%@NL@% Alert$ = "Press V to access the record for this cardholder"%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% HeadMessage$ = "Borrower of this Book"%@NL@% FootMessage$ = "Press a key to clear box"%@NL@% CALL ClearEm(TablesRec.TableNum, 1, 1, 1, 1, 1, 1)%@NL@% CALL PeekWindow(LendeeInfo(), HeadMessage$, FootMessage$, BiggestYet)%@NL@% CALL DrawTable(TablesRec.TableNum)%@NL@% CALL ShowMessage(KEYSMESSAGE, 0)%@NL@% END IF%@NL@% END IF%@NL@% END IF%@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The MakeOver SUB lets the user input the names of properly formatted *%@AE@%%@NL@% %@AB@%'* text files, then creates a database file of the same type as BOOKS.MDB. *%@AE@%%@NL@% %@AB@%'* There is also a prompt for the new database name. The text files must *%@AE@%%@NL@% %@AB@%'* contain comma-delimited fields, with strings within double quote marks. *%@AE@%%@NL@% %@AB@%'* The last part of this SUB demonstrates how indexes are created. You need*%@AE@%%@NL@% %@AB@%'* to have loaded PROISAMD.EXE to run this procedure. *%@AE@%%@NL@% %@AB@%'* Parameters: *%@AE@%%@NL@% %@AB@%'* Big Rec User-defined type containing all table information *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB MakeOver (BigRec AS RecStruct)%@NL@% CLOSE%@NL@% Alert$ = "Type name of file containing Cardholders table data: "%@NL@% CALL ShowMessage(Alert$, 1)%@NL@% INPUT "", CardFile$%@NL@% Alert$ = "Type name of file containing BooksOut table data: "%@NL@% CALL ShowMessage(Alert$, 1)%@NL@% INPUT "", OutBooks$%@NL@% Alert$ = "Type name of file containing BookStock table data: "%@NL@% CALL ShowMessage(Alert$, 1)%@NL@% INPUT "", BookFile$%@NL@% Alert$ = "Type name of ISAM file to create: "%@NL@% CALL ShowMessage(Alert$, 1)%@NL@% INPUT "", IsamFile$%@NL@% IF UCASE$(IsamFile$) = "BOOKS.MDB" THEN KILL "BOOKS.MDB"%@NL@% CALL ShowMessage("Loading database...", 0)%@NL@% %@NL@% CLOSE%@NL@% ON LOCAL ERROR GOTO FileHandler%@NL@% LenFileNo% = 10%@NL@% OPEN CardFile$ FOR INPUT AS LenFileNo%%@NL@% OutFileNo% = 11%@NL@% OPEN OutBooks$ FOR INPUT AS OutFileNo%%@NL@% RecFileNo% = 12%@NL@% OPEN BookFile$ FOR INPUT AS RecFileNo%%@NL@% ON ERROR GOTO 0%@NL@% %@NL@% %@AB@% ' Open the database and the BookStock table%@AE@%%@NL@% OPEN IsamFile$ FOR ISAM Books "BookStock" AS cBookStockTableNum%@NL@% OPEN IsamFile$ FOR ISAM Borrowers "CardHolders" AS cCardHoldersTableNum%@NL@% OPEN IsamFile$ FOR ISAM BookStatus "BooksOut" AS cBooksOutTableNum%@NL@% CALL ShowMessage(" Opened all isam tables", 0)%@NL@% %@NL@% SeqFile% = LenFileNo%@NL@% DO WHILE (Reader%(BigRec, SeqFile%))%@NL@% INSERT cCardHoldersTableNum, BigRec.Lendee%@NL@% LOOP%@NL@% SeqFile% = OutFileNo%@NL@% DO WHILE (Reader%(BigRec, SeqFile))%@NL@% INSERT cBooksOutTableNum, BigRec.OutBooks%@NL@% LOOP%@NL@% SeqFile = RecFileNo%@NL@% DO WHILE (Reader%(BigRec, SeqFile))%@NL@% INSERT cBookStockTableNum, BigRec.Inventory%@NL@% LOOP%@NL@% CALL ShowMessage("Finished reading in records---Indexes next", 0)%@NL@% %@AB@%' These indexes are already in the BOOKS.MDB database --- the following%@AE@%%@NL@% %@AB@%' is the syntax that was used to create them%@AE@%%@NL@% %@NL@% ON LOCAL ERROR GOTO FileHandler%@NL@% CREATEINDEX cBookStockTableNum, "TitleIndexBS", 0, "Title"%@NL@% CREATEINDEX cBookStockTableNum, "AuthorIndexBS", 0, "Author"%@NL@% CREATEINDEX cBookStockTableNum, "PubIndexBS", 0, "Publisher"%@NL@% CREATEINDEX cBookStockTableNum, "IDIndex", 1, "IDnum" ' Note unique index%@NL@% CREATEINDEX cBookStockTableNum, "BigIndex", 0, "Title", "Author", "IDnum"%@NL@% %@NL@% CREATEINDEX cBooksOutTableNum, "IDIndexBO", 0, "IDnum"%@NL@% CREATEINDEX cBooksOutTableNum, "CardNumIndexBO", 0, "CardNum"%@NL@% %@NL@% CREATEINDEX cCardHoldersTableNum, "NameIndexCH", 0, "TheName"%@NL@% CREATEINDEX cCardHoldersTableNum, "StateIndexCH", 0, "State"%@NL@% CREATEINDEX cCardHoldersTableNum, "ZipIndexCH", 0, "Zip"%@NL@% CREATEINDEX cCardHoldersTableNum, "CardNumIndexCH", 1, "CardNum" ' Unique index%@NL@% ON ERROR GOTO 0%@NL@% CALL ShowMessage(" All done with indexes...", 0)%@NL@% %@AB@% 'CLOSE%@AE@%%@NL@% %@NL@% EXIT SUB%@NL@% %@NL@% FileHandler:%@NL@% IF ERR = 73 THEN%@NL@% CALL ShowMessage("You need to Exit QBX and load PROISAMD /Ib:24 /Ii:16", 0)%@NL@% ELSEIF ERR = 10 THEN%@NL@% Alert$ = "Finished appending the records to " + IsamFile$%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% END%@NL@% ELSEIF ERR = 86 THEN%@NL@% Alert$ = "Tried to add record with duplicate value on a unique index"%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% ELSE%@NL@% CALL ShowMessage("Can't find textfiles needed to make the database", 0)%@NL@% END IF%@NL@% END%@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The PeekWindow SUB displays the elements of the OutBookNames array in *%@AE@%%@NL@% %@AB@%'* a window on top of the currently displayed table. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* OutBookNames Array of strings containing lines displayed in window *%@AE@%%@NL@% %@AB@%'* Header$ String to show at top of window *%@AE@%%@NL@% %@AB@%'* Footer$ String to show at bottom of window *%@AE@%%@NL@% %@AB@%'* BiggestYet Length of the longest string to be shown *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB PeekWindow (OutBookNames() AS STRING, Header$, Footer$, BiggestYet%)%@NL@% HeadLen = LEN(Header$) ' + 4%@NL@% FootLen = LEN(Footer$) ' + 4%@NL@% IF HeadLen > FootLen THEN Bigger = HeadLen ELSE Bigger = FootLen%@NL@% IF Bigger > BiggestYet THEN BiggestYet = Bigger%@NL@% %@NL@% InnerBox = 9 ' InnerBox is total number of lines allowed inside box%@NL@% first = 0: last = 8%@NL@% DO%@NL@% %@NL@% %@AB@% ' Calculate header and footer placement%@AE@%%@NL@% %@NL@% IF (HeadLen MOD 2) THEN%@NL@% HeadStart = ((BiggestYet - HeadLen) \ 2) + 13%@NL@% ELSE%@NL@% HeadStart = ((BiggestYet - HeadLen) \ 2) + 12%@NL@% END IF%@NL@% IF (FootLen MOD 2) THEN%@NL@% FootStart = ((BiggestYet - FootLen) \ 2) + 13%@NL@% ELSE%@NL@% FootStart = ((BiggestYet - FootLen) \ 2) + 12%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Print a box and fill it with titles%@AE@%%@NL@% Inset = TABLETOP + 2%@NL@% %@NL@% Lines = Inset + 1%@NL@% IF MoreBoxes = FALSE THEN%@NL@% LOCATE Inset, 3%@NL@% PRINT " ╔"; STRING$(BiggestYet + 2, CHR$(205)); "╗"%@NL@% END IF%@NL@% FOR PrintEm = first TO last%@NL@% LOCATE Lines + NextSpace, 3%@NL@% PRINT " ║ "; OutBookNames(Total); SPACE$(BiggestYet - LEN((OutBookNames(Total)))); " ║"%@NL@% Total = Total + 1: NextSpace = NextSpace + 1%@NL@% NEXT PrintEm%@NL@% IF MoreBoxes = FALSE THEN ' Means first group%@NL@% LOCATE Lines + NextSpace, 3%@NL@% PRINT " ╚"; STRING$(BiggestYet + 2, CHR$(205)); "╝"%@NL@% COLOR BACKGROUND, FOREGROUND + BRIGHT%@NL@% LOCATE Inset, HeadStart%@NL@% PRINT Header$; '"╡ "; Header$; " ╞"%@NL@% LOCATE Lines + NextSpace, FootStart%@NL@% PRINT Footer$ '"╡ "; Footer$; " ╞"%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% END IF%@NL@% SLEEP%@NL@% first = first + InnerBox: last = last + InnerBox%@NL@% NextSpace = 0: HowMany = 0%@NL@% %@NL@% MoreBoxes = TRUE%@NL@% %@NL@% LOOP UNTIL LEN(RTRIM$(OutBookNames(Total))) = 0%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The Reader FUNCTION reads specified text files and returns each line *%@AE@%%@NL@% %@AB@%'* as a separate record for the corresponding table. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* BigRec RecStruct variable containing information on tables *%@AE@%%@NL@% %@AB@%'* SeqFile File number used to open the text file to be read%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% FUNCTION Reader% (BigRec AS RecStruct, SeqFile%)%@NL@% SELECT CASE SeqFile%@NL@% CASE 10%@NL@% IF NOT EOF(SeqFile) THEN%@NL@% INPUT #SeqFile, BigRec.Lendee.CardNum, BigRec.Lendee.Zip, BigRec.Lendee.TheName, BigRec.Lendee.City, BigRec.Lendee.Street, BigRec.Lendee.State%@NL@% Reader = -1%@NL@% ELSE%@NL@% Reader = 0%@NL@% END IF%@NL@% CASE 11%@NL@% IF NOT EOF(SeqFile) THEN%@NL@% INPUT #SeqFile, BigRec.OutBooks.IDnum, BigRec.OutBooks.CardNum, BigRec.OutBooks.DueDate%@NL@% Reader = -1%@NL@% ELSE%@NL@% Reader = 0%@NL@% END IF%@NL@% CASE 12%@NL@% IF NOT EOF(SeqFile) THEN%@NL@% INPUT #SeqFile, BigRec.Inventory.IDnum, BigRec.Inventory.Price, BigRec.Inventory.Edition, BigRec.Inventory.Title, BigRec.Inventory.Author, BigRec.Inventory.Publisher%@NL@% Reader = -1%@NL@% ELSE%@NL@% Reader = 0%@NL@% END IF%@NL@% END SELECT%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The ReturnBook SUB checks the book currently being displayed back into *%@AE@%%@NL@% %@AB@%'* the library --- that is, it eliminates the appropriate entry from the *%@AE@%%@NL@% %@AB@%'* BooksOut table. It checks to see if the book is overdue, and if so, it *%@AE@%%@NL@% %@AB@%'* displays the amount of the fine to be paid. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* TablesRec RecStruct type variable holding current table information *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB ReturnBook (TablesRec AS RecStruct, DueDate#)%@NL@% %@NL@% DIM ReturnLines(10) AS STRING%@NL@% %@NL@% Alert$ = "Press ENTER to check current book in, N to abort checkin..."%@NL@% CALL ShowMessage(Alert$, 0)%@NL@% %@NL@% SETINDEX cBooksOutTableNum, "IDIndexBO"%@NL@% SEEKEQ cBooksOutTableNum, TablesRec.Inventory.IDnum%@NL@% IF NOT EOF(cBooksOutTableNum) THEN%@NL@% RETRIEVE cBooksOutTableNum, TablesRec.OutBooks%@NL@% END IF%@NL@% SETINDEX cCardHoldersTableNum, "CardNumIndexCH"%@NL@% SEEKEQ cCardHoldersTableNum, TablesRec.OutBooks.CardNum%@NL@% %@NL@% IF NOT EOF(cBooksOutTableNum) THEN%@NL@% IF LOF(cCardHoldersTableNum) THEN%@NL@% RETRIEVE cCardHoldersTableNum, TablesRec.Lendee%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% Today# = 32000 'Replace this with call to DTFMTER.QLB library routine%@NL@% %@AB@% 'as shown on the next 2 lines%@AE@%%@NL@% %@AB@%'Today# = Now#%@AE@%%@NL@% %@AB@%'ShowDate$ = STR$(Month&(Today#)) + "/" + LTRIM$(STR$(Day&(Today#))) + "/" + LTRIM$(STR$(Year&(Today#)))%@AE@%%@NL@% IF Today# > TablesRec.OutBooks.DueDate THEN%@NL@% Fine = Today# - TablesRec.OutBooks.DueDate%@NL@% END IF%@NL@% %@NL@% DateDue# = (TablesRec.OutBooks.DueDate)%@NL@% %@AB@%' If you have DTFMTER.QLB loaded, use in to get date to display%@AE@%%@NL@% %@AB@%' DateDue$ = STR$(Month&(DateDue#)) + "/" + LTRIM$(STR$(Day&(DateDue#))) + "/" + LTRIM$(STR$(Year&(DateDue#)))%@AE@%%@NL@% ReturnLines(0) = ""%@NL@% ReturnLines(1) = RTRIM$(TablesRec.Inventory.Title)%@NL@% ReturnLines(2) = "is checked out to card number: " + STR$(TablesRec.OutBooks.CardNum)%@NL@% ReturnLines(3) = RTRIM$(TablesRec.Lendee.TheName)%@NL@% ReturnLines(4) = ""%@NL@% ReturnLines(5) = "Today's Date: " + STR$(Today#) + " - A phoney date"%@NL@% IF LEN(ShowDate$) THEN ReturnLines(5) = "Today's Date: " + ShowDate$%@NL@% ReturnLines(6) = "Due Date of Book: " + STR$(TablesRec.OutBooks.DueDate)%@NL@% IF LEN(DateDue$) THEN ReturnLines(6) = "Due Date of Book: " + DateDue$%@NL@% ReturnLines(7) = "Fine Payable: $" + STR$(ABS(Fine / 100))%@NL@% ReturnLines(8) = ""%@NL@% ReturnLines(9) = ""%@NL@% FOR Index = 0 TO 10%@NL@% ThisOne = LEN(ReturnLines(Index))%@NL@% IF ThisOne > BiggestYet THEN BiggestYet = ThisOne%@NL@% NEXT Index%@NL@% Header$ = "Press ENTER to check book in..."%@NL@% Footer$ = "Press N or n to abort checkin..."%@NL@% CALL PeekWindow(ReturnLines(), Header$, Footer$, BiggestYet%)%@NL@% %@NL@% IF CatchKey THEN ' If user confirms, delete%@NL@% IF LOF(cBooksOutTableNum) <> 0 THEN ' the entry to BooksOut table%@NL@% DELETE cBooksOutTableNum%@NL@% END IF%@NL@% END IF%@NL@% CALL DrawTable(TablesRec.TableNum)%@NL@% CALL EraseMessage%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% %@AB@%'* The ShowStatus SUB uses the due date associated with the book IDnum from*%@AE@%%@NL@% %@AB@%'* of the BooksOut table. This date is in serial form which is not decoded *%@AE@%%@NL@% %@AB@%'* here, but can be decoded with the date/time function library supplied *%@AE@%%@NL@% %@AB@%'* with BASIC 7.0. The due date is displayed centered on the top line of *%@AE@%%@NL@% %@AB@%'* the ShowMessage box. *%@AE@%%@NL@% %@AB@%'* Parameters *%@AE@%%@NL@% %@AB@%'* Stat$ Message introducing the due date when displayed in its box *%@AE@%%@NL@% %@AB@%'* ValueToShow The due date of the book from the BooksOut table *%@AE@%%@NL@% %@AB@%'***************************************************************************%@AE@%%@NL@% SUB ShowStatus (Stat$, ValueToShow AS DOUBLE)%@NL@% %@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% DataEndLine$ = STRING$(60, 205) 'redraw the bottom line%@NL@% %@NL@% StringToShow$ = Stat$ ' Figure out where to locate the text%@NL@% IF ValueToShow = 0 THEN%@NL@% LOCATE TABLEEND, 4%@NL@% PRINT DataEndLine$%@NL@% EXIT SUB%@NL@% ELSE%@NL@% %@AB@% ' The dates in the file are in serial form. Use the DTFMTER.QLB library%@AE@%%@NL@% %@AB@% ' to decode serial dates for normal display. In the code below, the%@AE@%%@NL@% %@AB@% ' calls to the library are commented out.%@AE@%%@NL@% %@NL@% %@AB@% 'TheDate$ = STR$(Month&(ValueToShow)) + "/" + LTRIM$(STR$(Day&(ValueToShow))) + "/" + LTRIM$(STR$(Year&(ValueToShow)))%@AE@%%@NL@% IF Stat$ = " Total records in table: " OR LEN(TheDate$) = 0 THEN%@NL@% StringToShow$ = StringToShow$ + " " + STR$(ValueToShow)%@NL@% ELSE%@NL@% StringToShow$ = StringToShow$ + " " + TheDate$%@NL@% END IF%@NL@% HowLong = LEN(StringToShow$)%@NL@% PlaceStatus = (73 \ 2) - (HowLong \ 2)%@NL@% StatusSpace$ = CHR$(181) + STRING$(HowLong, 32) + CHR$(198)%@NL@% END IF%@NL@% LOCATE TABLEEND, PlaceStatus%@NL@% PRINT StatusSpace$%@NL@% COLOR BACKGROUND, BRIGHT + FOREGROUND%@NL@% LOCATE TABLEEND, PlaceStatus + 1%@NL@% PRINT StringToShow$%@NL@% COLOR FOREGROUND, BACKGROUND%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%CAL.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\CAL.BAS%@AE@%%@NL@% %@NL@% DEFINT A-Z ' Default variable type is integer.%@NL@% %@NL@% %@AB@%' Define a data type for the names of the months and the%@AE@%%@NL@% %@AB@%' number of days in each:%@AE@%%@NL@% TYPE MonthType%@NL@% Number AS INTEGER ' Number of days in the month%@NL@% MName AS STRING * 9 ' Name of the month%@NL@% END TYPE%@NL@% %@NL@% %@AB@%' Declare procedures used:%@AE@%%@NL@% DECLARE FUNCTION IsLeapYear% (N%)%@NL@% DECLARE FUNCTION GetInput% (Prompt$, Row%, LowVal%, HighVal%)%@NL@% %@NL@% DECLARE SUB PrintCalendar (Year%, Month%)%@NL@% DECLARE SUB ComputeMonth (Year%, Month%, StartDay%, TotalDays%)%@NL@% %@NL@% DIM MonthData(1 TO 12) AS MonthType%@NL@% %@NL@% %@AB@%' Initialize month definitions from DATA statements below:%@AE@%%@NL@% FOR I = 1 TO 12%@NL@% READ MonthData(I).MName, MonthData(I).Number%@NL@% NEXT%@NL@% %@NL@% %@AB@%' Main loop, repeat for as many months as desired:%@AE@%%@NL@% DO%@NL@% CLS%@NL@% %@NL@% %@AB@% ' Get year and month as input:%@AE@%%@NL@% Year = GetInput("Year (1899 to 2099): ", 1, 1899, 2099)%@NL@% Month = GetInput("Month (1 to 12): ", 2, 1, 12)%@NL@% %@NL@% %@AB@% ' Print the calendar:%@AE@%%@NL@% PrintCalendar Year, Month%@NL@% %@AB@%' Another Date?%@AE@%%@NL@% LOCATE 13, 1 ' Locate in 13th row, 1st column.%@NL@% PRINT "New Date? "; ' Keep cursor on same line.%@NL@% LOCATE , , 1, 0, 13 ' Turn cursor on and make it one%@NL@% %@AB@% ' character high.%@AE@%%@NL@% Resp$ = INPUT$(1) ' Wait for a key press.%@NL@% PRINT Resp$ ' Print the key pressed.%@NL@% %@NL@% LOOP WHILE UCASE$(Resp$) = "Y"%@NL@% END%@NL@% %@NL@% %@AB@%' Data for the months of a year:%@AE@%%@NL@% DATA January, 31, February, 28, March, 31%@NL@% DATA April, 30, May, 31, June, 30, July, 31, August, 31%@NL@% DATA September, 30, October, 31, November, 30, December, 31%@NL@% %@NL@% %@AB@%' ====================== COMPUTEMONTH =====================%@AE@%%@NL@% %@AB@%' Computes the first day and the total days in a month%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ComputeMonth (Year, Month, StartDay, TotalDays) STATIC%@NL@% SHARED MonthData() AS MonthType%@NL@% %@NL@% CONST LEAP = 366 MOD 7%@NL@% CONST NORMAL = 365 MOD 7%@NL@% %@NL@% %@AB@% ' Calculate total number of days (NumDays) since 1/1/1899:%@AE@%%@NL@% %@NL@% %@AB@% ' Start with whole years:%@AE@%%@NL@% NumDays = 0%@NL@% FOR I = 1899 TO Year - 1%@NL@% IF IsLeapYear(I) THEN ' If leap year,%@NL@% NumDays = NumDays + LEAP ' add 366 MOD 7.%@NL@% ELSE ' If normal year,%@NL@% NumDays = NumDays + NORMAL ' add 365 MOD 7.%@NL@% END IF%@NL@% NEXT%@NL@% %@NL@% %@AB@% ' Next, add in days from whole months:%@AE@%%@NL@% FOR I = 1 TO Month - 1%@NL@% NumDays = NumDays + MonthData(I).Number%@NL@% NEXT%@NL@% %@NL@% %@AB@% ' Set the number of days in the requested month:%@AE@%%@NL@% TotalDays = MonthData(Month).Number%@NL@% %@NL@% %@AB@% ' Compensate if requested year is a leap year:%@AE@%%@NL@% IF IsLeapYear(Year) THEN%@NL@% %@NL@% %@AB@% ' If after February, add one to total days:%@AE@%%@NL@% IF Month > 2 THEN%@NL@% NumDays = NumDays + 1%@NL@% %@NL@% %@AB@% ' If February, add one to the month's days:%@AE@%%@NL@% ELSEIF Month = 2 THEN%@NL@% TotalDays = TotalDays + 1%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' 1/1/1899 was a Sunday, so calculating "NumDays MOD 7"%@AE@%%@NL@% %@AB@% ' gives the day of week (Sunday = 0, Monday = 1, Tuesday%@AE@%%@NL@% %@AB@% ' = 2, and so on) for the first day of the input month:%@AE@%%@NL@% StartDay = NumDays MOD 7%@NL@% END SUB%@NL@% %@NL@% %@AB@%' ======================== GETINPUT =======================%@AE@%%@NL@% %@AB@%' Prompts for input, then tests for a valid range%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION GetInput (Prompt$, Row, LowVal, HighVal) STATIC%@NL@% %@NL@% %@AB@% ' Locate prompt at specified row, turn cursor on and%@AE@%%@NL@% %@AB@% ' make it one character high:%@AE@%%@NL@% LOCATE Row, 1, 1, 0, 13%@NL@% PRINT Prompt$;%@NL@% %@NL@% %@AB@% ' Save column position:%@AE@%%@NL@% Column = POS(0)%@NL@% %@NL@% %@AB@% ' Input value until it's within range:%@AE@%%@NL@% DO%@NL@% LOCATE Row, Column ' Locate cursor at end of prompt.%@NL@% PRINT SPACE$(10) ' Erase anything already there.%@NL@% LOCATE Row, Column ' Relocate cursor at end of prompt.%@NL@% INPUT "", Value ' Input value with no prompt.%@NL@% LOOP WHILE (Value < LowVal OR Value > HighVal)%@NL@% %@NL@% %@AB@% ' Return valid input as value of function:%@AE@%%@NL@% GetInput = Value%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%' ====================== ISLEAPYEAR =======================%@AE@%%@NL@% %@AB@%' Determines if a year is a leap year or not%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION IsLeapYear (N) STATIC%@NL@% %@NL@% %@AB@% ' If the year is evenly divisible by 4 and not divisible%@AE@%%@NL@% %@AB@% ' by 100, or if the year is evenly divisible by 400,%@AE@%%@NL@% %@AB@% ' then it's a leap year:%@AE@%%@NL@% IsLeapYear = (N MOD 4 = 0 AND N MOD 100 <> 0) OR (N MOD 400 = 0)%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%' ===================== PRINTCALENDAR =====================%@AE@%%@NL@% %@AB@%' Prints a formatted calendar given the year and month%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB PrintCalendar (Year, Month) STATIC%@NL@% SHARED MonthData() AS MonthType%@NL@% %@NL@% %@AB@% ' Compute starting day (Su M Tu ...)%@AE@%%@NL@% %@AB@% ' and total days for the month:%@AE@%%@NL@% ComputeMonth Year, Month, StartDay, TotalDays%@NL@% CLS%@NL@% Header$ = RTRIM$(MonthData(Month).MName) + "," + STR$(Year)%@NL@% %@NL@% %@AB@% ' Calculate location for centering month and year:%@AE@%%@NL@% LeftMargin = (35 - LEN(Header$)) \ 2%@NL@% %@AB@%' Print header:%@AE@%%@NL@% PRINT TAB(LeftMargin); Header$%@NL@% PRINT%@NL@% PRINT "Su M Tu W Th F Sa"%@NL@% PRINT%@NL@% %@NL@% %@AB@% ' Recalculate and print tab%@AE@%%@NL@% %@AB@% ' to the first day of the month (Su M Tu ...):%@AE@%%@NL@% LeftMargin = 5 * StartDay + 1%@NL@% PRINT TAB(LeftMargin);%@NL@% %@NL@% %@AB@% ' Print out the days of the month:%@AE@%%@NL@% FOR I = 1 TO TotalDays%@NL@% PRINT USING "##_ "; I;%@NL@% %@NL@% %@AB@% ' Advance to the next line%@AE@%%@NL@% %@AB@% ' when the cursor is past column 32:%@AE@%%@NL@% IF POS(0) > 32 THEN PRINT%@NL@% NEXT%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%CHECK.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\CHECK.BAS%@AE@%%@NL@% %@NL@% DIM Amount(1 TO 100) AS CURRENCY, Balance AS CURRENCY%@NL@% CONST FALSE = 0, TRUE = NOT FALSE%@NL@% CLS%@NL@% %@AB@%' Get account's starting balance:%@AE@%%@NL@% INPUT "Type starting balance, then press <ENTER>: ", Balance%@NL@% %@AB@%' Get transactions. Continue accepting input%@AE@%%@NL@% %@AB@%' until the input is zero for a transaction,%@AE@%%@NL@% %@AB@%' or until 100 transactions have been entered:%@AE@%%@NL@% FOR TransacNum% = 1 TO 100%@NL@% PRINT TransacNum%;%@NL@% PRINT ") Enter transaction amount (0 to end): ";%@NL@% INPUT "", Amount(TransacNum%)%@NL@% IF Amount(TransacNum%) = 0 THEN%@NL@% TransacNum% = TransacNum% - 1%@NL@% EXIT FOR%@NL@% END IF%@NL@% NEXT%@NL@% %@NL@% %@AB@%' Sort transactions in ascending order,%@AE@%%@NL@% %@AB@%' using a "bubble sort":%@AE@%%@NL@% Limit% = TransacNum%%@NL@% DO%@NL@% Swaps% = FALSE%@NL@% FOR I% = 1 TO (Limit% - 1)%@NL@% %@AB@% ' If two adjacent elements are out of order,%@AE@%%@NL@% %@AB@% ' switch those elements:%@AE@%%@NL@% IF Amount(I%) < Amount(I% + 1) THEN%@NL@% SWAP Amount(I%), Amount(I% + 1)%@NL@% Swaps% = I%%@NL@% END IF%@NL@% NEXT I%%@NL@% %@AB@% ' Sort on next pass only to where last switch was made:%@AE@%%@NL@% Limit% = Swaps%%@NL@% %@NL@% %@AB@%' Sort until no elements are exchanged:%@AE@%%@NL@% LOOP WHILE Swaps%%@NL@% %@AB@%' Print the sorted transaction array. If a transaction%@AE@%%@NL@% %@AB@%' is greater than zero, print it as a "CREDIT"; if a%@AE@%%@NL@% %@AB@%' transaction is less than zero, print it as a "DEBIT":%@AE@%%@NL@% FOR I% = 1 TO TransacNum%%@NL@% IF Amount(I%) > 0 THEN%@NL@% PRINT USING "CREDIT: $$#####.##"; Amount(I%)%@NL@% ELSEIF Amount(I%) < 0 THEN%@NL@% PRINT USING "DEBIT: $$#####.##"; Amount(I%)%@NL@% END IF%@NL@% %@AB@% ' Update balance:%@AE@%%@NL@% Balance = Balance + Amount(I%)%@NL@% NEXT I%%@NL@% %@AB@%' Print the final balance:%@AE@%%@NL@% PRINT%@NL@% PRINT "--------------------------"%@NL@% PRINT USING "Final Balance: $$######.##"; Balance%@NL@% END%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%CHRTASM.ASM%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\CHRTASM.ASM%@AE@%%@NL@% %@NL@% .MODEL medium%@NL@% %@AB@%;********************************************************%@AE@%%@NL@% %@AB@%;CHRTASM.ASM - assembly routines for the BASIC chart toolbox%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; Copyright (C) 1989 Microsoft Corporation, All Rights Reserved%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; DefaultFont - provides the segment:offset address for%@AE@%%@NL@% %@AB@%; the default font%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%;********************************************************%@AE@%%@NL@% %@NL@% .FARDATA%@NL@% _IBM8_def label byte%@NL@% %@NL@% db 000h,000h,07Eh,00Ch,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,008h,000h,030h,000h%@NL@% db 060h,000h,007h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,090h,001h,000h,008h,000h%@NL@% db 008h,000h,000h,008h,000h,008h,000h,000h%@NL@% db 0FFh,02Eh,020h,0FFh,000h,000h,000h,000h%@NL@% db 000h,07Ah,004h,000h,000h,000h,000h,000h%@NL@% db 000h,07Eh,004h,000h,000h,000h,008h,000h%@NL@% db 07Eh,004h,008h,000h,086h,004h,008h,000h%@NL@% db 08Eh,004h,008h,000h,096h,004h,008h,000h%@NL@% db 09Eh,004h,008h,000h,0A6h,004h,008h,000h%@NL@% db 0AEh,004h,008h,000h,0B6h,004h,008h,000h%@NL@% db 0BEh,004h,008h,000h,0C6h,004h,008h,000h%@NL@% db 0CEh,004h,008h,000h,0D6h,004h,008h,000h%@NL@% db 0DEh,004h,008h,000h,0E6h,004h,008h,000h%@NL@% db 0EEh,004h,008h,000h,0F6h,004h,008h,000h%@NL@% db 0FEh,004h,008h,000h,006h,005h,008h,000h%@NL@% db 00Eh,005h,008h,000h,016h,005h,008h,000h%@NL@% db 01Eh,005h,008h,000h,026h,005h,008h,000h%@NL@% db 02Eh,005h,008h,000h,036h,005h,008h,000h%@NL@% db 03Eh,005h,008h,000h,046h,005h,008h,000h%@NL@% db 04Eh,005h,008h,000h,056h,005h,008h,000h%@NL@% db 05Eh,005h,008h,000h,066h,005h,008h,000h%@NL@% db 06Eh,005h,008h,000h,076h,005h,008h,000h%@NL@% db 07Eh,005h,008h,000h,086h,005h,008h,000h%@NL@% db 08Eh,005h,008h,000h,096h,005h,008h,000h%@NL@% db 09Eh,005h,008h,000h,0A6h,005h,008h,000h%@NL@% db 0AEh,005h,008h,000h,0B6h,005h,008h,000h%@NL@% db 0BEh,005h,008h,000h,0C6h,005h,008h,000h%@NL@% db 0CEh,005h,008h,000h,0D6h,005h,008h,000h%@NL@% db 0DEh,005h,008h,000h,0E6h,005h,008h,000h%@NL@% db 0EEh,005h,008h,000h,0F6h,005h,008h,000h%@NL@% db 0FEh,005h,008h,000h,006h,006h,008h,000h%@NL@% db 00Eh,006h,008h,000h,016h,006h,008h,000h%@NL@% db 01Eh,006h,008h,000h,026h,006h,008h,000h%@NL@% db 02Eh,006h,008h,000h,036h,006h,008h,000h%@NL@% db 03Eh,006h,008h,000h,046h,006h,008h,000h%@NL@% db 04Eh,006h,008h,000h,056h,006h,008h,000h%@NL@% db 05Eh,006h,008h,000h,066h,006h,008h,000h%@NL@% db 06Eh,006h,008h,000h,076h,006h,008h,000h%@NL@% db 07Eh,006h,008h,000h,086h,006h,008h,000h%@NL@% db 08Eh,006h,008h,000h,096h,006h,008h,000h%@NL@% db 09Eh,006h,008h,000h,0A6h,006h,008h,000h%@NL@% db 0AEh,006h,008h,000h,0B6h,006h,008h,000h%@NL@% db 0BEh,006h,008h,000h,0C6h,006h,008h,000h%@NL@% db 0CEh,006h,008h,000h,0D6h,006h,008h,000h%@NL@% db 0DEh,006h,008h,000h,0E6h,006h,008h,000h%@NL@% db 0EEh,006h,008h,000h,0F6h,006h,008h,000h%@NL@% db 0FEh,006h,008h,000h,006h,007h,008h,000h%@NL@% db 00Eh,007h,008h,000h,016h,007h,008h,000h%@NL@% db 01Eh,007h,008h,000h,026h,007h,008h,000h%@NL@% db 02Eh,007h,008h,000h,036h,007h,008h,000h%@NL@% db 03Eh,007h,008h,000h,046h,007h,008h,000h%@NL@% db 04Eh,007h,008h,000h,056h,007h,008h,000h%@NL@% db 05Eh,007h,008h,000h,066h,007h,008h,000h%@NL@% db 06Eh,007h,008h,000h,076h,007h,008h,000h%@NL@% db 07Eh,007h,008h,000h,086h,007h,008h,000h%@NL@% db 08Eh,007h,008h,000h,096h,007h,008h,000h%@NL@% db 09Eh,007h,008h,000h,0A6h,007h,008h,000h%@NL@% db 0AEh,007h,008h,000h,0B6h,007h,008h,000h%@NL@% db 0BEh,007h,008h,000h,0C6h,007h,008h,000h%@NL@% db 0CEh,007h,008h,000h,0D6h,007h,008h,000h%@NL@% db 0DEh,007h,008h,000h,0E6h,007h,008h,000h%@NL@% db 0EEh,007h,008h,000h,0F6h,007h,008h,000h%@NL@% db 0FEh,007h,008h,000h,006h,008h,008h,000h%@NL@% db 00Eh,008h,008h,000h,016h,008h,008h,000h%@NL@% db 01Eh,008h,008h,000h,026h,008h,008h,000h%@NL@% db 02Eh,008h,008h,000h,036h,008h,008h,000h%@NL@% db 03Eh,008h,008h,000h,046h,008h,008h,000h%@NL@% db 04Eh,008h,008h,000h,056h,008h,008h,000h%@NL@% db 05Eh,008h,008h,000h,066h,008h,008h,000h%@NL@% db 06Eh,008h,008h,000h,076h,008h,008h,000h%@NL@% db 07Eh,008h,008h,000h,086h,008h,008h,000h%@NL@% db 08Eh,008h,008h,000h,096h,008h,008h,000h%@NL@% db 09Eh,008h,008h,000h,0A6h,008h,008h,000h%@NL@% db 0AEh,008h,008h,000h,0B6h,008h,008h,000h%@NL@% db 0BEh,008h,008h,000h,0C6h,008h,008h,000h%@NL@% db 0CEh,008h,008h,000h,0D6h,008h,008h,000h%@NL@% db 0DEh,008h,008h,000h,0E6h,008h,008h,000h%@NL@% db 0EEh,008h,008h,000h,0F6h,008h,008h,000h%@NL@% db 0FEh,008h,008h,000h,006h,009h,008h,000h%@NL@% db 00Eh,009h,008h,000h,016h,009h,008h,000h%@NL@% db 01Eh,009h,008h,000h,026h,009h,008h,000h%@NL@% db 02Eh,009h,008h,000h,036h,009h,008h,000h%@NL@% db 03Eh,009h,008h,000h,046h,009h,008h,000h%@NL@% db 04Eh,009h,008h,000h,056h,009h,008h,000h%@NL@% db 05Eh,009h,008h,000h,066h,009h,008h,000h%@NL@% db 06Eh,009h,008h,000h,076h,009h,008h,000h%@NL@% db 07Eh,009h,008h,000h,086h,009h,008h,000h%@NL@% db 08Eh,009h,008h,000h,096h,009h,008h,000h%@NL@% db 09Eh,009h,008h,000h,0A6h,009h,008h,000h%@NL@% db 0AEh,009h,008h,000h,0B6h,009h,008h,000h%@NL@% db 0BEh,009h,008h,000h,0C6h,009h,008h,000h%@NL@% db 0CEh,009h,008h,000h,0D6h,009h,008h,000h%@NL@% db 0DEh,009h,008h,000h,0E6h,009h,008h,000h%@NL@% db 0EEh,009h,008h,000h,0F6h,009h,008h,000h%@NL@% db 0FEh,009h,008h,000h,006h,00Ah,008h,000h%@NL@% db 00Eh,00Ah,008h,000h,016h,00Ah,008h,000h%@NL@% db 01Eh,00Ah,008h,000h,026h,00Ah,008h,000h%@NL@% db 02Eh,00Ah,008h,000h,036h,00Ah,008h,000h%@NL@% db 03Eh,00Ah,008h,000h,046h,00Ah,008h,000h%@NL@% db 04Eh,00Ah,008h,000h,056h,00Ah,008h,000h%@NL@% db 05Eh,00Ah,008h,000h,066h,00Ah,008h,000h%@NL@% db 06Eh,00Ah,008h,000h,076h,00Ah,008h,000h%@NL@% db 07Eh,00Ah,008h,000h,086h,00Ah,008h,000h%@NL@% db 08Eh,00Ah,008h,000h,096h,00Ah,008h,000h%@NL@% db 09Eh,00Ah,008h,000h,0A6h,00Ah,008h,000h%@NL@% db 0AEh,00Ah,008h,000h,0B6h,00Ah,008h,000h%@NL@% db 0BEh,00Ah,008h,000h,0C6h,00Ah,008h,000h%@NL@% db 0CEh,00Ah,008h,000h,0D6h,00Ah,008h,000h%@NL@% db 0DEh,00Ah,008h,000h,0E6h,00Ah,008h,000h%@NL@% db 0EEh,00Ah,008h,000h,0F6h,00Ah,008h,000h%@NL@% db 0FEh,00Ah,008h,000h,006h,00Bh,008h,000h%@NL@% db 00Eh,00Bh,008h,000h,016h,00Bh,008h,000h%@NL@% db 01Eh,00Bh,008h,000h,026h,00Bh,008h,000h%@NL@% db 02Eh,00Bh,008h,000h,036h,00Bh,008h,000h%@NL@% db 03Eh,00Bh,008h,000h,046h,00Bh,008h,000h%@NL@% db 04Eh,00Bh,008h,000h,056h,00Bh,008h,000h%@NL@% db 05Eh,00Bh,008h,000h,066h,00Bh,008h,000h%@NL@% db 06Eh,00Bh,008h,000h,076h,00Bh,008h,000h%@NL@% db 07Eh,00Bh,008h,000h,086h,00Bh,008h,000h%@NL@% db 08Eh,00Bh,008h,000h,096h,00Bh,008h,000h%@NL@% db 09Eh,00Bh,008h,000h,0A6h,00Bh,008h,000h%@NL@% db 0AEh,00Bh,008h,000h,0B6h,00Bh,008h,000h%@NL@% db 0BEh,00Bh,008h,000h,0C6h,00Bh,008h,000h%@NL@% db 0CEh,00Bh,008h,000h,0D6h,00Bh,008h,000h%@NL@% db 0DEh,00Bh,008h,000h,0E6h,00Bh,008h,000h%@NL@% db 0EEh,00Bh,008h,000h,0F6h,00Bh,008h,000h%@NL@% db 0FEh,00Bh,008h,000h,006h,00Ch,008h,000h%@NL@% db 00Eh,00Ch,008h,000h,016h,00Ch,008h,000h%@NL@% db 01Eh,00Ch,008h,000h,026h,00Ch,008h,000h%@NL@% db 02Eh,00Ch,008h,000h,036h,00Ch,008h,000h%@NL@% db 03Eh,00Ch,008h,000h,046h,00Ch,008h,000h%@NL@% db 04Eh,00Ch,008h,000h,056h,00Ch,008h,000h%@NL@% db 05Eh,00Ch,008h,000h,066h,00Ch,008h,000h%@NL@% db 06Eh,00Ch,008h,000h,076h,00Ch,008h,000h%@NL@% db 07Eh,005h,049h,042h,04Dh,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,07Eh,081h%@NL@% db 0A5h,081h,0BDh,099h,081h,07Eh,07Eh,0FFh%@NL@% db 0DBh,0FFh,0C3h,0E7h,0FFh,07Eh,06Ch,0FEh%@NL@% db 0FEh,0FEh,07Ch,038h,010h,000h,010h,038h%@NL@% db 07Ch,0FEh,07Ch,038h,010h,000h,038h,07Ch%@NL@% db 038h,0FEh,0FEh,07Ch,038h,07Ch,010h,010h%@NL@% db 038h,07Ch,0FEh,07Ch,038h,07Ch,010h,010h%@NL@% db 038h,07Ch,0FEh,07Ch,038h,07Ch,0FFh,0FFh%@NL@% db 0E7h,0C3h,0C3h,0E7h,0FFh,0FFh,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,07Fh,063h%@NL@% db 07Fh,063h,063h,067h,0E6h,0C0h,099h,05Ah%@NL@% db 03Ch,0E7h,0E7h,03Ch,05Ah,099h,080h,0E0h%@NL@% db 0F8h,0FEh,0F8h,0E0h,080h,000h,002h,00Eh%@NL@% db 03Eh,0FEh,03Eh,00Eh,002h,000h,018h,03Ch%@NL@% db 07Eh,018h,018h,07Eh,03Ch,018h,066h,066h%@NL@% db 066h,066h,066h,000h,066h,000h,07Fh,0DBh%@NL@% db 0DBh,07Bh,01Bh,01Bh,01Bh,000h,03Eh,063h%@NL@% db 038h,06Ch,06Ch,038h,0CCh,078h,000h,000h%@NL@% db 000h,000h,07Eh,07Eh,07Eh,000h,018h,03Ch%@NL@% db 07Eh,018h,07Eh,03Ch,018h,0FFh,018h,03Ch%@NL@% db 07Eh,018h,018h,018h,018h,000h,018h,018h%@NL@% db 018h,018h,07Eh,03Ch,018h,000h,000h,018h%@NL@% db 00Ch,0FEh,00Ch,018h,000h,000h,000h,030h%@NL@% db 060h,0FEh,060h,030h,000h,000h,000h,030h%@NL@% db 060h,0FEh,060h,030h,000h,000h,000h,030h%@NL@% db 060h,0FEh,060h,030h,000h,000h,000h,030h%@NL@% db 060h,0FEh,060h,030h,000h,000h,000h,030h%@NL@% db 060h,0FEh,060h,030h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h,030h,078h%@NL@% db 078h,030h,030h,000h,030h,000h,06Ch,06Ch%@NL@% db 06Ch,000h,000h,000h,000h,000h,06Ch,06Ch%@NL@% db 0FEh,06Ch,0FEh,06Ch,06Ch,000h,030h,07Ch%@NL@% db 0C0h,078h,00Ch,0F8h,030h,000h,000h,0C6h%@NL@% db 0CCh,018h,030h,066h,0C6h,000h,038h,06Ch%@NL@% db 038h,076h,0DCh,0CCh,076h,000h,060h,060h%@NL@% db 0C0h,000h,000h,000h,000h,000h,018h,030h%@NL@% db 060h,060h,060h,030h,018h,000h,060h,030h%@NL@% db 018h,018h,018h,030h,060h,000h,000h,066h%@NL@% db 03Ch,0FFh,03Ch,066h,000h,000h,000h,030h%@NL@% db 030h,0FCh,030h,030h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,030h,030h,060h,000h,000h%@NL@% db 000h,0FCh,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,030h,030h,000h,006h,00Ch%@NL@% db 018h,030h,060h,0C0h,080h,000h,07Ch,0C6h%@NL@% db 0CEh,0DEh,0F6h,0E6h,07Ch,000h,030h,070h%@NL@% db 030h,030h,030h,030h,0FCh,000h,078h,0CCh%@NL@% db 00Ch,038h,060h,0CCh,0FCh,000h,078h,0CCh%@NL@% db 00Ch,038h,00Ch,0CCh,078h,000h,01Ch,03Ch%@NL@% db 06Ch,0CCh,0FEh,00Ch,01Eh,000h,0FCh,0C0h%@NL@% db 0F8h,00Ch,00Ch,0CCh,078h,000h,038h,060h%@NL@% db 0C0h,0F8h,0CCh,0CCh,078h,000h,0FCh,0CCh%@NL@% db 00Ch,018h,030h,030h,030h,000h,078h,0CCh%@NL@% db 0CCh,078h,0CCh,0CCh,078h,000h,078h,0CCh%@NL@% db 0CCh,07Ch,00Ch,018h,070h,000h,000h,030h%@NL@% db 030h,000h,000h,030h,030h,000h,000h,030h%@NL@% db 030h,000h,000h,030h,030h,060h,018h,030h%@NL@% db 060h,0C0h,060h,030h,018h,000h,000h,000h%@NL@% db 0FCh,000h,000h,0FCh,000h,000h,060h,030h%@NL@% db 018h,00Ch,018h,030h,060h,000h,078h,0CCh%@NL@% db 00Ch,018h,030h,000h,030h,000h,07Ch,0C6h%@NL@% db 0DEh,0DEh,0DEh,0C0h,078h,000h,030h,078h%@NL@% db 0CCh,0CCh,0FCh,0CCh,0CCh,000h,0FCh,066h%@NL@% db 066h,07Ch,066h,066h,0FCh,000h,03Ch,066h%@NL@% db 0C0h,0C0h,0C0h,066h,03Ch,000h,0F8h,06Ch%@NL@% db 066h,066h,066h,06Ch,0F8h,000h,0FEh,062h%@NL@% db 068h,078h,068h,062h,0FEh,000h,0FEh,062h%@NL@% db 068h,078h,068h,060h,0F0h,000h,03Ch,066h%@NL@% db 0C0h,0C0h,0CEh,066h,03Eh,000h,0CCh,0CCh%@NL@% db 0CCh,0FCh,0CCh,0CCh,0CCh,000h,078h,030h%@NL@% db 030h,030h,030h,030h,078h,000h,01Eh,00Ch%@NL@% db 00Ch,00Ch,0CCh,0CCh,078h,000h,0E6h,066h%@NL@% db 06Ch,078h,06Ch,066h,0E6h,000h,0F0h,060h%@NL@% db 060h,060h,062h,066h,0FEh,000h,0C6h,0EEh%@NL@% db 0FEh,0FEh,0D6h,0C6h,0C6h,000h,0C6h,0E6h%@NL@% db 0F6h,0DEh,0CEh,0C6h,0C6h,000h,038h,06Ch%@NL@% db 0C6h,0C6h,0C6h,06Ch,038h,000h,0FCh,066h%@NL@% db 066h,07Ch,060h,060h,0F0h,000h,078h,0CCh%@NL@% db 0CCh,0CCh,0DCh,078h,01Ch,000h,0FCh,066h%@NL@% db 066h,07Ch,06Ch,066h,0E6h,000h,078h,0CCh%@NL@% db 0E0h,070h,01Ch,0CCh,078h,000h,0FCh,0B4h%@NL@% db 030h,030h,030h,030h,078h,000h,0CCh,0CCh%@NL@% db 0CCh,0CCh,0CCh,0CCh,0FCh,000h,0CCh,0CCh%@NL@% db 0CCh,0CCh,0CCh,078h,030h,000h,0C6h,0C6h%@NL@% db 0C6h,0D6h,0FEh,0EEh,0C6h,000h,0C6h,0C6h%@NL@% db 06Ch,038h,038h,06Ch,0C6h,000h,0CCh,0CCh%@NL@% db 0CCh,078h,030h,030h,078h,000h,0FEh,0C6h%@NL@% db 08Ch,018h,032h,066h,0FEh,000h,078h,060h%@NL@% db 060h,060h,060h,060h,078h,000h,0C0h,060h%@NL@% db 030h,018h,00Ch,006h,002h,000h,078h,018h%@NL@% db 018h,018h,018h,018h,078h,000h,010h,038h%@NL@% db 06Ch,0C6h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,0FFh,030h,030h%@NL@% db 018h,000h,000h,000h,000h,000h,000h,000h%@NL@% db 078h,00Ch,07Ch,0CCh,076h,000h,0E0h,060h%@NL@% db 060h,07Ch,066h,066h,0DCh,000h,000h,000h%@NL@% db 078h,0CCh,0C0h,0CCh,078h,000h,01Ch,00Ch%@NL@% db 00Ch,07Ch,0CCh,0CCh,076h,000h,000h,000h%@NL@% db 078h,0CCh,0FCh,0C0h,078h,000h,038h,06Ch%@NL@% db 060h,0F0h,060h,060h,0F0h,000h,000h,000h%@NL@% db 076h,0CCh,0CCh,07Ch,00Ch,0F8h,0E0h,060h%@NL@% db 06Ch,076h,066h,066h,0E6h,000h,030h,000h%@NL@% db 070h,030h,030h,030h,078h,000h,00Ch,000h%@NL@% db 00Ch,00Ch,00Ch,0CCh,0CCh,078h,0E0h,060h%@NL@% db 066h,06Ch,078h,06Ch,0E6h,000h,070h,030h%@NL@% db 030h,030h,030h,030h,078h,000h,000h,000h%@NL@% db 0CCh,0FEh,0FEh,0D6h,0C6h,000h,000h,000h%@NL@% db 0F8h,0CCh,0CCh,0CCh,0CCh,000h,000h,000h%@NL@% db 078h,0CCh,0CCh,0CCh,078h,000h,000h,000h%@NL@% db 0DCh,066h,066h,07Ch,060h,0F0h,000h,000h%@NL@% db 076h,0CCh,0CCh,07Ch,00Ch,01Eh,000h,000h%@NL@% db 0DCh,076h,066h,060h,0F0h,000h,000h,000h%@NL@% db 07Ch,0C0h,078h,00Ch,0F8h,000h,010h,030h%@NL@% db 07Ch,030h,030h,034h,018h,000h,000h,000h%@NL@% db 0CCh,0CCh,0CCh,0CCh,076h,000h,000h,000h%@NL@% db 0CCh,0CCh,0CCh,078h,030h,000h,000h,000h%@NL@% db 0C6h,0D6h,0FEh,0FEh,06Ch,000h,000h,000h%@NL@% db 0C6h,06Ch,038h,06Ch,0C6h,000h,000h,000h%@NL@% db 0CCh,0CCh,0CCh,07Ch,00Ch,0F8h,000h,000h%@NL@% db 0FCh,098h,030h,064h,0FCh,000h,01Ch,030h%@NL@% db 030h,0E0h,030h,030h,01Ch,000h,018h,018h%@NL@% db 018h,000h,018h,018h,018h,000h,0E0h,030h%@NL@% db 030h,01Ch,030h,030h,0E0h,000h,076h,0DCh%@NL@% db 000h,000h,000h,000h,000h,000h,000h,010h%@NL@% db 038h,06Ch,0C6h,0C6h,0FEh,000h,078h,0CCh%@NL@% db 0C0h,0CCh,078h,018h,00Ch,078h,000h,0CCh%@NL@% db 000h,0CCh,0CCh,0CCh,07Eh,000h,01Ch,000h%@NL@% db 078h,0CCh,0FCh,0C0h,078h,000h,07Eh,0C3h%@NL@% db 03Ch,006h,03Eh,066h,03Fh,000h,0CCh,000h%@NL@% db 078h,00Ch,07Ch,0CCh,07Eh,000h,0E0h,000h%@NL@% db 078h,00Ch,07Ch,0CCh,07Eh,000h,030h,030h%@NL@% db 078h,00Ch,07Ch,0CCh,07Eh,000h,000h,000h%@NL@% db 078h,0C0h,0C0h,078h,00Ch,038h,07Eh,0C3h%@NL@% db 03Ch,066h,07Eh,060h,03Ch,000h,0CCh,000h%@NL@% db 078h,0CCh,0FCh,0C0h,078h,000h,0E0h,000h%@NL@% db 078h,0CCh,0FCh,0C0h,078h,000h,0CCh,000h%@NL@% db 070h,030h,030h,030h,078h,000h,07Ch,0C6h%@NL@% db 038h,018h,018h,018h,03Ch,000h,0E0h,000h%@NL@% db 070h,030h,030h,030h,078h,000h,0C6h,038h%@NL@% db 06Ch,0C6h,0FEh,0C6h,0C6h,000h,030h,030h%@NL@% db 000h,078h,0CCh,0FCh,0CCh,000h,01Ch,000h%@NL@% db 0FCh,060h,078h,060h,0FCh,000h,000h,000h%@NL@% db 07Fh,00Ch,07Fh,0CCh,07Fh,000h,03Eh,06Ch%@NL@% db 0CCh,0FEh,0CCh,0CCh,0CEh,000h,078h,0CCh%@NL@% db 000h,078h,0CCh,0CCh,078h,000h,000h,0CCh%@NL@% db 000h,078h,0CCh,0CCh,078h,000h,000h,0E0h%@NL@% db 000h,078h,0CCh,0CCh,078h,000h,078h,0CCh%@NL@% db 000h,0CCh,0CCh,0CCh,07Eh,000h,000h,0E0h%@NL@% db 000h,0CCh,0CCh,0CCh,07Eh,000h,000h,0CCh%@NL@% db 000h,0CCh,0CCh,07Ch,00Ch,0F8h,0C3h,018h%@NL@% db 03Ch,066h,066h,03Ch,018h,000h,0CCh,000h%@NL@% db 0CCh,0CCh,0CCh,0CCh,078h,000h,018h,018h%@NL@% db 07Eh,0C0h,0C0h,07Eh,018h,018h,038h,06Ch%@NL@% db 064h,0F0h,060h,0E6h,0FCh,000h,0CCh,0CCh%@NL@% db 078h,0FCh,030h,0FCh,030h,030h,0F8h,0CCh%@NL@% db 0CCh,0FAh,0C6h,0CFh,0C6h,0C7h,00Eh,01Bh%@NL@% db 018h,03Ch,018h,018h,0D8h,070h,01Ch,000h%@NL@% db 078h,00Ch,07Ch,0CCh,07Eh,000h,038h,000h%@NL@% db 070h,030h,030h,030h,078h,000h,000h,01Ch%@NL@% db 000h,078h,0CCh,0CCh,078h,000h,000h,01Ch%@NL@% db 000h,0CCh,0CCh,0CCh,07Eh,000h,000h,0F8h%@NL@% db 000h,0F8h,0CCh,0CCh,0CCh,000h,0FCh,000h%@NL@% db 0CCh,0ECh,0FCh,0DCh,0CCh,000h,03Ch,06Ch%@NL@% db 06Ch,03Eh,000h,07Eh,000h,000h,038h,06Ch%@NL@% db 06Ch,038h,000h,07Ch,000h,000h,030h,000h%@NL@% db 030h,060h,0C0h,0CCh,078h,000h,000h,000h%@NL@% db 000h,0FCh,0C0h,0C0h,000h,000h,000h,000h%@NL@% db 000h,0FCh,00Ch,00Ch,000h,000h,0C3h,0C6h%@NL@% db 0CCh,0DEh,033h,066h,0CCh,00Fh,0C3h,0C6h%@NL@% db 0CCh,0DBh,037h,06Fh,0CFh,003h,018h,018h%@NL@% db 000h,018h,018h,018h,018h,000h,000h,033h%@NL@% db 066h,0CCh,066h,033h,000h,000h,000h,0CCh%@NL@% db 066h,033h,066h,0CCh,000h,000h,022h,088h%@NL@% db 022h,088h,022h,088h,022h,088h,055h,0AAh%@NL@% db 055h,0AAh,055h,0AAh,055h,0AAh,0DBh,077h%@NL@% db 0DBh,0EEh,0DBh,077h,0DBh,0EEh,018h,018h%@NL@% db 018h,018h,018h,018h,018h,018h,018h,018h%@NL@% db 018h,018h,0F8h,018h,018h,018h,018h,018h%@NL@% db 0F8h,018h,0F8h,018h,018h,018h,036h,036h%@NL@% db 036h,036h,0F6h,036h,036h,036h,000h,000h%@NL@% db 000h,000h,0FEh,036h,036h,036h,000h,000h%@NL@% db 0F8h,018h,0F8h,018h,018h,018h,036h,036h%@NL@% db 0F6h,006h,0F6h,036h,036h,036h,036h,036h%@NL@% db 036h,036h,036h,036h,036h,036h,000h,000h%@NL@% db 0FEh,006h,0F6h,036h,036h,036h,036h,036h%@NL@% db 0F6h,006h,0FEh,000h,000h,000h,036h,036h%@NL@% db 036h,036h,0FEh,000h,000h,000h,018h,018h%@NL@% db 0F8h,018h,0F8h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,0F8h,018h,018h,018h,018h,018h%@NL@% db 018h,018h,01Fh,000h,000h,000h,018h,018h%@NL@% db 018h,018h,0FFh,000h,000h,000h,000h,000h%@NL@% db 000h,000h,0FFh,018h,018h,018h,018h,018h%@NL@% db 018h,018h,01Fh,018h,018h,018h,000h,000h%@NL@% db 000h,000h,0FFh,000h,000h,000h,018h,018h%@NL@% db 018h,018h,0FFh,018h,018h,018h,018h,018h%@NL@% db 01Fh,018h,01Fh,018h,018h,018h,036h,036h%@NL@% db 036h,036h,037h,036h,036h,036h,036h,036h%@NL@% db 037h,030h,03Fh,000h,000h,000h,000h,000h%@NL@% db 03Fh,030h,037h,036h,036h,036h,036h,036h%@NL@% db 0F7h,000h,0FFh,000h,000h,000h,000h,000h%@NL@% db 0FFh,000h,0F7h,036h,036h,036h,036h,036h%@NL@% db 037h,030h,037h,036h,036h,036h,000h,000h%@NL@% db 0FFh,000h,0FFh,000h,000h,000h,036h,036h%@NL@% db 0F7h,000h,0F7h,036h,036h,036h,018h,018h%@NL@% db 0FFh,000h,0FFh,000h,000h,000h,036h,036h%@NL@% db 036h,036h,0FFh,000h,000h,000h,000h,000h%@NL@% db 0FFh,000h,0FFh,018h,018h,018h,000h,000h%@NL@% db 000h,000h,0FFh,036h,036h,036h,036h,036h%@NL@% db 036h,036h,03Fh,000h,000h,000h,018h,018h%@NL@% db 01Fh,018h,01Fh,000h,000h,000h,000h,000h%@NL@% db 01Fh,018h,01Fh,018h,018h,018h,000h,000h%@NL@% db 000h,000h,03Fh,036h,036h,036h,036h,036h%@NL@% db 036h,036h,0FFh,036h,036h,036h,018h,018h%@NL@% db 0FFh,018h,0FFh,018h,018h,018h,018h,018h%@NL@% db 018h,018h,0F8h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,01Fh,018h,018h,018h,0FFh,0FFh%@NL@% db 0FFh,0FFh,0FFh,0FFh,0FFh,0FFh,000h,000h%@NL@% db 000h,000h,0FFh,0FFh,0FFh,0FFh,0F0h,0F0h%@NL@% db 0F0h,0F0h,0F0h,0F0h,0F0h,0F0h,00Fh,00Fh%@NL@% db 00Fh,00Fh,00Fh,00Fh,00Fh,00Fh,0FFh,0FFh%@NL@% db 0FFh,0FFh,000h,000h,000h,000h,000h,000h%@NL@% db 076h,0DCh,0C8h,0DCh,076h,000h,000h,078h%@NL@% db 0CCh,0F8h,0CCh,0F8h,0C0h,0C0h,000h,0FCh%@NL@% db 0CCh,0C0h,0C0h,0C0h,0C0h,000h,000h,0FEh%@NL@% db 06Ch,06Ch,06Ch,06Ch,06Ch,000h,0FCh,0CCh%@NL@% db 060h,030h,060h,0CCh,0FCh,000h,000h,000h%@NL@% db 07Eh,0D8h,0D8h,0D8h,070h,000h,000h,066h%@NL@% db 066h,066h,066h,07Ch,060h,0C0h,000h,076h%@NL@% db 0DCh,018h,018h,018h,018h,000h,0FCh,030h%@NL@% db 078h,0CCh,0CCh,078h,030h,0FCh,038h,06Ch%@NL@% db 0C6h,0FEh,0C6h,06Ch,038h,000h,038h,06Ch%@NL@% db 0C6h,0C6h,06Ch,06Ch,0EEh,000h,01Ch,030h%@NL@% db 018h,07Ch,0CCh,0CCh,078h,000h,000h,000h%@NL@% db 07Eh,0DBh,0DBh,07Eh,000h,000h,006h,00Ch%@NL@% db 07Eh,0DBh,0DBh,07Eh,060h,0C0h,038h,060h%@NL@% db 0C0h,0F8h,0C0h,060h,038h,000h,078h,0CCh%@NL@% db 0CCh,0CCh,0CCh,0CCh,0CCh,000h,000h,0FCh%@NL@% db 000h,0FCh,000h,0FCh,000h,000h,030h,030h%@NL@% db 0FCh,030h,030h,000h,0FCh,000h,060h,030h%@NL@% db 018h,030h,060h,000h,0FCh,000h,018h,030h%@NL@% db 060h,030h,018h,000h,0FCh,000h,00Eh,01Bh%@NL@% db 01Bh,018h,018h,018h,018h,018h,018h,018h%@NL@% db 018h,018h,018h,0D8h,0D8h,070h,030h,030h%@NL@% db 000h,0FCh,000h,030h,030h,000h,000h,076h%@NL@% db 0DCh,000h,076h,0DCh,000h,000h,038h,06Ch%@NL@% db 06Ch,038h,000h,000h,000h,000h,000h,000h%@NL@% db 000h,018h,018h,000h,000h,000h,000h,000h%@NL@% db 000h,000h,018h,000h,000h,000h,00Fh,00Ch%@NL@% db 00Ch,00Ch,0ECh,06Ch,03Ch,01Ch,078h,06Ch%@NL@% db 06Ch,06Ch,06Ch,000h,000h,000h,070h,018h%@NL@% db 030h,060h,078h,000h,000h,000h,000h,000h%@NL@% db 03Ch,03Ch,03Ch,03Ch,000h,000h,000h,000h%@NL@% db 000h,000h,000h,000h,000h,000h%@NL@% %@NL@% %@AB@%;=====End of Font%@AE@%%@NL@% %@NL@% .CODE%@NL@% %@NL@% %@AB@%;********************************************************%@AE@%%@NL@% %@AB@%;DefaultFont - Returns the Segment:Offset address of the%@AE@%%@NL@% %@AB@%; default font%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; DefaultFont Segment%, Offset%%@AE@%%@NL@% %@NL@% PUBLIC DefaultFont%@NL@% DefaultFont PROC%@NL@% push bp%@NL@% mov bp,sp%@NL@% %@NL@% les bx,[bp+10] %@AB@%;put address of first arg in es:si%@AE@%%@NL@% mov es:[bx],SEG _IBM8_def %@AB@%;move segment address to first arg of call%@AE@%%@NL@% %@NL@% les bx,[bp+6] %@AB@%;repeat above for offset address of font%@AE@%%@NL@% mov word ptr es:[bx],OFFSET _IBM8_def%@NL@% %@NL@% pop bp%@NL@% ret 8%@NL@% DefaultFont ENDP%@NL@% %@NL@% END%@NL@% %@NL@% %@NL@% %@2@%%@AH@%CHRTB.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\CHRTB.BAS%@AE@%%@NL@% %@NL@% %@AB@%'*** CHRTB.BAS - Chart Routines for the Presentation Graphics Toolbox in%@AE@%%@NL@% %@AB@%' Microsoft BASIC 7.0, Professional Development System%@AE@%%@NL@% %@AB@%' Copyright (C) 1987-1989, Microsoft Corporation%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' NOTE: This sample source code toolbox is intended to demonstrate some%@AE@%%@NL@% %@AB@%' of the extended capabilities of Microsoft BASIC 7.0 Professional Development%@AE@%%@NL@% %@AB@%' system that can help to leverage the professional developer's time more%@AE@%%@NL@% %@AB@%' effectively. While you are free to use, modify, or distribute the routines%@AE@%%@NL@% %@AB@%' in this module in any way you find useful, it should be noted that these are%@AE@%%@NL@% %@AB@%' examples only and should not be relied upon as a fully-tested "add-on"%@AE@%%@NL@% %@AB@%' library.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' PURPOSE: This file contains the BASIC source code for the Presentation%@AE@%%@NL@% %@AB@%' Graphics Toolbox Chart Routines.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' To create a library and QuickLib containing the charting routines found%@AE@%%@NL@% %@AB@%' in this file, follow these steps:%@AE@%%@NL@% %@AB@%' BC /X/FS chrtb.bas%@AE@%%@NL@% %@AB@%' LIB chrtb.lib + chrtb + chrtasm + qbx.lib;%@AE@%%@NL@% %@AB@%' LINK /Q chrtb.lib, chrtb.qlb,,qbxqlb.lib;%@AE@%%@NL@% %@AB@%' If you are going to use this CHRTB.QLB QuickLib in conjunction with%@AE@%%@NL@% %@AB@%' the font source code (FONTB.BAS) or the UI toobox source code%@AE@%%@NL@% %@AB@%' (GENERAL.BAS, WINDOW.BAS, MENU.BAS and MOUSE.BAS), you need to%@AE@%%@NL@% %@AB@%' include the assembly code routines referenced in these files. For the%@AE@%%@NL@% %@AB@%' font routines, create CHRTB.LIB as follows before you create the%@AE@%%@NL@% %@AB@%' QuickLib:%@AE@%%@NL@% %@AB@%' LIB chrtb.lib + chrtb + chrtasm + fontasm + qbx.lib;%@AE@%%@NL@% %@AB@%' For the UI toolbox routines, create the library as follows:%@AE@%%@NL@% %@AB@%' LIB chrtb.lib + chrtb + chrtasm + uiasm + qbx.lib;%@AE@%%@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% %@NL@% %@AB@%' Constants:%@AE@%%@NL@% %@NL@% CONST cTicSize = .02 ' Percent of axis length to use for tic length%@NL@% CONST cMaxChars = 255 ' Maximum ASCII value allowed for character%@NL@% CONST cBarWid = .8 ' Percent of category width to use for bar%@NL@% CONST cPiVal = 3.141592 ' A value for PI%@NL@% CONST cFalse = 0 ' Logical false%@NL@% CONST cTrue = NOT cFalse ' Logical true%@NL@% %@NL@% %@AB@%' CHRTB.BI contains all of the TYPE definitions and SUB declarations%@AE@%%@NL@% %@AB@%' that are accessible to the library user as well as CONST definitions for%@AE@%%@NL@% %@AB@%' some routine parameters and error messages:%@AE@%%@NL@% %@NL@% %@AB@%'$INCLUDE: 'CHRTB.BI'%@AE@%%@NL@% %@NL@% %@AB@%' FONTB.BI contains all of the TYPE definitions and SUB declarations%@AE@%%@NL@% %@AB@%' required for graphics text:%@AE@%%@NL@% %@NL@% %@AB@%'$INCLUDE: 'FONTB.BI'%@AE@%%@NL@% %@NL@% %@AB@%' Below are TYPE definitions local to this module:%@AE@%%@NL@% %@NL@% %@AB@%' TYPE for recording information on title spacing:%@AE@%%@NL@% TYPE TitleLayout%@NL@% Top AS INTEGER ' Space above first title%@NL@% TitleOne AS INTEGER ' Height of first title%@NL@% Middle AS INTEGER ' Space between first and second titles%@NL@% TitleTwo AS INTEGER ' Height of second title%@NL@% Bottom AS INTEGER ' Space below second title%@NL@% TotalSize AS INTEGER ' Sum of all the above%@NL@% END TYPE%@NL@% %@NL@% %@AB@%' TYPE for recording information on the legend layout:%@AE@%%@NL@% TYPE LegendLayout%@NL@% NumCol AS INTEGER ' Number of columns in legend%@NL@% NumRow AS INTEGER ' Number of rows in legend%@NL@% SymbolSize AS INTEGER ' Height of symbol%@NL@% LabelOffset AS INTEGER ' Space between start of symbol and label%@NL@% RowSpacing AS INTEGER ' Space between tops of rows%@NL@% ColSpacing AS INTEGER ' Spacing between beginnings of columns%@NL@% HorizBorder AS INTEGER ' Top and bottom border%@NL@% VertBorder AS INTEGER ' Left and right border%@NL@% END TYPE%@NL@% %@NL@% %@AB@%' TYPE for a group of global parameters:%@AE@%%@NL@% TYPE GlobalParams%@NL@% SysFlag AS INTEGER ' cYes means Analyze call is from system%@NL@% Initialized AS INTEGER ' cYes means clInitChart has been called%@NL@% %@NL@% PaletteScrn AS INTEGER ' Screen mode for which palette is set%@NL@% PaletteBits AS INTEGER ' Bits per pixel for current screen mode%@NL@% PaletteSet AS INTEGER ' cYes means palette has been initialized%@NL@% White AS INTEGER ' White attribute in current screen mode%@NL@% %@NL@% Aspect AS SINGLE ' Current screen aspect%@NL@% MaxXPix AS INTEGER ' Screen size along X axis%@NL@% MaxYPix AS INTEGER ' Screen size along Y axis%@NL@% MaxColor AS INTEGER ' Maximum color number for current screen%@NL@% %@NL@% ChartWid AS INTEGER ' Width of chart window%@NL@% ChartHgt AS INTEGER ' Height of chart window%@NL@% CwX1 AS INTEGER ' Left side of chart window%@NL@% CwY1 AS INTEGER ' Top edge of chart window%@NL@% CwX2 AS INTEGER ' Right side of chart window%@NL@% CwY2 AS INTEGER ' Bottom edge of chart window%@NL@% %@NL@% XStagger AS INTEGER ' Boolean, true if category labels overflow%@NL@% ValLenX AS INTEGER ' Maximum length of value labels on X-axis%@NL@% ValLenY AS INTEGER ' Maximum length of value labels on Y-axis%@NL@% %@NL@% NVals AS INTEGER ' Number of data values in data series%@NL@% NSeries AS INTEGER ' Number of series of data%@NL@% MSeries AS INTEGER ' If multiple-series chart then cYes, else%@NL@% %@AB@% ' cNo%@AE@%%@NL@% XMode AS INTEGER ' Axis mode of x axis%@NL@% YMode AS INTEGER ' Axis mode of y axis%@NL@% END TYPE%@NL@% %@NL@% %@AB@%' FUNCTION and SUB declarations for procedures local to this module:%@AE@%%@NL@% %@NL@% DECLARE FUNCTION clBuildBitP$ (Bits%, C%, InP$)%@NL@% DECLARE FUNCTION clBuildPlaneP$ (Bits%, C%, InP$)%@NL@% DECLARE FUNCTION clColorMaskL% (Bits%, Colr%)%@NL@% DECLARE FUNCTION clGetStyle% (StyleNum%)%@NL@% DECLARE FUNCTION clMaxVal (A, B)%@NL@% DECLARE FUNCTION clMap2Pal% (N%)%@NL@% DECLARE FUNCTION clMap2Attrib% (N%)%@NL@% DECLARE FUNCTION clMaxStrLen% (Txt$(), First%, Last%)%@NL@% DECLARE FUNCTION clVal2Str$ (X, Places%, Format%)%@NL@% %@NL@% DECLARE SUB clAdjustScale (Axis AS AxisType)%@NL@% DECLARE SUB clAnalyzeC (Cat$(), N%, SLabels$(), First%, Last%)%@NL@% DECLARE SUB clAnalyzeS (N%, SLabels$(), First%, Last%)%@NL@% DECLARE SUB clBuildPalette (ScrnMode%, Bits%)%@NL@% DECLARE SUB clChkInit ()%@NL@% DECLARE SUB clChkFonts ()%@NL@% DECLARE SUB clChkForErrors (Env AS ChartEnvironment, TypeMin%, TypeMax%, N%, First%, Last%)%@NL@% DECLARE SUB clChkChartWindow (Env AS ChartEnvironment)%@NL@% DECLARE SUB clChkPalettes (C%(), s%(), P$(), Char%(), B%())%@NL@% DECLARE SUB clClearError ()%@NL@% DECLARE SUB clColorMaskH (Bits%, Colr%, CMask%())%@NL@% DECLARE SUB clDrawAxes (Cat$())%@NL@% DECLARE SUB clDrawDataWindow ()%@NL@% DECLARE SUB clDrawChartWindow ()%@NL@% DECLARE SUB clDrawTitles ()%@NL@% DECLARE SUB clDrawLegend (SeriesLabel$(), First AS INTEGER, Last AS INTEGER)%@NL@% DECLARE SUB clDrawBarData ()%@NL@% DECLARE SUB clDrawColumnData ()%@NL@% DECLARE SUB clDrawLineData ()%@NL@% DECLARE SUB clDrawPieData (value(), Expl%(), N%)%@NL@% DECLARE SUB clDrawScatterData ()%@NL@% DECLARE SUB clFilter (A AS AxisType, AxisMode%, D1(), D2(), N%)%@NL@% DECLARE SUB clFilterMS (A AS AxisType, AxisMode%, D1(), D2(), N%, First%, Last%)%@NL@% DECLARE SUB clFlagSystem ()%@NL@% DECLARE SUB clFormatTics (A AS AxisType)%@NL@% DECLARE SUB clHPrint (X%, Y%, Txt$)%@NL@% DECLARE SUB clInitChart ()%@NL@% DECLARE SUB clInitStdStruc ()%@NL@% DECLARE SUB clLabelXTics (Axis AS AxisType, Cat$(), TicX, TicTotX%, TicY, YBoundry%)%@NL@% DECLARE SUB clLabelYTics (Axis AS AxisType, Cat$(), TicX, TicY, TicTotY%)%@NL@% DECLARE SUB clLayoutTitle (TL AS ANY, T1 AS ANY, T2 AS ANY)%@NL@% DECLARE SUB clPrintTitle (TitleVar AS TitleType, Y%)%@NL@% DECLARE SUB clRenderBar (X1, Y1, X2, Y2, C%)%@NL@% DECLARE SUB clRenderWindow (W AS RegionType)%@NL@% DECLARE SUB clScaleAxis (A AS AxisType, AxisMode%, D1())%@NL@% DECLARE SUB clSelectChartWindow ()%@NL@% DECLARE SUB clSelectRelWindow (W AS RegionType)%@NL@% DECLARE SUB clSetAxisModes ()%@NL@% DECLARE SUB clSetChartFont (N AS INTEGER)%@NL@% DECLARE SUB clSetError (ErrNo AS INTEGER)%@NL@% DECLARE SUB clSetCharColor (N%)%@NL@% DECLARE SUB clSetGlobalParams ()%@NL@% DECLARE SUB clSizeDataWindow (Cat$())%@NL@% DECLARE SUB clLayoutLegend (SeriesLabel$(), First%, Last%)%@NL@% DECLARE SUB clSpaceTics ()%@NL@% DECLARE SUB clSpaceTicsA (A AS AxisType, AxisMode%, AxisLen%, TicWid%)%@NL@% DECLARE SUB clTitleXAxis (A AS AxisType, X1%, X2%, YBoundry%)%@NL@% DECLARE SUB clTitleYAxis (A AS AxisType, Y1%, Y2%)%@NL@% DECLARE SUB clUnFlagSystem ()%@NL@% DECLARE SUB clVPrint (X%, Y%, Txt$)%@NL@% %@NL@% %@NL@% %@AB@%' Variable definitions local to this module:%@AE@%%@NL@% %@NL@% DIM PaletteC%(0 TO cPalLen) ' List of colors for drawing data%@NL@% DIM PaletteS%(0 TO cPalLen) ' List of styles for drawing data%@NL@% DIM PaletteP$(0 TO cPalLen) ' List of patterns for drawing data%@NL@% DIM PaletteCh%(0 TO cPalLen) ' List of plot chars for drawing data%@NL@% DIM PaletteB%(0 TO cPalLen) ' List of patterns for borders%@NL@% %@NL@% DIM StdChars%(0 TO cPalLen) ' Holds default plot characters%@NL@% %@NL@% DIM DAxis AS AxisType ' Default axis settings%@NL@% DIM DWindow AS RegionType ' Default window settings%@NL@% DIM DLegend AS LegendType ' Default legend settings%@NL@% DIM DTitle AS TitleType ' Default title settings%@NL@% %@NL@% DIM XTitleLayout AS TitleLayout ' X-axis layout information%@NL@% DIM YTitleLayout AS TitleLayout ' Y-axis layout information%@NL@% DIM TTitleLayout AS TitleLayout ' Main/Sub layout information%@NL@% %@NL@% DIM LLayout AS LegendLayout ' Legend layout information%@NL@% %@NL@% DIM GFI AS FontInfo ' Global font information%@NL@% DIM GE AS ChartEnvironment ' An internal global chart environment%@NL@% DIM GP AS GlobalParams ' Holds a number of global parameters%@NL@% %@AB@% ' used in the charting routines. See%@AE@%%@NL@% %@AB@% ' TYPE definition for details.%@AE@%%@NL@% %@NL@% %@AB@%'$DYNAMIC%@AE@%%@NL@% DIM V1(1, 1), V2(1, 1) ' Internal dynamic data arrays.%@NL@% %@AB@%'$STATIC%@AE@%%@NL@% %@NL@% %@AB@%'============================================================%@AE@%%@NL@% %@AB@%'============== Main Level Code ====================%@AE@%%@NL@% %@AB@%'============================================================%@AE@%%@NL@% %@NL@% %@AB@%' This error trap is set in the ChartScreen routine and will%@AE@%%@NL@% %@AB@%' be evoked if an invalid screen mode is used:%@AE@%%@NL@% ScreenErr:%@NL@% clSetError cBadScreen%@NL@% RESUME NEXT%@NL@% %@NL@% %@AB@%' This error trap should catch all errors that arise in using%@AE@%%@NL@% %@AB@%' the charting library that are not expected:%@AE@%%@NL@% UnexpectedErr:%@NL@% clSetError cCLUnexpectedOff + ERR%@NL@% RESUME NEXT%@NL@% %@NL@% %@AB@%'=== AnalyzeChart - Sets up scales and data window sizes%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Cat$(1) - One-dimensional array of category labels%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Value(1) - One-dimensional array of values to chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - The number of data values in data series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Scale and Data-Window values are changed as appropriate.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB AnalyzeChart (Env AS ChartEnvironment, Cat$(), value(), N AS INTEGER)%@NL@% %@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED V1()%@NL@% REDIM V1(1 TO N%, 1 TO 1)%@NL@% DIM Dum$(1 TO 1)%@NL@% %@NL@% %@AB@% ' Check initialization and fonts:%@AE@%%@NL@% clClearError%@NL@% clChkInit%@NL@% clChkFonts%@NL@% IF ChartErr >= 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Set a global flag to indicate that this isn't a multiple-series chart:%@AE@%%@NL@% GP.MSeries = cNo%@NL@% %@NL@% %@AB@% ' Check for obvious parameter and ChartEnvironment errors:%@AE@%%@NL@% clChkForErrors Env, 1, 3, N, 0, 0%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Make a copy of the user's ChartEnvironment variable to the library's%@AE@%%@NL@% %@AB@% ' global environment variable:%@AE@%%@NL@% GE = Env%@NL@% %@NL@% %@AB@% ' Set the correct axis modes for the type of chart specified in the%@AE@%%@NL@% %@AB@% ' chart environment:%@AE@%%@NL@% clSetAxisModes%@NL@% %@NL@% %@AB@% ' Transfer the input data to the dynamic working data array. Do this%@AE@%%@NL@% %@AB@% ' for each axis because, depending on the chart type, either one may be%@AE@%%@NL@% %@AB@% ' the value axis. The Filter routine automatically ignores the call if%@AE@%%@NL@% %@AB@% ' the axis is a category axis:%@AE@%%@NL@% clFilter GE.XAxis, GP.XMode, value(), V1(), N%@NL@% clFilter GE.YAxis, GP.YMode, value(), V1(), N%@NL@% %@NL@% %@AB@% ' Analyze the data for scale-maximum and -minimum and set the scale-%@AE@%%@NL@% %@AB@% ' factor, etc. depending on the options set in the chart environment:%@AE@%%@NL@% clAnalyzeC Cat$(), N, Dum$(), 1, 1%@NL@% %@NL@% %@AB@% ' Copy the global chart environment back to the user's ChartEnvironment%@AE@%%@NL@% %@AB@% ' variable so that the settings that were calculated by the library are%@AE@%%@NL@% %@AB@% ' accessible. Then, if this routine wasn't called by the library itself,%@AE@%%@NL@% %@AB@% ' in the course of drawing a bar, column or line chart, deallocate the%@AE@%%@NL@% %@AB@% ' working data array:%@AE@%%@NL@% Env = GE%@NL@% IF GP.SysFlag = cNo THEN ERASE V1%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== AnalyzeChartMS - Analyzes multiple-series data for scale/window size.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Cat$(1) - One-dimensional array of category labels%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Value(2) - Two-dimensional array of values to chart. First%@AE@%%@NL@% %@AB@%' dimension (rows) represents different values within%@AE@%%@NL@% %@AB@%' a series. Second dimension (columns) represents%@AE@%%@NL@% %@AB@%' different series.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - Number of values (beginning with 1) to chart per%@AE@%%@NL@% %@AB@%' series.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' First% - First series to analyze%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Last% - Last series to analyze%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' SeriesLabel$(1) - Labels for the different series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Various settings in the Env variable are altered in accordance with%@AE@%%@NL@% %@AB@%' the analysis.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB AnalyzeChartMS (Env AS ChartEnvironment, Cat$(), value() AS SINGLE, N AS INTEGER, First AS INTEGER, Last AS INTEGER, SeriesLabel$())%@NL@% %@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED V1()%@NL@% REDIM V1(1 TO N, 1 TO Last - First + 1)%@NL@% %@NL@% %@AB@% ' Check initialization and fonts:%@AE@%%@NL@% clClearError%@NL@% clChkInit%@NL@% clChkFonts%@NL@% IF ChartErr >= 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Set a global flag to indicate that this is a multiple-series chart:%@AE@%%@NL@% GP.MSeries = cYes%@NL@% %@NL@% %@AB@% ' Check for obvious parameter and ChartEnvironment errors:%@AE@%%@NL@% clChkForErrors Env, 1, 3, N, 0, 0%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Make a copy of the user's ChartEnvironment variable to the library's%@AE@%%@NL@% %@AB@% ' global environment variable:%@AE@%%@NL@% GE = Env%@NL@% %@NL@% %@AB@% ' Set the correct axis modes for the type of chart specified in the%@AE@%%@NL@% %@AB@% ' chart environment:%@AE@%%@NL@% clSetAxisModes%@NL@% %@NL@% %@AB@% ' Transfer the input data to the dynamic working data array. Do this%@AE@%%@NL@% %@AB@% ' for each axis because, depending on the chart type, either one may be%@AE@%%@NL@% %@AB@% ' the value axis. The Filter routine automatically ignores the call if%@AE@%%@NL@% %@AB@% ' the axis is a category axis:%@AE@%%@NL@% clFilterMS GE.XAxis, GP.XMode, value(), V1(), N, First, Last%@NL@% clFilterMS GE.YAxis, GP.YMode, value(), V1(), N, First, Last%@NL@% %@NL@% %@AB@% ' Analyze the data for scale maximums and minimums and set the scale%@AE@%%@NL@% %@AB@% ' factor, etc. depending on the options set in the chart environment:%@AE@%%@NL@% clAnalyzeC Cat$(), N, SeriesLabel$(), First, Last%@NL@% %@NL@% %@AB@% ' Copy the global chart environment back to the user's ChartEnvironment%@AE@%%@NL@% %@AB@% ' variable so that the settings that were calculated by the library are%@AE@%%@NL@% %@AB@% ' accessible. Then, if this routine wasn't called by the library itself,%@AE@%%@NL@% %@AB@% ' in the course of drawing a bar, column or line chart, deallocate the%@AE@%%@NL@% %@AB@% ' working data array:%@AE@%%@NL@% Env = GE%@NL@% IF GP.SysFlag = cNo THEN ERASE V1%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== AnalyzePie - Analyzes data for a pie chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Cat$() - One-dimensional array of category names%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Value() - One-dimensional array of values to chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Expl() - One dimensional array of flags indicating whether slices%@AE@%%@NL@% %@AB@%' are to be "exploded" (0 means no, 1 means yes).%@AE@%%@NL@% %@AB@%' Ignored if Env.ChartStyle <> 1.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N - The number of values to chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB AnalyzePie (Env AS ChartEnvironment, Cat$(), value() AS SINGLE, Expl() AS INTEGER, N AS INTEGER)%@NL@% SHARED GE AS ChartEnvironment%@NL@% SHARED GP AS GlobalParams%@NL@% SHARED TTitleLayout AS TitleLayout%@NL@% SHARED XTitleLayout AS TitleLayout%@NL@% SHARED YTitleLayout AS TitleLayout%@NL@% SHARED V1()%@NL@% DIM EmptyTitle AS TitleType%@NL@% %@NL@% %@AB@% ' Check initialization and fonts:%@AE@%%@NL@% clClearError%@NL@% clChkInit%@NL@% clChkFonts%@NL@% IF ChartErr >= 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' This is a multiple series chart (a pie chart is treated as a%@AE@%%@NL@% %@AB@% ' multiple series chart with each series having one value):%@AE@%%@NL@% GP.MSeries = cYes%@NL@% GP.NSeries = N%@NL@% %@NL@% %@AB@% ' Check for obvious parameter and ChartEnvironment errors:%@AE@%%@NL@% clChkForErrors Env, cPie, cPie, 2, 1, N%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Make a copy of the user's ChartEnvironment variable to the library's%@AE@%%@NL@% %@AB@% ' global environment variable:%@AE@%%@NL@% GE = Env%@NL@% %@NL@% %@AB@% ' Set the correct axis modes for the type of chart specified in the%@AE@%%@NL@% %@AB@% ' chart environment:%@AE@%%@NL@% clSetAxisModes%@NL@% %@NL@% %@AB@% ' Set global parameters and layout main title:%@AE@%%@NL@% clSetGlobalParams%@NL@% %@NL@% %@AB@% ' Layout titles (ignore X and Y axis titles):%@AE@%%@NL@% clLayoutTitle TTitleLayout, GE.MainTitle, GE.SubTitle%@NL@% EmptyTitle.Title = ""%@NL@% clLayoutTitle XTitleLayout, EmptyTitle, EmptyTitle%@NL@% clLayoutTitle YTitleLayout, EmptyTitle, EmptyTitle%@NL@% %@NL@% %@AB@% ' Calculate the size for LegendWindow and DataWindow:%@AE@%%@NL@% clLayoutLegend Cat$(), 1, N%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% clSizeDataWindow Cat$()%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Copy the global chart environment back to the user's ChartEnvironment%@AE@%%@NL@% %@AB@% ' variable so that the settings that were calculated by the library are%@AE@%%@NL@% %@AB@% ' accessible. Then, if this routine wasn't called by the library itself,%@AE@%%@NL@% %@AB@% ' in the course of drawing a pie chart, deallocate the working data array:%@AE@%%@NL@% Env = GE%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== AnalyzeScatter - Sets up scales and data-window sizes for scatter chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ValX(1) - One-dimensional array of values for X axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ValY(1) - One-dimensional array of values for Y axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - The number of data values in data series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Scale and data-window values are changed as appropriate.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB AnalyzeScatter (Env AS ChartEnvironment, ValX() AS SINGLE, ValY() AS SINGLE, N AS INTEGER)%@NL@% %@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED V1(), V2()%@NL@% REDIM V1(1 TO N, 1 TO 1), V2(1 TO N, 1 TO 1)%@NL@% DIM Dum$(1 TO 1)%@NL@% %@NL@% %@AB@% ' Check initialization and fonts:%@AE@%%@NL@% clClearError%@NL@% clChkInit%@NL@% clChkFonts%@NL@% IF ChartErr >= 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Set a global flag to indicate that this isn't a multiple-series chart:%@AE@%%@NL@% GP.MSeries = cNo%@NL@% %@NL@% %@AB@% ' Check for obvious parameter and ChartEnvironment errors:%@AE@%%@NL@% clChkForErrors Env, 4, 4, N%, 0, 0%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Make a copy of the user's ChartEnvironment variable to the library's%@AE@%%@NL@% %@AB@% ' global environment variable:%@AE@%%@NL@% GE = Env%@NL@% %@NL@% %@AB@% ' Set the correct axis modes for the type of chart specified in the%@AE@%%@NL@% %@AB@% ' chart environment:%@AE@%%@NL@% clSetAxisModes%@NL@% %@NL@% %@AB@% ' Transfer the input data to the dynamic working data arrays (one%@AE@%%@NL@% %@AB@% ' for each axis):%@AE@%%@NL@% clFilter GE.XAxis, GP.XMode, ValX(), V1(), N%@NL@% clFilter GE.YAxis, GP.YMode, ValY(), V2(), N%@NL@% %@NL@% %@AB@% ' Analyze the data for scale-maximum and -minimum and set the scale-%@AE@%%@NL@% %@AB@% ' factor, etc. depending on the options set in the chart environment:%@AE@%%@NL@% clAnalyzeS N, Dum$(), 1, 1%@NL@% %@NL@% %@AB@% ' Copy the global chart environment back to the user's ChartEnvironment%@AE@%%@NL@% %@AB@% ' variable so that the settings that were calculated by the library are%@AE@%%@NL@% %@AB@% ' accessible. Then, if this routine wasn't called by the library itself,%@AE@%%@NL@% %@AB@% ' in the course of drawing a scatter chart, deallocate the working%@AE@%%@NL@% %@AB@% ' data arrays:%@AE@%%@NL@% Env = GE%@NL@% IF GP.SysFlag = cNo THEN ERASE V1, V2%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== AnalyzeScatterMS - Analyzes multiple-series data for scale/window size%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ValX(2) - Two-dimensional array of values for X axis. First%@AE@%%@NL@% %@AB@%' dimension (rows) represents different values within%@AE@%%@NL@% %@AB@%' a series. Second dimension (columns) represents%@AE@%%@NL@% %@AB@%' different series.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ValY(2) - Two-dimensional array of values for Y axis. Above%@AE@%%@NL@% %@AB@%' comments apply%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - Number of values (beginning with 1) to chart per%@AE@%%@NL@% %@AB@%' series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' First% - First series to analyze%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Last% - Last series to analyze%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' SeriesLabel$(1) - Labels for the different series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Various settings in the Env variable are altered in accordance with%@AE@%%@NL@% %@AB@%' the analysis.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB AnalyzeScatterMS (Env AS ChartEnvironment, ValX() AS SINGLE, ValY() AS SINGLE, N AS INTEGER, First AS INTEGER, Last AS INTEGER, SeriesLabel$())%@NL@% %@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED V1(), V2()%@NL@% REDIM V1(1 TO N, 1 TO Last - First + 1), V2(1 TO N, 1 TO Last - First + 1)%@NL@% DIM Dum$(1 TO 1)%@NL@% %@NL@% %@AB@% ' Check initialization and fonts:%@AE@%%@NL@% clClearError%@NL@% clChkInit%@NL@% clChkFonts%@NL@% IF ChartErr >= 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Set a global flag to indicate that this is a multiple-series chart:%@AE@%%@NL@% GP.MSeries = cYes%@NL@% %@NL@% %@AB@% ' Check for obvious parameter and ChartEnvironment errors:%@AE@%%@NL@% clChkForErrors Env, 4, 4, N%, 0, 0%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Make a copy of the user's ChartEnvironment variable to the library's%@AE@%%@NL@% %@AB@% ' global environment variable:%@AE@%%@NL@% GE = Env%@NL@% %@NL@% %@AB@% ' Set the correct axis modes for the type of chart specified in the%@AE@%%@NL@% %@AB@% ' chart environment:%@AE@%%@NL@% clSetAxisModes%@NL@% %@NL@% %@AB@% ' Transfer the input data to the dynamic working data arrays (one%@AE@%%@NL@% %@AB@% ' for each axis):%@AE@%%@NL@% clFilterMS GE.XAxis, GP.XMode, ValX(), V1(), N, First, Last%@NL@% clFilterMS GE.YAxis, GP.YMode, ValY(), V2(), N, First, Last%@NL@% %@NL@% %@AB@% ' Analyze the data for scale-maximum and -minimum and set the scale-%@AE@%%@NL@% %@AB@% ' factor, etc. depending on the options set in the chart environment:%@AE@%%@NL@% clAnalyzeS N, SeriesLabel$(), First%, Last%%@NL@% %@NL@% %@AB@% ' Copy the global chart environment back to the user's ChartEnvironment%@AE@%%@NL@% %@AB@% ' variable so that the settings that were calculated by the library are%@AE@%%@NL@% %@AB@% ' accessible. Then, if this routine wasn't called by the library itself,%@AE@%%@NL@% %@AB@% ' in the course of drawing a scatter chart, deallocate the working%@AE@%%@NL@% %@AB@% ' data arrays:%@AE@%%@NL@% Env = GE%@NL@% IF GP.SysFlag = cNo THEN ERASE V1, V2%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== Chart - Draws a single-series category/value chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Cat$(1) - One-dimensional array of category labels%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Value(1) - One-dimensional array of values to plot%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N - The number of data values in data series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Some elements of the Env variable are altered by plotting routines%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' This routine takes all of the parameters set in the Env variable%@AE@%%@NL@% %@AB@%' and draws a single-series chart of type Bar, Column, or Line%@AE@%%@NL@% %@AB@%' depending on the chart type specified in the Env variable.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB Chart (Env AS ChartEnvironment, Cat$(), value() AS SINGLE, N AS INTEGER)%@NL@% %@NL@% SHARED V1()%@NL@% %@NL@% %@AB@% ' Analyze data for scale and window settings:%@AE@%%@NL@% clFlagSystem%@NL@% AnalyzeChart Env, Cat$(), value(), N%@NL@% clUnFlagSystem%@NL@% IF ChartErr < 100 THEN%@NL@% %@NL@% %@AB@% ' Draw the different elements of the chart:%@AE@%%@NL@% clDrawChartWindow%@NL@% clDrawTitles%@NL@% clDrawDataWindow%@NL@% clDrawAxes Cat$()%@NL@% %@NL@% %@AB@% ' Call appropriate Draw...Data routine for chart type:%@AE@%%@NL@% SELECT CASE Env.ChartType%@NL@% CASE 1: clDrawBarData%@NL@% CASE 2: clDrawColumnData%@NL@% CASE 3: clDrawLineData%@NL@% END SELECT%@NL@% %@NL@% END IF%@NL@% %@NL@% %@AB@% ' Deallocate the data array:%@AE@%%@NL@% ERASE V1%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== ChartMS - Draws a multiple-series category/value chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Cat$(1) - A one-dimensional array of category names for the%@AE@%%@NL@% %@AB@%' different data values%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Value(2) - A two-dimensional array of values--one column for%@AE@%%@NL@% %@AB@%' each series of data%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - The number of data points in each series of data%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' First% - The first series to be plotted%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Last% - The last series to be plotted%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' SeriesLabel$(1) - Labels used for each series in the legend%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Some elements of the Env variable are altered by plotting routines%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' This routine takes all of the parameters set in the Env variable%@AE@%%@NL@% %@AB@%' and draws a multiple-series chart of type Bar, Column, or Line%@AE@%%@NL@% %@AB@%' depending on the chart type specified in the Env variable.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB ChartMS (Env AS ChartEnvironment, Cat$(), value() AS SINGLE, N AS INTEGER, First AS INTEGER, Last AS INTEGER, SeriesLabel$())%@NL@% %@NL@% SHARED V1()%@NL@% %@NL@% %@AB@% ' Analyze data for scale settings:%@AE@%%@NL@% clFlagSystem%@NL@% AnalyzeChartMS Env, Cat$(), value(), N, First, Last, SeriesLabel$()%@NL@% clUnFlagSystem%@NL@% IF ChartErr < 100 THEN%@NL@% %@NL@% %@AB@% ' Draw the different elements of the chart:%@AE@%%@NL@% clDrawChartWindow%@NL@% clDrawTitles%@NL@% clDrawDataWindow%@NL@% clDrawAxes Cat$()%@NL@% %@NL@% %@AB@% ' Call appropriate Draw...DataMS routine for chart type:%@AE@%%@NL@% SELECT CASE Env.ChartType%@NL@% CASE 1: clDrawBarData%@NL@% CASE 2: clDrawColumnData%@NL@% CASE 3: clDrawLineData%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Lastly, add the legend:%@AE@%%@NL@% clDrawLegend SeriesLabel$(), First, Last%@NL@% %@NL@% END IF%@NL@% %@NL@% %@AB@% ' Deallocate the data array:%@AE@%%@NL@% ERASE V1%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== ChartPie - Draws a pie chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Cat$() - One-dimensional array of category names%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Value() - One-dimensional array of values to chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Expl%() - One-dimensional array of flags indicating whether slices%@AE@%%@NL@% %@AB@%' are to be "exploded" or not (0 means no, 1 means yes),%@AE@%%@NL@% %@AB@%' ignored if ChartStyle <> 1%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - The number of values to chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' No return values%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB ChartPie (Env AS ChartEnvironment, Cat$(), value() AS SINGLE, Expl() AS INTEGER, N AS INTEGER)%@NL@% SHARED GP AS GlobalParams%@NL@% %@AB@% ' Set the global system flag to tell the AnalyzePie routine that it%@AE@%%@NL@% %@AB@% ' is being called by the system and not the user:%@AE@%%@NL@% clFlagSystem%@NL@% %@NL@% %@AB@% ' Calculate the size of the Data- and Legend-window:%@AE@%%@NL@% AnalyzePie Env, Cat$(), value(), Expl(), N%@NL@% %@NL@% %@AB@% ' Remove the system flag:%@AE@%%@NL@% clUnFlagSystem%@NL@% %@NL@% %@AB@% ' If there were no errors during analysis draw the chart:%@AE@%%@NL@% IF ChartErr < 100 THEN%@NL@% %@NL@% %@AB@% ' Draw the different chart elements:%@AE@%%@NL@% clDrawChartWindow%@NL@% clDrawTitles%@NL@% clDrawDataWindow%@NL@% clDrawPieData value(), Expl(), N%@NL@% IF ChartErr <> 0 THEN EXIT SUB%@NL@% clDrawLegend Cat$(), 1, N%@NL@% %@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== ChartScatter - Draws a single-series scatter chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ValX(1) - One-dimensional array of values for X axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ValY(1) - One-dimensional array of values for Y axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - The number of values to chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Some elements of Env variable may be changed by drawing routines%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' ChartScatter should be called when a chart with two value axes is%@AE@%%@NL@% %@AB@%' desired%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB ChartScatter (Env AS ChartEnvironment, ValX() AS SINGLE, ValY() AS SINGLE, N AS INTEGER)%@NL@% DIM Dum$(1 TO 1)%@NL@% SHARED V1(), V2()%@NL@% %@NL@% %@AB@% ' Set the global system flag to tell the AnalyzeScatter routine that it%@AE@%%@NL@% %@AB@% ' is being called by the system and not the user:%@AE@%%@NL@% clFlagSystem%@NL@% %@NL@% %@AB@% ' Calculate the scale maximums and minimums and scale factor. Also%@AE@%%@NL@% %@AB@% ' calculate the sizes for the Data- and Legend-windows:%@AE@%%@NL@% AnalyzeScatter Env, ValX(), ValY(), N%@NL@% %@NL@% %@AB@% ' Remove the system flag:%@AE@%%@NL@% clUnFlagSystem%@NL@% %@NL@% %@AB@% ' If there were no errors during analysis draw the chart:%@AE@%%@NL@% IF ChartErr < 100 THEN%@NL@% %@NL@% %@AB@% ' Draw the different elements of the chart:%@AE@%%@NL@% clDrawChartWindow%@NL@% clDrawTitles%@NL@% clDrawDataWindow%@NL@% clDrawAxes Dum$()%@NL@% clDrawScatterData%@NL@% %@NL@% END IF%@NL@% %@NL@% %@AB@% ' Deallocate the dynamic working data arrays:%@AE@%%@NL@% ERASE V1, V2%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== ChartScatterMS - Draws a multiple-series scatter chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ValX(2) - Two-dimensional array of values for X axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ValY(2) - Two-dimensional array of values for Y axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - The number of values in each series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' First% - First series to chart (first column)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Last% - Last series to chart (last column)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' SeriesLabel$() - Label used for each series in legend%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Some elements in Env variable may be changed by drawing routines%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' A scatter chart uses two value axes so it must have values for both%@AE@%%@NL@% %@AB@%' the X and Y axes (ValX(), ValY()). The first dimension denotes%@AE@%%@NL@% %@AB@%' the different values within a series. The second dimension specifies%@AE@%%@NL@% %@AB@%' different data series (e.g. ValX(4,3) would represent the fourth value%@AE@%%@NL@% %@AB@%' in the third series of data).%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB ChartScatterMS (Env AS ChartEnvironment, ValX() AS SINGLE, ValY() AS SINGLE, N AS INTEGER, First AS INTEGER, Last AS INTEGER, SeriesLabel$())%@NL@% DIM Dum$(1 TO 1)%@NL@% SHARED V1(), V2()%@NL@% %@NL@% %@AB@% ' Set the global system flag to tell the AnalyzeScatterMS routine that it%@AE@%%@NL@% %@AB@% ' is being called by the system and not the user:%@AE@%%@NL@% clFlagSystem%@NL@% %@NL@% %@AB@% ' Calculate the scale maximums and minimums and scale factor. Also%@AE@%%@NL@% %@AB@% ' calculate the sizes for the Data- and Legend-windows:%@AE@%%@NL@% AnalyzeScatterMS Env, ValX(), ValY(), N, First, Last, SeriesLabel$()%@NL@% %@NL@% %@AB@% ' Remove the system flag:%@AE@%%@NL@% clUnFlagSystem%@NL@% %@NL@% %@AB@% ' If there were no errors during analysis draw the chart:%@AE@%%@NL@% IF ChartErr < 100 THEN%@NL@% %@NL@% %@AB@% ' Draw the different elements of the chart:%@AE@%%@NL@% clDrawChartWindow%@NL@% clDrawTitles%@NL@% clDrawDataWindow%@NL@% clDrawAxes Dum$()%@NL@% clDrawScatterData%@NL@% clDrawLegend SeriesLabel$(), First, Last%@NL@% %@NL@% END IF%@NL@% %@NL@% %@AB@% ' Deallocate the dynamic working data arrays:%@AE@%%@NL@% ERASE V1, V2%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== ChartScreen - Sets the SCREEN mode and default palettes%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' N% - A valid BASIC graphic mode, or mode 0%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' All palettes may be altered%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB ChartScreen (N AS INTEGER)%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% %@AB@% ' Check initialization and fonts:%@AE@%%@NL@% clClearError%@NL@% clChkInit%@NL@% %@NL@% %@AB@% ' Set up branch to error processor and attempt to set the specified%@AE@%%@NL@% %@AB@% ' screen mode and draw to it:%@AE@%%@NL@% ON ERROR GOTO ScreenErr%@NL@% SCREEN N%@NL@% IF N <> 0 THEN PRESET (0, 0)%@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@% ' If the above PRESET failed, then the TestScreen error processor will%@AE@%%@NL@% %@AB@% ' have set the ChartErr error variable to a nonzero value. If the last%@AE@%%@NL@% %@AB@% ' call to ChartScreen used the same mode, GP.PaletteScrn will equal N; and%@AE@%%@NL@% %@AB@% ' there is no need to rebuild palettes. In either case there is no need%@AE@%%@NL@% %@AB@% ' to do anything else, so exit:%@AE@%%@NL@% IF ChartErr <> 0 OR (GP.PaletteScrn = N AND GP.PaletteSet) THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' This is a new screen mode so use the SELECT CASE statement below%@AE@%%@NL@% %@AB@% ' to handle it. It sets the number of bits per pixel for a screen%@AE@%%@NL@% %@AB@% ' mode so that the palettes can be built properly:%@AE@%%@NL@% SELECT CASE N%@NL@% %@NL@% %@AB@% ' Screen mode 0 is not a graphics mode and is included mainly for%@AE@%%@NL@% %@AB@% ' completeness. The actual screen mode has been set above, so exit:%@AE@%%@NL@% CASE 0:%@NL@% EXIT SUB%@NL@% %@NL@% CASE 1: Bits% = 2%@NL@% CASE 2: Bits% = 1%@NL@% CASE 3: Bits% = 1%@NL@% CASE 4: Bits% = 1%@NL@% CASE 7: Bits% = 4%@NL@% CASE 8: Bits% = 4%@NL@% CASE 9:%@NL@% %@AB@% ' For screen mode 9, assume a 256K EGA and try setting%@AE@%%@NL@% %@AB@% ' a color to 63. If that fails, assume it is a 64K EGA%@AE@%%@NL@% %@AB@% ' (the number of bit planes is four for 256K and two for%@AE@%%@NL@% %@AB@% ' 64K):%@AE@%%@NL@% Bits% = 4%@NL@% ON ERROR GOTO ScreenErr%@NL@% clClearError%@NL@% COLOR 15%@NL@% IF ChartErr <> 0 THEN Bits% = 2%@NL@% clClearError%@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% CASE 10: Bits% = 2%@NL@% CASE 11: Bits% = 1%@NL@% CASE 12: Bits% = 4%@NL@% CASE 13: Bits% = 8%@NL@% %@NL@% %@AB@% ' If none of the above match then a valid screen mode was specified;%@AE@%%@NL@% %@AB@% ' however the mode is un-supported so set error and exit:%@AE@%%@NL@% CASE ELSE: clSetError cBadScreen%@NL@% EXIT SUB%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' The screen aspect is 4/3 * MaxY/MaxX:%@AE@%%@NL@% VIEW%@NL@% WINDOW (0, 0)-(1, 1)%@NL@% GP.MaxXPix% = PMAP(1, 0) + 1%@NL@% GP.MaxYPix% = PMAP(0, 1) + 1%@NL@% GP.Aspect = 1.33333 * (GP.MaxYPix% - 1) / (GP.MaxXPix% - 1)%@NL@% WINDOW%@NL@% %@NL@% %@AB@% ' The number of colors available:%@AE@%%@NL@% GP.MaxColor = 2 ^ Bits% - 1%@NL@% %@NL@% %@AB@% ' Specify which color to use for white:%@AE@%%@NL@% SELECT CASE N%@NL@% CASE 13: GP.White = 15%@NL@% CASE ELSE: GP.White = GP.MaxColor%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Build palette for this screen mode:%@AE@%%@NL@% clBuildPalette N, Bits%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clAdjustScale - Calculates scaling factor for an axis and adjusts max-min%@AE@%%@NL@% %@AB@%' as appropriate for scale factor and log base if log axis:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Axis - AxisType variable describing axis to be scaled.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' May set the ScaleFactor and ScaleTitle elements and alter%@AE@%%@NL@% %@AB@%' ScaleMin and ScaleMax elements of the Axis variable.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clAdjustScale (Axis AS AxisType)%@NL@% %@NL@% %@AB@% ' Don't try to scale a log axis:%@AE@%%@NL@% IF Axis.RangeType = cLog THEN%@NL@% %@NL@% Axis.ScaleFactor = 1%@NL@% Axis.ScaleTitle.Title = "Log" + STR$(Axis.LogBase)%@NL@% %@NL@% %@AB@% ' For a linear axis, choose a scale factor up to Trillions depending%@AE@%%@NL@% %@AB@% ' on the size of the axis limits:%@AE@%%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' Choose the largest ABS from Max and Min for the axis:%@AE@%%@NL@% IF ABS(Axis.ScaleMax) > ABS(Axis.ScaleMin) THEN%@NL@% Max = ABS(Axis.ScaleMax)%@NL@% ELSE%@NL@% Max = ABS(Axis.ScaleMin)%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Find out power of three by which to scale:%@AE@%%@NL@% Power% = INT((LOG(Max) / LOG(10)) / 3)%@NL@% %@NL@% %@AB@% ' And, choose the correct title to go with it:%@AE@%%@NL@% SELECT CASE Power%%@NL@% CASE -4: Axis.ScaleTitle.Title = "Trillionths"%@NL@% CASE -3: Axis.ScaleTitle.Title = "Billionths"%@NL@% CASE -2: Axis.ScaleTitle.Title = "Millionths"%@NL@% CASE -1: Axis.ScaleTitle.Title = "Thousandths"%@NL@% CASE 0: Axis.ScaleTitle.Title = ""%@NL@% CASE 1: Axis.ScaleTitle.Title = "Thousands"%@NL@% CASE 2: Axis.ScaleTitle.Title = "Millions"%@NL@% CASE 3: Axis.ScaleTitle.Title = "Billions"%@NL@% CASE 4: Axis.ScaleTitle.Title = "Trillions"%@NL@% CASE ELSE: Axis.ScaleTitle.Title = "10^" + LTRIM$(STR$(Power% * 3))%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Calculate the actual scale factor:%@AE@%%@NL@% Axis.ScaleFactor = 10 ^ (3 * Power%)%@NL@% %@NL@% %@AB@% ' Finally, scale Max and Min by ScaleFactor:%@AE@%%@NL@% Axis.ScaleMin = Axis.ScaleMin / Axis.ScaleFactor%@NL@% Axis.ScaleMax = Axis.ScaleMax / Axis.ScaleFactor%@NL@% %@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clAnalyzeC - Does analysis of category/value data%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Cat$(1) - List of category names%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - Number of data values per series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' SLabels$ - Labels for the different data series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' First% - First series to chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Last% - Last series to chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Some values in GE are altered.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clAnalyzeC (Cat$(), N%, SLabels$(), First%, Last%)%@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED TTitleLayout AS TitleLayout%@NL@% SHARED XTitleLayout AS TitleLayout%@NL@% SHARED YTitleLayout AS TitleLayout%@NL@% SHARED V1()%@NL@% %@NL@% %@AB@% ' Save the number of values and the number of series in the chart in%@AE@%%@NL@% %@AB@% ' the global parameter variables:%@AE@%%@NL@% GP.NVals = N%%@NL@% GP.NSeries = Last% - First% + 1%@NL@% %@NL@% %@AB@% ' Analyze data for scale-maximim and -minimum and scale-factor:%@AE@%%@NL@% clScaleAxis GE.XAxis, GP.XMode, V1()%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% clScaleAxis GE.YAxis, GP.YMode, V1()%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Format tic labels (needed for sizing routines) and set global%@AE@%%@NL@% %@AB@% ' parameters (again used by sizing and other routines):%@AE@%%@NL@% clFormatTics GE.XAxis%@NL@% clFormatTics GE.YAxis%@NL@% clSetGlobalParams%@NL@% %@NL@% %@AB@% ' Layout Titles%@AE@%%@NL@% clLayoutTitle TTitleLayout, GE.MainTitle, GE.SubTitle%@NL@% clLayoutTitle YTitleLayout, GE.YAxis.AxisTitle, GE.YAxis.ScaleTitle%@NL@% clLayoutTitle XTitleLayout, GE.XAxis.AxisTitle, GE.XAxis.ScaleTitle%@NL@% %@NL@% %@AB@% ' If this is a multiple-series chart, calculate the legend size:%@AE@%%@NL@% IF GP.MSeries = cYes THEN clLayoutLegend SLabels$(), First%, Last%%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Calculate the data-window size:%@AE@%%@NL@% clSizeDataWindow Cat$()%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Finally, figure out the distance between tic marks:%@AE@%%@NL@% clSpaceTics%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clAnalyzeS - Does actual analysis of scatter data%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' N% - Number of values per data series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' SLabels$(1) - Labels for the data series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' First% - First series to analyze%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Last% - Last series to analyze%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Values in GE are altered.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clAnalyzeS (N%, SLabels$(), First%, Last%)%@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED TTitleLayout AS TitleLayout%@NL@% SHARED XTitleLayout AS TitleLayout%@NL@% SHARED YTitleLayout AS TitleLayout%@NL@% SHARED V1(), V2()%@NL@% DIM Dum$(1 TO 1)%@NL@% %@NL@% %@AB@% ' Save the number of values and the number of series in the chart in%@AE@%%@NL@% %@AB@% ' the global parameter variables:%@AE@%%@NL@% GP.NVals = N%%@NL@% GP.NSeries = Last% - First% + 1%@NL@% %@NL@% %@AB@% ' Analyze data for scale-maximim and -minimum and scale-factor:%@AE@%%@NL@% clScaleAxis GE.XAxis, GP.XMode, V1()%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% clScaleAxis GE.YAxis, GP.YMode, V2()%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Format tic labels (needed for sizing routines) and set global%@AE@%%@NL@% %@AB@% ' parameters (again used by sizing and other routines):%@AE@%%@NL@% clFormatTics GE.XAxis%@NL@% clFormatTics GE.YAxis%@NL@% clSetGlobalParams%@NL@% %@NL@% %@AB@% ' Layout Titles%@AE@%%@NL@% clLayoutTitle TTitleLayout, GE.MainTitle, GE.SubTitle%@NL@% clLayoutTitle YTitleLayout, GE.YAxis.AxisTitle, GE.YAxis.ScaleTitle%@NL@% clLayoutTitle XTitleLayout, GE.XAxis.AxisTitle, GE.XAxis.ScaleTitle%@NL@% %@NL@% %@AB@% ' If this is a multiple-series chart, calculate the legend size:%@AE@%%@NL@% IF GP.MSeries = cYes THEN clLayoutLegend SLabels$(), First%, Last%%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Calculate the data window size:%@AE@%%@NL@% clSizeDataWindow Dum$()%@NL@% IF ChartErr > 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Finally, figure out the distance between tic marks:%@AE@%%@NL@% clSpaceTics%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clBuildBitP$ - Builds a pattern tile for a one bit-plane screen mode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Bits% = Number of bits per pixel in this screen mode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' C% = The color used to make the pattern.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' InP$ = Reference pattern%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Returns the specified pattern in specified color.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' In screen modes where a pixel on the screen is represented by 1 or%@AE@%%@NL@% %@AB@%' more bits that are adjacent in memory, a byte of memory represents%@AE@%%@NL@% %@AB@%' one or more pixels depending on the number of bits per pixel the%@AE@%%@NL@% %@AB@%' mode uses (e.g. screen mode 1 uses 2 bits per pixel so each byte%@AE@%%@NL@% %@AB@%' contains 4 pixels). To make a pattern tile in a specific color%@AE@%%@NL@% %@AB@%' you first decide which pixels should be on and which ones off.%@AE@%%@NL@% %@AB@%' Then, you set the corresponding two-bit pixels in the tile bytes%@AE@%%@NL@% %@AB@%' to the value of the color you want the pattern to be. This routine%@AE@%%@NL@% %@AB@%' does this semi-automatically. First it inputs a reference pattern that%@AE@%%@NL@% %@AB@%' contains the pattern defined in the highest color available for a%@AE@%%@NL@% %@AB@%' screen mode (all bits in a pixel set to one). Then a color mask byte%@AE@%%@NL@% %@AB@%' is prepared with each pixel set to the color that was specified as%@AE@%%@NL@% %@AB@%' input to the routine. When these two components (reference pattern%@AE@%%@NL@% %@AB@%' and color mask) are combined using a logical "AND" any pixel in the%@AE@%%@NL@% %@AB@%' reference pattern that was black (all zero) will remain black and any%@AE@%%@NL@% %@AB@%' pixel that was white will be of the input color. The nice feature of%@AE@%%@NL@% %@AB@%' this scheme is that you can use one pattern set for any color%@AE@%%@NL@% %@AB@%' available for the screen mode.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Example: Screen mode 1; 2 bits per pixel; to build a pattern%@AE@%%@NL@% %@AB@%' with pixels alternating on and off in color 2:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Reference pattern: 11 00 11 00 (8 bits = 1 byte)%@AE@%%@NL@% %@AB@%' Color mask: 10 10 10 10 (each pixel set to color 2)%@AE@%%@NL@% %@AB@%' -------------%@AE@%%@NL@% %@AB@%' Result of "AND" 10 00 10 00 (pattern in color 2)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION clBuildBitP$ (Bits%, C%, InP$)%@NL@% %@NL@% %@AB@% ' First get color mask to match this color and pixel size (bits per pixel):%@AE@%%@NL@% CMask% = clColorMaskL%(Bits%, C%)%@NL@% %@NL@% %@AB@% ' Initialize the output pattern to empty then combine the color%@AE@%%@NL@% %@AB@% ' mask with each byte in the input tile using a logical "AND":%@AE@%%@NL@% OutP$ = ""%@NL@% FOR i% = 1 TO LEN(InP$)%@NL@% NxtCH% = CMask% AND ASC(MID$(InP$, i%, 1))%@NL@% OutP$ = OutP$ + CHR$(NxtCH%)%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' Return the completed pattern:%@AE@%%@NL@% clBuildBitP$ = OutP$%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== clBuildPalette - Builds the five chart palettes%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' N - Screen mode for which to build palettes%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Values in chart palettes set to standard ones for this mode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' The following code sets up the palettes that are referenced when the%@AE@%%@NL@% %@AB@%' different chart elements are drawn. See the charting library%@AE@%%@NL@% %@AB@%' documentation for a complete description of how these palettes are%@AE@%%@NL@% %@AB@%' used in drawing different portions of a chart.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clBuildPalette (ScrnMode AS INTEGER, Bits AS INTEGER)%@NL@% SHARED PaletteC%(), PaletteS%(), PaletteP$(), PaletteCh%(), PaletteB%()%@NL@% SHARED StdChars%()%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% %@AB@% ' Flag palette set and record the screen mode:%@AE@%%@NL@% GP.PaletteSet = cYes%@NL@% GP.PaletteScrn = ScrnMode%@NL@% GP.PaletteBits = Bits%@NL@% %@NL@% %@AB@% ' The first palettes to set are the character palette and the border%@AE@%%@NL@% %@AB@% ' style palette:%@AE@%%@NL@% PaletteCh%(0) = 0%@NL@% PaletteB%(0) = &HFFFF%@NL@% FOR i% = 1 TO cPalLen%@NL@% PaletteCh%(i%) = StdChars%(i%)%@NL@% PaletteB%(i%) = clGetStyle(i%)%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' The next palette to set is the color palette, which is made up of%@AE@%%@NL@% %@AB@% ' a list of 10 (maybe repeating) colors. Begin by setting the first%@AE@%%@NL@% %@AB@% ' two colors. The first color (position 0) is always black and the%@AE@%%@NL@% %@AB@% ' second color is always white (or whatever the maximum color number%@AE@%%@NL@% %@AB@% ' is mapped to in the graphics-card palette). Cycle through setting%@AE@%%@NL@% %@AB@% ' other colors. They will be entered in order starting with color 1%@AE@%%@NL@% %@AB@% ' until the maximum number of colors is reached or the palette is filled%@AE@%%@NL@% %@AB@% ' (size governed by the cPalLen CONST). If the maximum color is reached%@AE@%%@NL@% %@AB@% ' before the palette is filled then repeat the cycle again excluding%@AE@%%@NL@% %@AB@% ' color 0, and so on, until the color palette is filled:%@AE@%%@NL@% %@NL@% PaletteC%(0) = 0 ' Black%@NL@% PaletteC%(1) = GP.White ' White%@NL@% %@NL@% FOR i% = 2 TO cPalLen%@NL@% MappedI% = ((i% - 2) MOD GP.MaxColor) + 1%@NL@% PaletteC%(i%) = MappedI%%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' Setting the line styles is almost the inverse of setting the colors%@AE@%%@NL@% %@AB@% ' in that each color within a cycle has the same line style. When a%@AE@%%@NL@% %@AB@% ' new cycle of colors begins, though, the line style changes to%@AE@%%@NL@% %@AB@% ' differentiate the new cycle from previous ones. The line style%@AE@%%@NL@% %@AB@% ' begins as &HFFFF or a solid line:%@AE@%%@NL@% %@NL@% %@AB@% ' The pattern component of the palette contains fill patterns for use in%@AE@%%@NL@% %@AB@% ' filling bars and pie slices. Fill patterns are "bit" oriented whereas%@AE@%%@NL@% %@AB@% ' line styles are "pixel" oriented. What this means is that a fill%@AE@%%@NL@% %@AB@% ' pattern of CHR$(&HFF) will be white regardless of what the current%@AE@%%@NL@% %@AB@% ' color is. If you know that each pixel on the screen is represented by%@AE@%%@NL@% %@AB@% ' 2 bits in RAM and you want a solid fill with color 2, the corresponding%@AE@%%@NL@% %@AB@% ' definition would be CHR$(&HAA) (in binary 10 10 10 10 -- notice, four%@AE@%%@NL@% %@AB@% ' pixels of two bits each set to 2). The following code automatically%@AE@%%@NL@% %@AB@% ' takes a fill pattern defined in terms of pixels, and by masking it%@AE@%%@NL@% %@AB@% ' with the current color generates the same fill pattern in the%@AE@%%@NL@% %@AB@% ' specified color. Start with solid black (color 0):%@AE@%%@NL@% %@NL@% PaletteS%(0) = &HFFFF%@NL@% PaletteP$(0) = CHR$(0)%@NL@% %@NL@% FOR i% = 1 TO cPalLen%@NL@% %@NL@% %@AB@% ' The cycle number starts at one and is incremented each time%@AE@%%@NL@% %@AB@% ' the maximum number of colors for the current screen mode is reached:%@AE@%%@NL@% Cycle% = ((i% - 1) \ GP.MaxColor) + 1%@NL@% %@NL@% %@AB@% ' Set the style palette from the standard styles (which have%@AE@%%@NL@% %@AB@% ' previously been placed in the border palette):%@AE@%%@NL@% PaletteS%(i%) = PaletteB%(Cycle%)%@NL@% %@NL@% %@AB@% ' Get the default pattern and put it into the palette:%@AE@%%@NL@% SELECT CASE ScrnMode%@NL@% %@NL@% %@AB@% ' One bit plane modes:%@AE@%%@NL@% CASE 1, 2, 11, 13: RefPattern$ = GetPattern$(Bits, Cycle%)%@NL@% %@NL@% %@AB@% ' Multiple bit plane modes:%@AE@%%@NL@% CASE ELSE: RefPattern$ = GetPattern$(1, Cycle%)%@NL@% %@NL@% END SELECT%@NL@% PaletteP$(i%) = MakeChartPattern$(RefPattern$, PaletteC%(i%), 0)%@NL@% %@NL@% NEXT i%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clBuildPlaneP$ - Builds a pattern tile for multiple bit-plane screen modes%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Bits% = Number of planes in this screen mode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' C% = The color used to make the pattern%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' InP$ = Reference pattern%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Returns the specified pattern in specified color%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' PAINT tiles are different for screen modes that use 2 or more%@AE@%%@NL@% %@AB@%' bit-planes than for the modes that use only one (see remarks for%@AE@%%@NL@% %@AB@%' clBuildBitP$()). When bit-planes are used each pixel requires only%@AE@%%@NL@% %@AB@%' one bit per byte, but, there needs to be one byte for each bit-%@AE@%%@NL@% %@AB@%' plane. The process for building a pattern from a reference pattern%@AE@%%@NL@% %@AB@%' and color mask are logically the same as in the one bit-plane modes%@AE@%%@NL@% %@AB@%' the only difference is that a color mask requires several bytes%@AE@%%@NL@% %@AB@%' (one for each bit-plane) rather than one.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Example: Screen mode 9 with 2 bit planes; pattern with alternating%@AE@%%@NL@% %@AB@%' pixels on and off; color 2:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Reference pattern: 1 0 1 0 1 0 1 0%@AE@%%@NL@% %@AB@%' Color mask: 0 0 0 0 0 0 0 0 (plane 1)%@AE@%%@NL@% %@AB@%' 1 1 1 1 1 1 1 1 (plane 2)%@AE@%%@NL@% %@AB@%' -----------------%@AE@%%@NL@% %@AB@%' Result of "AND" 0 0 0 0 0 0 0 0 (plane 1)%@AE@%%@NL@% %@AB@%' 1 0 1 0 1 0 1 0 (plane 2)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION clBuildPlaneP$ (Bits%, C%, InP$)%@NL@% DIM CMask%(1 TO 4)%@NL@% %@NL@% %@AB@% ' First get color mask to match this color and pixel size (bits per pixel):%@AE@%%@NL@% clColorMaskH Bits%, C%, CMask%()%@NL@% %@NL@% %@AB@% ' Initialize the output pattern to empty then combine the color%@AE@%%@NL@% %@AB@% ' mask with each byte in the input tile using a logical "AND":%@AE@%%@NL@% OutP$ = ""%@NL@% FOR TileByte% = 1 TO LEN(InP$)%@NL@% RefTile% = ASC(MID$(InP$, TileByte%, 1))%@NL@% %@NL@% %@AB@% ' Combine each bit-plane in the color mask with the pattern byte:%@AE@%%@NL@% FOR Plane% = 1 TO Bits%%@NL@% OutP$ = OutP$ + CHR$(RefTile% AND CMask%(Plane%))%@NL@% NEXT Plane%%@NL@% NEXT TileByte%%@NL@% %@NL@% %@AB@% ' Return the completed pattern:%@AE@%%@NL@% clBuildPlaneP$ = OutP$%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== clChkChartWindow - Makes sure the chart window is valid%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Changes global parameters for chart window%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' This routine forces the chart window to be valid. If the input%@AE@%%@NL@% %@AB@%' values are invalid a full screen is chosen. The valid chart window%@AE@%%@NL@% %@AB@%' is stored in the global parameter set and used by other charting%@AE@%%@NL@% %@AB@%' routines. The last valid screen set by ChartScreen is used as%@AE@%%@NL@% %@AB@%' reference.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clChkChartWindow (Env AS ChartEnvironment)%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% %@AB@% ' Make sure X1 < X2:%@AE@%%@NL@% IF Env.ChartWindow.X1 < Env.ChartWindow.X2 THEN%@NL@% GP.CwX1 = Env.ChartWindow.X1%@NL@% GP.CwX2 = Env.ChartWindow.X2%@NL@% ELSE%@NL@% GP.CwX1 = Env.ChartWindow.X2%@NL@% GP.CwX2 = Env.ChartWindow.X1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Make sure Y1 < Y2:%@AE@%%@NL@% IF Env.ChartWindow.Y1 < Env.ChartWindow.Y2 THEN%@NL@% GP.CwY1 = Env.ChartWindow.Y1%@NL@% GP.CwY2 = Env.ChartWindow.Y2%@NL@% ELSE%@NL@% GP.CwY1 = Env.ChartWindow.Y2%@NL@% GP.CwY2 = Env.ChartWindow.Y1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If the X coordinates of the chart window are invalid,%@AE@%%@NL@% %@AB@% ' set them to full screen:%@AE@%%@NL@% IF GP.CwX1 < 0 OR GP.CwX2 >= GP.MaxXPix OR GP.CwX1 = GP.CwX2 THEN%@NL@% GP.CwX1 = 0%@NL@% GP.CwX2 = GP.MaxXPix - 1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If the Y coordinates of the chart window are invalid,%@AE@%%@NL@% %@AB@% ' set them to full screen:%@AE@%%@NL@% IF GP.CwY1 < 0 OR GP.CwY2 >= GP.MaxYPix OR GP.CwY1 = GP.CwY2 THEN%@NL@% GP.CwY1 = 0%@NL@% GP.CwY2 = GP.MaxYPix - 1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Set chart height and width for use later:%@AE@%%@NL@% GP.ChartWid = GP.CwX2 - GP.CwX1 + 1%@NL@% GP.ChartHgt = GP.CwY2 - GP.CwY1 + 1%@NL@% %@NL@% %@AB@% ' Put the valid coordinates in Env:%@AE@%%@NL@% Env.ChartWindow.X1 = GP.CwX1%@NL@% Env.ChartWindow.Y1 = GP.CwY1%@NL@% Env.ChartWindow.X2 = GP.CwX2%@NL@% Env.ChartWindow.Y2 = GP.CwY2%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clChkFonts - Checks that there is at least one loaded font%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Chart error set if no room for a font%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clChkFonts%@NL@% %@NL@% %@AB@% ' See if a font is loaded:%@AE@%%@NL@% GetTotalFonts Reg%, Load%%@NL@% %@NL@% %@AB@% ' If not then find out the maximum number of fonts allowed and if%@AE@%%@NL@% %@AB@% ' there's room, then load the default font:%@AE@%%@NL@% IF Load% <= 0 THEN%@NL@% GetMaxFonts MReg%, MLoad%%@NL@% IF Reg% < MReg% AND Load% < MLoad% THEN%@NL@% DefaultFont Segment%, Offset%%@NL@% FontNum% = RegisterMemFont(Segment%, Offset%)%@NL@% FontNum% = LoadFont("N" + STR$(Load% + 1))%@NL@% %@NL@% %@AB@% ' If there's no room, then set an error:%@AE@%%@NL@% ELSE%@NL@% clSetError cNoFontSpace%@NL@% END IF%@NL@% END IF%@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== CheckForErrors - Checks for and tries to fix a variety of errors%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' TypeMin% - Minimum allowable ChartType%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' TypeMax% - Maximum allowable ChartType%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - Number of data values per series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' First% - Column of data representing first series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Last% - Column of data representing last series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' This routine is the main one that checks for errors of input in%@AE@%%@NL@% %@AB@%' the ChartEnvironment variable and routine parameters.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clChkForErrors (Env AS ChartEnvironment, TypeMin%, TypeMax%, N%, First%, Last%)%@NL@% %@NL@% %@AB@% ' Clear any previous error:%@AE@%%@NL@% clClearError%@NL@% %@NL@% %@AB@% ' Check for correct chart type:%@AE@%%@NL@% IF Env.ChartType < TypeMin% OR Env.ChartType > TypeMax% THEN%@NL@% clSetError cBadType%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Check for valid chart style:%@AE@%%@NL@% IF Env.ChartStyle < 1 OR Env.ChartStyle > 2 THEN%@NL@% clSetError cBadStyle%@NL@% Env.ChartStyle = 1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' The following things are not relevant for pie charts:%@AE@%%@NL@% IF Env.ChartType <> cPie THEN%@NL@% %@NL@% %@AB@% ' Check LogBase for the X axis (default to 10):%@AE@%%@NL@% IF Env.XAxis.RangeType = cLog AND Env.XAxis.LogBase <= 0 THEN%@NL@% clSetError cBadLogBase%@NL@% Env.XAxis.LogBase = 10%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Check LogBase for the Y axis (default to 10):%@AE@%%@NL@% IF Env.YAxis.RangeType = cLog AND Env.YAxis.LogBase <= 0 THEN%@NL@% clSetError cBadLogBase%@NL@% Env.YAxis.LogBase = 10%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Check X axis ScaleFactor:%@AE@%%@NL@% IF Env.XAxis.AutoScale <> cYes AND Env.XAxis.ScaleFactor = 0 THEN%@NL@% clSetError cBadScaleFactor%@NL@% Env.XAxis.ScaleFactor = 1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Check Y axis ScaleFactor:%@AE@%%@NL@% IF Env.YAxis.AutoScale <> cYes AND Env.YAxis.ScaleFactor = 0 THEN%@NL@% clSetError cBadScaleFactor%@NL@% Env.YAxis.ScaleFactor = 1%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Make sure N > 0:%@AE@%%@NL@% IF N% <= 0 THEN%@NL@% clSetError cTooSmallN%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Check that First series <= Last one:%@AE@%%@NL@% IF First% > Last% THEN%@NL@% clSetError cTooFewSeries%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Force ChartWindow to be valid:%@AE@%%@NL@% clChkChartWindow Env%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clChkInit - Check that chartlib has been initialized%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clChkInit%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% IF NOT GP.Initialized THEN clInitChart%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clChkPalettes - Makes sure that palettes are dimensioned correctly%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' C%() - Color palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' S%() - Style palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' P$() - Pattern palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Char%() - Plot character palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' B%() - Border pattern palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Chart error may be set to cBadPalette%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clChkPalettes (C() AS INTEGER, s() AS INTEGER, P$(), Char() AS INTEGER, B() AS INTEGER)%@NL@% %@NL@% %@AB@% ' Check each palette array to be sure it is dimensioned from 0%@AE@%%@NL@% %@AB@% ' to cPalLen:%@AE@%%@NL@% FOR i% = 1 TO 5%@NL@% SELECT CASE i%%@NL@% CASE 1: L% = LBOUND(C, 1): U% = UBOUND(C, 1)%@NL@% CASE 2: L% = LBOUND(s, 1): U% = UBOUND(s, 1)%@NL@% CASE 3: L% = LBOUND(P$, 1): U% = UBOUND(P$, 1)%@NL@% CASE 4: L% = LBOUND(Char, 1): U% = UBOUND(Char, 1)%@NL@% CASE 5: L% = LBOUND(B, 1): U% = UBOUND(B, 1)%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' If incorrectly dimensioned then set error:%@AE@%%@NL@% IF (L% <> 0) OR (U% <> cPalLen) THEN%@NL@% clSetError cBadPalette%@NL@% EXIT SUB%@NL@% END IF%@NL@% NEXT i%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clClearError - Clears ChartErr, the ChartLib error variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Sets ChartErr to 0%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clClearError%@NL@% %@NL@% ChartErr = 0%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clColorMaskH% - Function to generate a byte with each pixel set to%@AE@%%@NL@% %@AB@%' some color - for high-res modes (7,8,9,10)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Bits% - Number of bits per pixel in current screen mode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Colr% - Color to make the mask%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' CMask%() - One dimensional array to place mask values in%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Screen modes 7, 8, 9 and 10 use bit planes. Rather than using%@AE@%%@NL@% %@AB@%' adjacent bits in one byte to determine a color, they use bits%@AE@%%@NL@% %@AB@%' "stacked" on top of each other in different bytes. This routine%@AE@%%@NL@% %@AB@%' generates one byte of a particular color by setting the different%@AE@%%@NL@% %@AB@%' levels of the stack to &H00 and &HFF to represent eight pixels%@AE@%%@NL@% %@AB@%' of a particular color.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clColorMaskH (Bits%, Colr%, CMask%())%@NL@% %@NL@% %@AB@% ' Copy the color to a local variable:%@AE@%%@NL@% RefColor% = Colr%%@NL@% %@NL@% %@AB@% ' Bits% is the number of bit planes, set a mask for each one:%@AE@%%@NL@% FOR i% = 1 TO Bits%%@NL@% %@NL@% %@AB@% ' Check rightmost bit in color, if it is set to 1 then this plane is%@AE@%%@NL@% %@AB@% ' "on" (it equals &HFF):%@AE@%%@NL@% IF RefColor% MOD 2 <> 0 THEN%@NL@% CMask%(i%) = &HFF%@NL@% %@NL@% %@AB@% ' If the bit is 0, the plane is off (it equals &H0):%@AE@%%@NL@% ELSE%@NL@% CMask%(i%) = &H0%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Shift the reference color right by one bit:%@AE@%%@NL@% RefColor% = RefColor% \ 2%@NL@% NEXT i%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clColorMaskL% - Function to generate a byte with each pixel set to%@AE@%%@NL@% %@AB@%' some color.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Bits% - Number of bits per pixel in current screen mode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Colr% - Color to make the mask%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Returns integer with low byte that contains definitions for%@AE@%%@NL@% %@AB@%' pixels of specified color.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION clColorMaskL% (Bits%, Colr%)%@NL@% %@NL@% %@AB@% ' Initialize the mask to zero:%@AE@%%@NL@% M% = 0%@NL@% %@NL@% %@AB@% ' Multiplying a number by (2 ^ Bits%) will shift it left by "Bits%" bits:%@AE@%%@NL@% LShift% = 2 ^ Bits%%@NL@% %@NL@% %@AB@% ' Create a byte in which each pixel (of "Bits%" bits) is set to%@AE@%%@NL@% %@AB@% ' Colr%. This is done by setting the mask to "Colr%" then shifting%@AE@%%@NL@% %@AB@% ' it left by "Bits%" and repeating until the byte is full:%@AE@%%@NL@% FOR i% = 0 TO 7 \ Bits%%@NL@% M% = M% * LShift% + Colr%%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' Return the mask as the value of the function:%@AE@%%@NL@% clColorMaskL% = M% MOD 256%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== clDrawAxes - Draws the axes for a chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Cat$(1) - One-dimensional array or category names for use in%@AE@%%@NL@% %@AB@%' labeling the category axis (ignored if category%@AE@%%@NL@% %@AB@%' axis not used)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' No return values%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clDrawAxes (Cat$())%@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED GFI AS FontInfo%@NL@% SHARED PaletteC%(), PaletteB%()%@NL@% %@NL@% %@AB@% ' Use temporary variables to refer to axis limits:%@AE@%%@NL@% X1 = GE.XAxis.ScaleMin%@NL@% X2 = GE.XAxis.ScaleMax%@NL@% Y1 = GE.YAxis.ScaleMin%@NL@% Y2 = GE.YAxis.ScaleMax%@NL@% %@NL@% %@AB@% ' To draw the tic/grid lines it is necessary to know where the line%@AE@%%@NL@% %@AB@% ' starts and ends. If tic marks are specified (by setting%@AE@%%@NL@% %@AB@% ' the "labeled" flag in the axis definition) then the%@AE@%%@NL@% %@AB@% ' tic lines start "ticwidth" below or to the left of the X and%@AE@%%@NL@% %@AB@% ' Y axis respectively. If grid lines are specified then the%@AE@%%@NL@% %@AB@% ' tic/grid line ends at ScaleMax for the respective axis. The%@AE@%%@NL@% %@AB@% ' case statements below calculate where the tic/grid lines start%@AE@%%@NL@% %@AB@% ' based on the above criteria.%@AE@%%@NL@% %@NL@% %@AB@% ' Check for tic marks first (X Axis):%@AE@%%@NL@% SELECT CASE GE.XAxis.Labeled%@NL@% CASE cNo: XTicMinY = Y1%@NL@% CASE ELSE%@NL@% XTicMinY = Y1 - cTicSize * (Y2 - Y1)%@NL@% IF GP.XStagger = cYes THEN%@NL@% clSetChartFont GE.XAxis.TicFont%@NL@% XTicDropY = GFI.PixHeight * (Y2 - Y1) / (GE.DataWindow.Y2 - GE.DataWindow.Y1)%@NL@% ELSE%@NL@% XTicDropY = 0%@NL@% END IF%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' (Y Axis):%@AE@%%@NL@% SELECT CASE GE.YAxis.Labeled%@NL@% CASE cNo: YTicMinX = X1%@NL@% CASE ELSE: YTicMinX = X1 - cTicSize * (X2 - X1)%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Now for the other end of the tic/grid lines check for%@AE@%%@NL@% %@AB@% ' the grid flag (X axis):%@AE@%%@NL@% SELECT CASE GE.XAxis.grid%@NL@% CASE cNo: XTicMaxY = Y1%@NL@% CASE ELSE: XTicMaxY = Y2%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' (Y Axis):%@AE@%%@NL@% SELECT CASE GE.YAxis.grid%@NL@% CASE cNo: YTicMaxX = X1%@NL@% CASE ELSE: YTicMaxX = X2%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Now that the beginning and end of the tic/grid lines has been%@AE@%%@NL@% %@AB@% ' calculated, it is necessary to figure out where they fall along the%@AE@%%@NL@% %@AB@% ' axes. This depends on the type of axis: category or value. On a%@AE@%%@NL@% %@AB@% ' category axis the tic/grid lines should fall in the middle of each%@AE@%%@NL@% %@AB@% ' bar set. This is calculated by adding 1/2 of TicInterval to%@AE@%%@NL@% %@AB@% ' the beginning of the axis. On a value axis the tic/grid line%@AE@%%@NL@% %@AB@% ' falls at the beginning of the axis. It is also necessary to know%@AE@%%@NL@% %@AB@% ' the total number of tics per axis. The following CASE statements%@AE@%%@NL@% %@AB@% ' calculate this. Once the first tic/grid location on an axis is%@AE@%%@NL@% %@AB@% ' calculated the others can be calculated as they are drawn by adding%@AE@%%@NL@% %@AB@% ' TicInterval each time to the position of the previous tic mark:%@AE@%%@NL@% %@NL@% %@AB@% ' Location of the first (leftmost) tic/grid line on the X axis:%@AE@%%@NL@% TicTotX% = CINT((X2 - X1) / GE.XAxis.TicInterval)%@NL@% SELECT CASE GP.XMode%@NL@% CASE cCategory: TicX = X1 + GE.XAxis.TicInterval / 2%@NL@% CASE ELSE%@NL@% TicX = X1%@NL@% TicTotX% = TicTotX% + 1%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Location of the first (top) tic/grid line on the Y axis:%@AE@%%@NL@% TicTotY% = CINT((Y2 - Y1) / GE.YAxis.TicInterval)%@NL@% SELECT CASE GP.YMode%@NL@% CASE cCategory: TicY = Y1 + GE.YAxis.TicInterval / 2%@NL@% CASE ELSE%@NL@% TicY = Y1%@NL@% TicTotY% = TicTotY% + 1%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Now it's time to draw the axes; first the X then the Y axis.%@AE@%%@NL@% %@AB@% ' There's a small complexity that has to be dealt with first, though.%@AE@%%@NL@% %@AB@% ' The tic/grid lines are specified in "world" coordinates since that%@AE@%%@NL@% %@AB@% ' is easier to calculate but the current VIEW (the DataWindow) would%@AE@%%@NL@% %@AB@% ' clip them since tic marks (and also labels) lie outside of that%@AE@%%@NL@% %@AB@% ' region. The solution is to extrapolate the DataWindow "world" to the%@AE@%%@NL@% %@AB@% ' ChartWindow region and set our VIEW to the ChartWindow. This will%@AE@%%@NL@% %@AB@% ' clip labels if they are too long and try to go outside the Chart%@AE@%%@NL@% %@AB@% ' Window but still allow use of world coordinates for specifying%@AE@%%@NL@% %@AB@% ' locations. To extrapolate the world coordinates to the ChartWindow,%@AE@%%@NL@% %@AB@% ' PMAP can be used. This works since PMAP can take pixel coordinates%@AE@%%@NL@% %@AB@% ' outside of the current VIEW and map them to the appropriate world%@AE@%%@NL@% %@AB@% ' coordinates. The DataWindow coordinates (calculated in the routine%@AE@%%@NL@% %@AB@% ' clSizeDataWindow) are expressed relative to the ChartWindow so%@AE@%%@NL@% %@AB@% ' it can be somewhat complicated trying to understand what to use with%@AE@%%@NL@% %@AB@% ' PMAP. If you draw a picture of it things will appear more straight%@AE@%%@NL@% %@AB@% ' forward.%@AE@%%@NL@% %@NL@% %@AB@% ' To make sure that bars and columns aren't drawn over the axis lines%@AE@%%@NL@% %@AB@% ' temporarily move the left DataWindow border left by one and the bottom%@AE@%%@NL@% %@AB@% ' border down by one pixel:%@AE@%%@NL@% GE.DataWindow.X1 = GE.DataWindow.X1 - 1%@NL@% GE.DataWindow.Y2 = GE.DataWindow.Y2 + 1%@NL@% %@NL@% %@AB@% ' Select the DataWindow view and assign the "world" to it:%@AE@%%@NL@% clSelectRelWindow GE.DataWindow%@NL@% WINDOW (X1, Y1)-(X2, Y2)%@NL@% GTextWindow X1, Y1, X2, Y2, cFalse%@NL@% %@NL@% %@AB@% ' Next, use PMAP to extrapolate to ChartWindow:%@AE@%%@NL@% WorldX1 = PMAP(-GE.DataWindow.X1, 2)%@NL@% WorldX2 = PMAP(GP.ChartWid - 1 - GE.DataWindow.X1, 2)%@NL@% %@NL@% WorldY1 = PMAP(GP.ChartHgt - 1 - GE.DataWindow.Y1, 3)%@NL@% WorldY2 = PMAP(-GE.DataWindow.Y1, 3)%@NL@% %@NL@% %@AB@% ' Reset the DataWindow borders back to their original settings:%@AE@%%@NL@% GE.DataWindow.X1 = GE.DataWindow.X1 + 1%@NL@% GE.DataWindow.Y2 = GE.DataWindow.Y2 - 1%@NL@% %@NL@% %@AB@% ' Finally, select the ChartWindow VIEW and apply the extrapolated%@AE@%%@NL@% %@AB@% ' window to it:%@AE@%%@NL@% clSelectChartWindow%@NL@% WINDOW (WorldX1, WorldY1)-(WorldX2, WorldY2)%@NL@% GTextWindow WorldX1, WorldY1, WorldX2, WorldY2, cFalse%@NL@% %@NL@% %@AB@% ' Draw the X and Y axes (one pixel to left and bottom of window):%@AE@%%@NL@% CX% = PaletteC%(clMap2Pal%(GE.XAxis.AxisColor)) ' Color of X axis%@NL@% CY% = PaletteC%(clMap2Pal%(GE.YAxis.AxisColor)) ' Color of Y axis%@NL@% %@NL@% SX% = PaletteB%(clMap2Pal%(GE.XAxis.GridStyle)) ' Line styles; X grid%@NL@% SY% = PaletteB%(clMap2Pal%(GE.YAxis.GridStyle)) ' Line styles; Y grid%@NL@% %@NL@% LINE (X1, Y1)-(X2, Y1), CX%%@NL@% LINE (X1, Y1)-(X1, Y2), CY%%@NL@% %@NL@% %@AB@% ' X-Axis...Draw styled grid line then solid tic mark:%@AE@%%@NL@% TicLoc = TicX%@NL@% Stagger% = cFalse%@NL@% FOR i% = 1 TO TicTotX%%@NL@% LINE (TicLoc, Y1)-(TicLoc, XTicMaxY), CY%, , SX%%@NL@% IF Stagger% THEN%@NL@% LINE (TicLoc, XTicMinY - XTicDropY)-(TicLoc, Y1), CX%%@NL@% Stagger% = cFalse%@NL@% ELSE%@NL@% LINE (TicLoc, XTicMinY)-(TicLoc, Y1), CX%%@NL@% Stagger% = cTrue%@NL@% END IF%@NL@% TicLoc = TicLoc + GE.XAxis.TicInterval%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' Y-Axis...Draw styled grid line then solid tic mark:%@AE@%%@NL@% TicLoc = TicY%@NL@% FOR i% = 1 TO TicTotY%%@NL@% LINE (X1, TicLoc)-(YTicMaxX, TicLoc), CX%, , SY%%@NL@% LINE (YTicMinX, TicLoc)-(X1, TicLoc), CY%%@NL@% TicLoc = TicLoc + GE.YAxis.TicInterval%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' Label X tic marks and print titles:%@AE@%%@NL@% clLabelXTics GE.XAxis, Cat$(), TicX, TicTotX%, XTicMinY, YBoundry%%@NL@% clTitleXAxis GE.XAxis, GE.DataWindow.X1, GE.DataWindow.X2, YBoundry%%@NL@% %@NL@% %@AB@% ' Label Y tic marks and print titles:%@AE@%%@NL@% clLabelYTics GE.YAxis, Cat$(), YTicMinX, TicY, TicTotY%%@NL@% clTitleYAxis GE.YAxis, GE.DataWindow.Y1, GE.DataWindow.Y2%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clDrawBarData - Draws data portion of multi-series bar chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clDrawBarData%@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED PaletteC%()%@NL@% SHARED V1()%@NL@% %@NL@% %@AB@% ' Set the VIEW to the DataWindow:%@AE@%%@NL@% clSelectRelWindow GE.DataWindow%@NL@% %@NL@% %@AB@% ' Set the WINDOW to match:%@AE@%%@NL@% WINDOW (GE.XAxis.ScaleMin, GE.YAxis.ScaleMin)-(GE.XAxis.ScaleMax, GE.YAxis.ScaleMax)%@NL@% GTextWindow GE.XAxis.ScaleMin, GE.YAxis.ScaleMin, GE.XAxis.ScaleMax, GE.YAxis.ScaleMax, cFalse%@NL@% %@NL@% %@AB@% ' If this is a linear axis then determine where the bars should grow from:%@AE@%%@NL@% IF GE.XAxis.RangeType = cLinear THEN%@NL@% %@NL@% %@AB@% ' If the scale minimum and maximum are on opposite sides of zero%@AE@%%@NL@% %@AB@% ' set the bar starting point to zero:%@AE@%%@NL@% IF GE.XAxis.ScaleMin < 0 AND GE.XAxis.ScaleMax > 0 THEN%@NL@% BarMin = 0%@NL@% %@NL@% %@AB@% ' If the axis range is all negative the the bars should grow from%@AE@%%@NL@% %@AB@% ' the right to the left so make the bar starting point the scale%@AE@%%@NL@% %@AB@% ' maximum:%@AE@%%@NL@% ELSEIF GE.XAxis.ScaleMin < 0 THEN%@NL@% BarMin = GE.XAxis.ScaleMax%@NL@% %@NL@% %@AB@% ' The axis range is all positive so the bar starting point is the%@AE@%%@NL@% %@AB@% ' scale minimum:%@AE@%%@NL@% ELSE%@NL@% BarMin = GE.XAxis.ScaleMin%@NL@% END IF%@NL@% %@NL@% %@AB@% ' The bar starting point for log axes should always be the scale minimum%@AE@%%@NL@% %@AB@% ' since only positive numbers are represented on a log axis (even though%@AE@%%@NL@% %@AB@% ' the log of small numbers is negative):%@AE@%%@NL@% ELSE%@NL@% BarMin = GE.XAxis.ScaleMin%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Calculate the width of a bar. Divide by the number of%@AE@%%@NL@% %@AB@% ' series if it's a plain (not stacked) chart:%@AE@%%@NL@% BarWid = GE.YAxis.TicInterval * cBarWid%@NL@% IF GE.ChartStyle = cPlain THEN BarWid = BarWid / GP.NSeries%@NL@% %@NL@% %@AB@% ' Calculate the beginning Y value of first bar then loop drawing%@AE@%%@NL@% %@AB@% ' all the bars:%@AE@%%@NL@% SpaceWid = GE.YAxis.TicInterval * (1 - cBarWid)%@NL@% StartLoc = GE.YAxis.ScaleMax - SpaceWid / 2%@NL@% %@NL@% FOR i% = 1 TO GP.NVals%@NL@% %@NL@% %@AB@% ' Reset sum variables for positive and negative stacked bars:%@AE@%%@NL@% RSumPos = 0%@NL@% RSumNeg = 0%@NL@% %@NL@% %@AB@% ' Reset the bar starting points:%@AE@%%@NL@% BarStartPos = BarMin%@NL@% BarStartNeg = BarMin%@NL@% %@NL@% %@AB@% ' Reset starting Y location of this bar set:%@AE@%%@NL@% BarLoc = StartLoc%@NL@% %@NL@% %@AB@% ' Now, chart the different series for this category:%@AE@%%@NL@% FOR J% = 1 TO GP.NSeries%@NL@% %@NL@% %@AB@% ' Get the value to chart from the data array:%@AE@%%@NL@% V = V1(i%, J%)%@NL@% %@NL@% %@AB@% ' If the value isn't a missing one then try to chart it:%@AE@%%@NL@% IF V <> cMissingValue THEN%@NL@% %@NL@% %@AB@% ' If the X-axis has the AutoScale flag set then divide%@AE@%%@NL@% %@AB@% ' the value by the axis' ScaleFactor variable:%@AE@%%@NL@% IF GE.XAxis.AutoScale = cYes THEN V = V / GE.XAxis.ScaleFactor%@NL@% %@NL@% %@AB@% ' If this is a plain chart then calculate the bar's location%@AE@%%@NL@% %@AB@% ' and draw it:%@AE@%%@NL@% IF GE.ChartStyle = cPlain THEN%@NL@% %@NL@% BarLoc = StartLoc - (J% - 1) * BarWid%@NL@% clRenderBar BarMin, BarLoc, V, BarLoc - BarWid, J%%@NL@% %@NL@% %@AB@% ' If the bars should be stacked then draw either a positive or%@AE@%%@NL@% %@AB@% ' negative portion of a bar depending on whether the data value%@AE@%%@NL@% %@AB@% ' is positive or negative:%@AE@%%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' If the value is positive:%@AE@%%@NL@% IF V > 0 THEN%@NL@% %@NL@% %@AB@% ' Add the value to the current sum for the bar and draw%@AE@%%@NL@% %@AB@% ' the bar from the top of the last portion:%@AE@%%@NL@% RSumPos = RSumPos + V%@NL@% clRenderBar BarStartPos, BarLoc, RSumPos, BarLoc - BarWid, J%%@NL@% BarStartPos = RSumPos%@NL@% %@NL@% %@AB@% ' If the value is negative:%@AE@%%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' Add the value to the current sum for the bar and draw%@AE@%%@NL@% %@AB@% ' the bar from the bottom of the last portion:%@AE@%%@NL@% RSumNeg = RSumNeg + V%@NL@% clRenderBar BarStartNeg, BarLoc, RSumNeg, BarLoc - BarWid, J%%@NL@% BarStartNeg = RSumNeg%@NL@% %@NL@% END IF%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% NEXT J%%@NL@% %@NL@% %@AB@% ' Update the bar cluster's starting location:%@AE@%%@NL@% StartLoc = StartLoc - GE.YAxis.TicInterval%@NL@% %@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' If BarMin isn't the axis minimum then draw a reference line:%@AE@%%@NL@% IF BarMin <> GE.XAxis.ScaleMin THEN%@NL@% LINE (BarMin, GE.YAxis.ScaleMin)-(BarMin, GE.YAxis.ScaleMax), PaletteC%(clMap2Pal%(GE.YAxis.AxisColor))%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clDrawChartWindow - Draws the Chart window%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' This routine erases any previous viewport%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clDrawChartWindow%@NL@% SHARED GE AS ChartEnvironment%@NL@% %@NL@% %@AB@% ' Define viewport then render window:%@AE@%%@NL@% clSelectChartWindow%@NL@% clRenderWindow GE.ChartWindow%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clDrawColumnData - Draws data portion of MS Column chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clDrawColumnData%@NL@% SHARED GP AS GlobalParams, GE AS ChartEnvironment%@NL@% SHARED PaletteC%(), V1()%@NL@% %@NL@% %@AB@% ' First, set the VIEW to DataWindow:%@AE@%%@NL@% clSelectRelWindow GE.DataWindow%@NL@% %@NL@% %@AB@% ' Set the WINDOW to match:%@AE@%%@NL@% WINDOW (GE.XAxis.ScaleMin, GE.YAxis.ScaleMin)-(GE.XAxis.ScaleMax, GE.YAxis.ScaleMax)%@NL@% GTextWindow GE.XAxis.ScaleMin, GE.YAxis.ScaleMin, GE.XAxis.ScaleMax, GE.YAxis.ScaleMax, cFalse%@NL@% %@NL@% %@AB@% ' If this is a linear axis then determine where the bars should grow from:%@AE@%%@NL@% IF GE.YAxis.RangeType = cLinear THEN%@NL@% %@NL@% %@AB@% ' Draw 0 reference line if the scale minimum and maximum are on%@AE@%%@NL@% %@AB@% ' opposite sides of zero. Also set the bar starting point to zero%@AE@%%@NL@% %@AB@% ' so that bars grow from the zero line:%@AE@%%@NL@% IF GE.YAxis.ScaleMin < 0 AND GE.YAxis.ScaleMax > 0 THEN%@NL@% BarMin = 0%@NL@% %@NL@% %@AB@% ' If the axis range is all negative the the bars should grow from%@AE@%%@NL@% %@AB@% ' the right to the left so make the bar starting point the scale%@AE@%%@NL@% %@AB@% ' maximum:%@AE@%%@NL@% ELSEIF GE.YAxis.ScaleMin < 0 THEN%@NL@% BarMin = GE.YAxis.ScaleMax%@NL@% %@NL@% %@AB@% ' The axis range is all positive so the bar starting point is the%@AE@%%@NL@% %@AB@% ' scale minimum:%@AE@%%@NL@% ELSE%@NL@% BarMin = GE.YAxis.ScaleMin%@NL@% END IF%@NL@% %@NL@% %@AB@% ' The bar starting point for log axes should always be the scale minimum%@AE@%%@NL@% %@AB@% ' since only positive numbers are represented on a log axis (even though%@AE@%%@NL@% %@AB@% ' the log of small numbers is negative):%@AE@%%@NL@% ELSE%@NL@% BarMin = GE.YAxis.ScaleMin%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Calculate the width of a bar. Divide by the number of%@AE@%%@NL@% %@AB@% ' series if it's a plain (not stacked) chart:%@AE@%%@NL@% BarWid = GE.XAxis.TicInterval * cBarWid%@NL@% IF GE.ChartStyle = cPlain THEN BarWid = BarWid / GP.NSeries%@NL@% %@NL@% %@AB@% ' calculate the beginning X value of first bar and loop, drawing all%@AE@%%@NL@% %@AB@% ' the bars:%@AE@%%@NL@% SpaceWid = GE.XAxis.TicInterval * (1 - cBarWid)%@NL@% StartLoc = GE.XAxis.ScaleMin + SpaceWid / 2%@NL@% %@NL@% FOR i% = 1 TO GP.NVals%@NL@% %@NL@% %@AB@% ' Reset sum variables for positive and negative stacked bars:%@AE@%%@NL@% RSumPos = 0%@NL@% RSumNeg = 0%@NL@% %@NL@% BarStartPos = BarMin%@NL@% BarStartNeg = BarMin%@NL@% %@NL@% %@AB@% ' Reset starting Y location of this bar set:%@AE@%%@NL@% BarLoc = StartLoc%@NL@% %@NL@% %@AB@% ' Now, go across the rows charting the different series for%@AE@%%@NL@% %@AB@% ' this category:%@AE@%%@NL@% FOR J% = 1 TO GP.NSeries%@NL@% %@NL@% %@AB@% ' Get the value to chart from the data array:%@AE@%%@NL@% V = V1(i%, J%)%@NL@% %@NL@% %@AB@% ' If the value isn't a missing one then try to chart it:%@AE@%%@NL@% IF V <> cMissingValue THEN%@NL@% %@NL@% %@AB@% ' If the Y-axis has the AutoScale flag set then divide%@AE@%%@NL@% %@AB@% ' the value by the axis' ScaleFactor variable:%@AE@%%@NL@% IF GE.YAxis.AutoScale = cYes THEN V = V / GE.YAxis.ScaleFactor%@NL@% %@NL@% %@AB@% ' If this is a plain chart then calculate the bar's location%@AE@%%@NL@% %@AB@% ' and draw it:%@AE@%%@NL@% IF GE.ChartStyle = cPlain THEN%@NL@% %@NL@% BarLoc = StartLoc + (J% - 1) * BarWid%@NL@% clRenderBar BarLoc, BarMin, BarLoc + BarWid, V, J%%@NL@% %@NL@% %@AB@% ' If the bars should be stacked then draw either a positive or%@AE@%%@NL@% %@AB@% ' negative portion of a bar depending on whether the data value%@AE@%%@NL@% %@AB@% ' is positive or negative:%@AE@%%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' If the value is positive:%@AE@%%@NL@% IF V > 0 THEN%@NL@% %@NL@% %@AB@% ' Add the value to the current sum for the bar and draw%@AE@%%@NL@% %@AB@% ' the bar from the top of the last portion:%@AE@%%@NL@% RSumPos = RSumPos + V%@NL@% clRenderBar BarLoc, BarStartPos, BarLoc + BarWid, RSumPos, J%%@NL@% BarStartPos = RSumPos%@NL@% %@NL@% %@AB@% ' If the value is negative:%@AE@%%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' Add the value to the current sum for the bar and draw%@AE@%%@NL@% %@AB@% ' the bar from the bottom of the last portion:%@AE@%%@NL@% RSumNeg = RSumNeg + V%@NL@% clRenderBar BarLoc, BarStartNeg, BarLoc + BarWid, RSumNeg, J%%@NL@% BarStartNeg = RSumNeg%@NL@% %@NL@% END IF%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% NEXT J%%@NL@% %@NL@% %@AB@% ' Update the bar cluster's starting location:%@AE@%%@NL@% StartLoc = StartLoc + GE.XAxis.TicInterval%@NL@% %@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' If BarMin isn't the axis minimum then draw a reference line:%@AE@%%@NL@% IF BarMin <> GE.YAxis.ScaleMin THEN%@NL@% LINE (GE.XAxis.ScaleMin, BarMin)-(GE.XAxis.ScaleMax, BarMin), PaletteC%(clMap2Pal%(GE.XAxis.AxisColor))%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clDrawDataWindow - Draws the Data window%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' This routine erases any previous viewport or window specification.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clDrawDataWindow%@NL@% SHARED GE AS ChartEnvironment%@NL@% %@NL@% %@AB@% ' Define viewport then render window:%@AE@%%@NL@% clSelectRelWindow GE.DataWindow%@NL@% clRenderWindow GE.DataWindow%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clDrawLegend - Draws a legend%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' SeriesLabel$(1) - Array of labels for the legend%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' First% - Label number corresponding to first series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Last% - Label number corresponding to last series%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clDrawLegend (SeriesLabel$(), First AS INTEGER, Last AS INTEGER)%@NL@% %@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED PaletteC%(), PaletteP$(), PaletteCh%()%@NL@% SHARED GFI AS FontInfo%@NL@% SHARED LLayout AS LegendLayout%@NL@% %@NL@% %@AB@% ' If legend flag is No then exit:%@AE@%%@NL@% IF GE.Legend.Legend = cNo THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Select and render the legend window:%@AE@%%@NL@% clSelectRelWindow GE.Legend.LegendWindow%@NL@% clRenderWindow GE.Legend.LegendWindow%@NL@% WINDOW%@NL@% GTextWindow 0, 0, 0, 0, cFalse%@NL@% %@NL@% %@AB@% ' Start with the first label, set the Y position of the first line%@AE@%%@NL@% %@AB@% ' of labels and loop through all the rows in the legend:%@AE@%%@NL@% clSetChartFont GE.Legend.TextFont%@NL@% LabelNum% = First%@NL@% YPos% = LLayout.HorizBorder%@NL@% FOR i% = 1 TO LLayout.NumRow%@NL@% %@NL@% %@AB@% ' Set position of beginning of row:%@AE@%%@NL@% XPos% = LLayout.VertBorder%@NL@% %@NL@% FOR J% = 1 TO LLayout.NumCol%@NL@% %@NL@% %@AB@% ' Map the label number to a valid palette reference:%@AE@%%@NL@% MJ% = clMap2Pal%(LabelNum% - First + 1)%@NL@% %@NL@% %@AB@% ' Depending on ChartType draw either a filled box or the%@AE@%%@NL@% %@AB@% ' plot character used for plotting:%@AE@%%@NL@% XStep% = LLayout.SymbolSize / GP.Aspect%@NL@% SELECT CASE GE.ChartType%@NL@% %@NL@% CASE cBar, cColumn, cPie:%@NL@% LINE (XPos%, YPos%)-STEP(XStep%, LLayout.SymbolSize), 0, BF%@NL@% LINE (XPos%, YPos%)-STEP(XStep%, LLayout.SymbolSize), 1, B%@NL@% PAINT (XPos% + 1, YPos% + 1), PaletteP$(MJ%), 1%@NL@% LINE (XPos%, YPos%)-STEP(XStep%, LLayout.SymbolSize), PaletteC%(MJ%), B%@NL@% %@NL@% CASE cLine, cScatter:%@NL@% clSetCharColor MJ%%@NL@% PlotChr$ = CHR$(PaletteCh%(MJ%))%@NL@% clHPrint XPos% + XStep% - GFI.AvgWidth, YPos% - GFI.Leading, PlotChr$%@NL@% %@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Print the label for this entry in the legend:%@AE@%%@NL@% clSetCharColor GE.Legend.TextColor%@NL@% clHPrint XPos% + LLayout.LabelOffset, YPos% - GFI.Leading, SeriesLabel$(LabelNum%)%@NL@% %@NL@% %@AB@% ' Increment the label count and check count has finished:%@AE@%%@NL@% LabelNum% = LabelNum% + 1%@NL@% IF LabelNum% > Last THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Move over to the next column:%@AE@%%@NL@% XPos% = XPos% + LLayout.ColSpacing%@NL@% %@NL@% NEXT J%%@NL@% %@NL@% %@AB@% ' Move position to the next row:%@AE@%%@NL@% YPos% = YPos% + LLayout.RowSpacing%@NL@% %@NL@% NEXT i%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clDrawLineData - Draws data portion line chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clDrawLineData%@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED PaletteC%(), PaletteS%(), PaletteCh%()%@NL@% SHARED GFI AS FontInfo%@NL@% SHARED V1()%@NL@% %@NL@% %@AB@% ' First, set the appropriate font and make text horizontal:%@AE@%%@NL@% clSetChartFont GE.DataFont%@NL@% SetGTextDir 0%@NL@% %@NL@% %@AB@% ' Then, set the view to DataWindow:%@AE@%%@NL@% clSelectRelWindow GE.DataWindow%@NL@% %@NL@% %@AB@% ' Set the window to match:%@AE@%%@NL@% WINDOW (GE.XAxis.ScaleMin, GE.YAxis.ScaleMin)-(GE.XAxis.ScaleMax, GE.YAxis.ScaleMax)%@NL@% GTextWindow GE.XAxis.ScaleMin, GE.YAxis.ScaleMin, GE.XAxis.ScaleMax, GE.YAxis.ScaleMax, cFalse%@NL@% %@NL@% %@AB@% ' Loop through the series:%@AE@%%@NL@% FOR J% = 1 TO GP.NSeries%@NL@% %@NL@% %@AB@% ' Map the series number into a valid palette reference:%@AE@%%@NL@% MJ% = clMap2Pal%(J%)%@NL@% %@NL@% %@AB@% ' Calculate starting X location of first point and set%@AE@%%@NL@% %@AB@% ' last value to missing (since this is the first value in the%@AE@%%@NL@% %@AB@% ' series the last value wasn't there):%@AE@%%@NL@% StartLoc = GE.XAxis.ScaleMin + GE.XAxis.TicInterval / 2%@NL@% LastMissing% = cYes%@NL@% %@NL@% FOR i% = 1 TO GP.NVals%@NL@% %@NL@% %@AB@% ' Get a value from the data array:%@AE@%%@NL@% V = V1(i%, J%)%@NL@% %@NL@% %@AB@% ' If the value is missing, set the LastMissing flag to Yes and%@AE@%%@NL@% %@AB@% ' go to the next value:%@AE@%%@NL@% IF V = cMissingValue THEN%@NL@% LastMissing% = cYes%@NL@% %@NL@% %@AB@% ' If the value is not missing then try to chart it:%@AE@%%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' Scale the value (and convert it to a log if this is a%@AE@%%@NL@% %@AB@% ' Log axis):%@AE@%%@NL@% IF GE.YAxis.AutoScale = cYes THEN V = V / GE.YAxis.ScaleFactor%@NL@% %@NL@% %@AB@% ' If the style dictates lines and the last point wasn't%@AE@%%@NL@% %@AB@% ' missing then draw a line between the last point and this one:%@AE@%%@NL@% IF GE.ChartStyle = cLines AND LastMissing% <> cYes THEN%@NL@% LINE -(StartLoc, V), PaletteC%(MJ%), , PaletteS%(MJ%)%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Position and print character:%@AE@%%@NL@% CX% = PMAP(StartLoc, 0) - GetGTextLen(CHR$(PaletteCh%(MJ%))) / 2%@NL@% CY% = PMAP(V, 1) - GFI.Ascent / 2%@NL@% clSetCharColor MJ%%@NL@% clHPrint CX%, CY%, CHR$(PaletteCh%(MJ%))%@NL@% %@NL@% PSET (StartLoc, V), POINT(StartLoc, V)%@NL@% %@NL@% LastMissing% = cNo%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Move to next category position:%@AE@%%@NL@% StartLoc = StartLoc + GE.XAxis.TicInterval%@NL@% NEXT i%%@NL@% NEXT J%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clDrawPieData - Draws data part of a pie chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Value(1) - One-dimensional array of data values%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Expl(1) - One-dimensional array of explode flags (1=explode, 0=no)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - The number of data values to plot%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clDrawPieData (value() AS SINGLE, Expl() AS INTEGER, N AS INTEGER)%@NL@% SHARED GE AS ChartEnvironment%@NL@% SHARED GP AS GlobalParams%@NL@% SHARED GFI AS FontInfo%@NL@% SHARED PaletteC%(), PaletteP$()%@NL@% %@NL@% %@AB@% ' Set the font to use for percent labels:%@AE@%%@NL@% clSetChartFont GE.DataFont%@NL@% %@NL@% %@AB@% ' Set up some reference variables:%@AE@%%@NL@% Pi2 = 2 * cPiVal ' 2*PI for radians conversions%@NL@% MinAngle = Pi2 / 120 ' Smallest wedge to try to paint%@NL@% A1 = -.0000001 ' Starting and ending angle (set%@NL@% A2 = A1 ' to very small negative to get%@NL@% %@AB@% ' radius line for first wedge)%@AE@%%@NL@% %@NL@% %@AB@% ' Size the pie.%@AE@%%@NL@% %@AB@% ' Choose the point in the middle of the data window for the pie center:%@AE@%%@NL@% WINDOW (0, 0)-(1, 1)%@NL@% X = PMAP(.5, 0) ' Distance: left to center%@NL@% Y = PMAP(.5, 1) ' Distance: bottom to center%@NL@% WINDOW ' Now, use physical coordinates (pixels)%@NL@% GTextWindow 0, 0, 0, 0, cFalse%@NL@% %@NL@% %@AB@% ' Adjust radii for percent labels if required:%@AE@%%@NL@% clSetChartFont GE.DataFont%@NL@% IF GE.ChartStyle = cPercent THEN%@NL@% RadiusX = (X - 6 * GFI.AvgWidth) * GP.Aspect%@NL@% RadiusY = Y - 2 * GFI.PixHeight%@NL@% ELSE%@NL@% RadiusX = X * GP.Aspect%@NL@% RadiusY = Y%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Pick the smallest radius (adjusted for screen aspect) then reduce%@AE@%%@NL@% %@AB@% ' it by 10% so the pie isn't too close to the window border:%@AE@%%@NL@% IF RadiusX < RadiusY THEN%@NL@% Radius = RadiusX%@NL@% ELSE%@NL@% Radius = RadiusY%@NL@% END IF%@NL@% Radius = (.9 * Radius) / GP.Aspect%@NL@% %@NL@% %@AB@% ' If radius is too small then error:%@AE@%%@NL@% IF Radius <= 0 THEN%@NL@% clSetError cBadDataWindow%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Find the sum of the data values (use double precision Sum variable to%@AE@%%@NL@% %@AB@% ' protect against overflow if summing large data values):%@AE@%%@NL@% Sum# = 0%@NL@% FOR i% = 1 TO GP.NSeries%@NL@% IF value(i%) > 0 THEN Sum# = Sum# + value(i%)%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' Loop through drawing and painting the wedges:%@AE@%%@NL@% FOR i% = 1 TO N%@NL@% %@NL@% %@AB@% ' Map I% to a valid palette reference:%@AE@%%@NL@% MappedI% = clMap2Pal(i%)%@NL@% %@NL@% %@AB@% ' Draw wedges for positive values only:%@AE@%%@NL@% IF value(i%) > 0 THEN%@NL@% %@NL@% %@AB@% ' Calculate wedge percent and wedge ending angle:%@AE@%%@NL@% Percent = value(i%) / Sum#%@NL@% A2 = A1 - Percent * Pi2%@NL@% %@NL@% %@AB@% ' This locates the angle through the center of the pie wedge and%@AE@%%@NL@% %@AB@% ' calculates X and Y components of the vector headed in that%@AE@%%@NL@% %@AB@% ' direction:%@AE@%%@NL@% Bisect = (A1 + A2) / 2%@NL@% BisectX = Radius * COS(Bisect)%@NL@% BisectY = Radius * SIN(Bisect) * GP.Aspect%@NL@% %@NL@% %@AB@% ' If the piece is exploded then offset it 1/10th of a radius%@AE@%%@NL@% %@AB@% ' along the bisecting angle calculated above:%@AE@%%@NL@% IF Expl(i%) <> 0 THEN%@NL@% CX = X + .1 * BisectX%@NL@% CY = Y + .1 * BisectY%@NL@% ELSE%@NL@% CX = X%@NL@% CY = Y%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If the angle is large enough, paint the wedge (if wedges of%@AE@%%@NL@% %@AB@% ' smaller angles are painted, the "paint" will sometimes spill out):%@AE@%%@NL@% IF (A1 - A2) > MinAngle THEN%@NL@% PX = CX + .8 * BisectX%@NL@% PY = CY + .8 * BisectY%@NL@% %@NL@% %@AB@% ' Outline the wedge in color 1 and paint it black.%@AE@%%@NL@% CIRCLE (CX, CY), Radius, 1, A1, A2, GP.Aspect%@NL@% PAINT (PX, PY), 0, 1%@NL@% %@AB@% ' Paint with the appropriate pattern:%@AE@%%@NL@% PAINT (PX, PY), PaletteP$(MappedI%), 1%@NL@% END IF%@NL@% %@AB@% ' draw the wedge in the correct color:%@AE@%%@NL@% CIRCLE (CX, CY), Radius, PaletteC%(MappedI%), A1, A2, GP.Aspect%@NL@% %@NL@% %@AB@% ' Label pie wedge with percent if appropriate:%@AE@%%@NL@% IF GE.ChartStyle = cPercent THEN%@NL@% Label$ = clVal2Str$(Percent * 100, 1, 1) + "%"%@NL@% LabelX% = CX + BisectX + (GFI.AvgWidth * COS(Bisect))%@NL@% LabelY% = CY + BisectY + (GFI.AvgWidth * SIN(Bisect)) * GP.Aspect%@NL@% %@NL@% %@AB@% ' Adjust label location for the quadrant:%@AE@%%@NL@% Quadrant% = FIX((ABS(Bisect / Pi2)) * 4)%@NL@% IF Quadrant% = 0 OR Quadrant% = 1 THEN%@NL@% LabelY% = LabelY% - GFI.Ascent%@NL@% END IF%@NL@% IF Quadrant% = 1 OR Quadrant% = 2 THEN%@NL@% LabelX% = LabelX% - GetGTextLen(Label$)%@NL@% END IF%@NL@% %@NL@% clSetCharColor GE.Legend.TextColor%@NL@% clHPrint LabelX%, LabelY%, Label$%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Set the beginning of next wedge to the end of this one:%@AE@%%@NL@% A1 = A2%@NL@% %@NL@% NEXT i%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clDrawScatterData - Draws data portion of Scatter chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clDrawScatterData%@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED PaletteC%(), PaletteS%(), PaletteCh%()%@NL@% SHARED GFI AS FontInfo%@NL@% SHARED V1(), V2()%@NL@% %@NL@% %@AB@% ' Select the chart font and make text output horizontal:%@AE@%%@NL@% clSetChartFont GE.DataFont%@NL@% SetGTextDir 0%@NL@% %@NL@% %@AB@% ' Now, loop through all the points charting them:%@AE@%%@NL@% FOR Series% = 1 TO GP.NSeries%@NL@% %@NL@% %@AB@% ' Set LastMissing flag to Yes for first point in series:%@AE@%%@NL@% LastMissing% = cYes%@NL@% MS% = clMap2Pal%(Series%)%@NL@% %@NL@% %@AB@% ' Loop through all the points, charting them:%@AE@%%@NL@% FOR DataPoint% = 1 TO GP.NVals%@NL@% %@NL@% %@AB@% ' Get the X-value and Y-values from the data arrays:%@AE@%%@NL@% VX = V1(DataPoint%, Series%)%@NL@% VY = V2(DataPoint%, Series%)%@NL@% %@NL@% %@AB@% ' If either of the values to chart is missing set LastMissing%@AE@%%@NL@% %@AB@% ' flag to Yes to indicate a missing point and go to the next point:%@AE@%%@NL@% IF VX = cMissingValue OR VY = cMissingValue THEN%@NL@% LastMissing% = cYes%@NL@% %@NL@% ELSE%@NL@% %@NL@% %@AB@% ' Otherwise, scale the X and Y values if AutoScale is set for%@AE@%%@NL@% %@AB@% ' their respective axes:%@AE@%%@NL@% IF GE.XAxis.AutoScale = cYes THEN VX = VX / GE.XAxis.ScaleFactor%@NL@% IF GE.YAxis.AutoScale = cYes THEN VY = VY / GE.YAxis.ScaleFactor%@NL@% %@NL@% %@AB@% ' If this is a lined chart and the last point wasn't missing,%@AE@%%@NL@% %@AB@% ' then draw a line from last point to the current point:%@AE@%%@NL@% IF GE.ChartStyle = cLines AND LastMissing% <> cYes THEN%@NL@% LINE -(VX, VY), PaletteC%(MS%), , PaletteS%(MS%)%@NL@% END IF%@NL@% %@NL@% %@AB@% ' In any case draw the plot character. Start by getting the%@AE@%%@NL@% %@AB@% ' screen coordinates of the character relative to the point%@AE@%%@NL@% %@AB@% ' just charted:%@AE@%%@NL@% CX% = PMAP(VX, 0) - GetGTextLen(CHR$(PaletteCh%(MS%))) / 2%@NL@% CY% = PMAP(VY, 1) - GFI.Ascent / 2%@NL@% %@NL@% %@AB@% ' Now, set the character color and print it:%@AE@%%@NL@% clSetCharColor MS%%@NL@% clHPrint CX%, CY%, CHR$(PaletteCh%(MS%))%@NL@% %@NL@% %@AB@% ' Finally, reset the graphics cursor, since printing the%@AE@%%@NL@% %@AB@% ' character changed it:%@AE@%%@NL@% PSET (VX, VY), POINT(VX, VY)%@NL@% %@NL@% LastMissing% = cNo%@NL@% END IF%@NL@% %@NL@% NEXT DataPoint%%@NL@% NEXT Series%%@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clDrawTitles - Draws the main and subtitles on a chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clDrawTitles%@NL@% SHARED GE AS ChartEnvironment%@NL@% SHARED TTitleLayout AS TitleLayout%@NL@% %@NL@% %@AB@% ' Bottom of main title line is 1-1/2 character heights from the%@AE@%%@NL@% %@AB@% ' top of the chart window:%@AE@%%@NL@% YPos% = TTitleLayout.Top%@NL@% clPrintTitle GE.MainTitle, YPos%%@NL@% %@NL@% %@AB@% ' Add 1.5 * character height to y position for subtitle line position:%@AE@%%@NL@% YPos% = YPos% + TTitleLayout.TitleOne + TTitleLayout.Middle%@NL@% clPrintTitle GE.SubTitle, YPos%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clFilter - Filters input data into dynamic working data array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Axis - An AxisType variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' AxisMode%- Mode for this axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' D1(1) - One-dimensional array of input data%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' D2(2) - Two-dimensional array for filtered data%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - The number of values to transfer%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Alters values in D2()%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clFilter (Axis AS AxisType, AxisMode%, D1(), D2(), N%)%@NL@% %@NL@% %@AB@% ' If the axis is a category one then exit:%@AE@%%@NL@% IF AxisMode% = cCategory THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Transfer the data from the input data array to the working data%@AE@%%@NL@% %@AB@% ' array:%@AE@%%@NL@% FOR i% = 1 TO N%%@NL@% D2(i%, 1) = D1(i%)%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' Call FilterMS to go through the data again scaling it and taking%@AE@%%@NL@% %@AB@% ' logs depending on the settings for this axis:%@AE@%%@NL@% clFilterMS Axis, AxisMode%, D2(), D2(), N%, 1, 1%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clFilterMS - Filters two-dimensional input data into the dynamic working%@AE@%%@NL@% %@AB@%' data array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Axis - An AxisType variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' AxisMode%- Axis mode for the axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' D1(2) - Two-dimensional array of input data%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' D2(2) - Two-dimensional array for filtered data%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N% - The number of values to transfer%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' First% - First data series to filter%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Last% - Last data series to filter%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Alters values in D2()%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clFilterMS (Axis AS AxisType, AxisMode%, D1(), D2(), N%, First%, Last%)%@NL@% %@NL@% %@AB@% ' If the axis is a category axis then exit:%@AE@%%@NL@% IF AxisMode% = cCategory THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' If this isn't an autoscale axis, use the scale factor from the%@AE@%%@NL@% %@AB@% ' environment. If it is an autoscale axis don't scale at all now%@AE@%%@NL@% %@AB@% ' it will be done when the data is drawn on the screen:%@AE@%%@NL@% IF Axis.AutoScale = cNo THEN%@NL@% ScaleFactor = Axis.ScaleFactor%@NL@% ELSE%@NL@% ScaleFactor = 1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If this a log axis calculate the log base:%@AE@%%@NL@% IF AxisMode% = cLog THEN LogRef = LOG(Axis.LogBase)%@NL@% %@NL@% %@AB@% ' Loop through the data series:%@AE@%%@NL@% FOR J% = First% TO Last%%@NL@% %@NL@% %@AB@% ' Loop through the values within the series:%@AE@%%@NL@% FOR i% = 1 TO N%%@NL@% %@NL@% %@AB@% ' Get a data value and if it isn't missing, then scale it:%@AE@%%@NL@% V = D1(i%, J%)%@NL@% IF V <> cMissingValue THEN V = V / ScaleFactor%@NL@% %@NL@% %@AB@% ' If the axis is a log axis, then if the value is greater than%@AE@%%@NL@% %@AB@% ' it is safe to take it's log. Otherwise, set the data value to%@AE@%%@NL@% %@AB@% ' missing:%@AE@%%@NL@% IF Axis.RangeType = cLog THEN%@NL@% IF V > 0 THEN%@NL@% V = LOG(V) / LogRef%@NL@% ELSE%@NL@% V = cMissingValue%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Place the value in the output data array:%@AE@%%@NL@% D2(i%, J% - First% + 1) = V%@NL@% %@NL@% NEXT i%%@NL@% %@NL@% NEXT J%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clFlagSystem - Sets GP.SysFlag to cYes%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Alters the value of GP.SysFlag%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clFlagSystem%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% GP.SysFlag = cYes%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clFormatTics - Figures out tic label format and TicDecimals.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Axis - AxisType variable for which to format tics.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' The TicFormat and Decimals elements may be changed for an axis%@AE@%%@NL@% %@AB@%' if AutoTic is cYes.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clFormatTics (Axis AS AxisType)%@NL@% %@NL@% %@AB@% ' If AutoScale isn't Yes then exit%@AE@%%@NL@% IF Axis.AutoScale <> cYes THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' If the size of the largest value is bigger than seven decimal%@AE@%%@NL@% %@AB@% ' places then set TicFormat to exponential. Otherwise, set it%@AE@%%@NL@% %@AB@% ' to normal:%@AE@%%@NL@% IF ABS(Axis.ScaleMin) >= 10 ^ 8 OR ABS(Axis.ScaleMax) >= 10 ^ 8 THEN%@NL@% Axis.TicFormat = cExpFormat%@NL@% ELSE%@NL@% Axis.TicFormat = cNormFormat%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Pick the largest of the scale max and min (in absolute value) and%@AE@%%@NL@% %@AB@% ' use that to decide how many decimals to use when displaying the tic%@AE@%%@NL@% %@AB@% ' labels:%@AE@%%@NL@% Range = ABS(Axis.ScaleMax)%@NL@% IF ABS(Axis.ScaleMin) > Range THEN Range = ABS(Axis.ScaleMin)%@NL@% IF Range < 10 THEN%@NL@% TicResolution = -INT(-ABS(LOG(Range) / LOG(10!))) + 1%@NL@% IF TicResolution > 9 THEN TicResolution = 9%@NL@% Axis.TicDecimals = TicResolution%@NL@% ELSE%@NL@% Axis.TicDecimals = 0%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clGetStyle - Returns a predefined line-style definition%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' StyleNum% - A number identifying the entry to return%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Returns the line-style for the specified style number%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION clGetStyle% (StyleNum%)%@NL@% %@NL@% SELECT CASE StyleNum%%@NL@% CASE 1: Style% = &HFFFF%@NL@% CASE 2: Style% = &HF0F0%@NL@% CASE 3: Style% = &HF060%@NL@% CASE 4: Style% = &HCCCC%@NL@% CASE 5: Style% = &HC8C8%@NL@% CASE 6: Style% = &HEEEE%@NL@% CASE 7: Style% = &HEAEA%@NL@% CASE 8: Style% = &HF6DE%@NL@% CASE 9: Style% = &HF6F6%@NL@% CASE 10: Style% = &HF56A%@NL@% CASE 11: Style% = &HCECE%@NL@% CASE 12: Style% = &HA8A8%@NL@% CASE 13: Style% = &HAAAA%@NL@% CASE 14: Style% = &HE4E4%@NL@% CASE 15: Style% = &HC88C%@NL@% END SELECT%@NL@% clGetStyle% = Style%%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== clHPrint - Prints text Horizontally on the screen%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' X - X position for the lower left of the first character to be%@AE@%%@NL@% %@AB@%' printed (in absolute screen coordinates)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Y - Y position for the lower left of the first character to be%@AE@%%@NL@% %@AB@%' printed (in absolute screen coordinates)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Txt$ - Text to print%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clHPrint (X%, Y%, Txt$)%@NL@% %@NL@% %@AB@% ' Map the input coordinates relative to the current viewport:%@AE@%%@NL@% X = PMAP(X%, 2)%@NL@% Y = PMAP(Y%, 3)%@NL@% %@NL@% %@AB@% ' Output the text horizontally:%@AE@%%@NL@% SetGTextDir 0%@NL@% TextLen% = OutGText(X, Y, Txt$)%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clInitChart - Initializes the charting library.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' This routine initializes some default data structures and is%@AE@%%@NL@% %@AB@%' called automatically by charting routines if the variable%@AE@%%@NL@% %@AB@%' GP.Initialized is cNo (or zero).%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clInitChart%@NL@% SHARED StdChars%(), GP AS GlobalParams%@NL@% %@NL@% %@AB@% ' Clear any previous errors%@AE@%%@NL@% clClearError%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@% ' Initialize PaletteSet to no so palettes will be initialized properly%@AE@%%@NL@% %@AB@% ' when ChartScreen is called:%@AE@%%@NL@% GP.PaletteSet = cNo%@NL@% %@NL@% %@AB@% ' Set up the list of plotting characters:%@AE@%%@NL@% PlotChars$ = "*ox=+/:&#@%![$^"%@NL@% StdChars%(0) = 0%@NL@% FOR i% = 1 TO cPalLen%@NL@% StdChars%(i%) = ASC(MID$(PlotChars$, i%, 1))%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' Initialize standard structures for title, axis, window and legend:%@AE@%%@NL@% clInitStdStruc%@NL@% %@NL@% GP.Initialized = cYes%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clInitStdStruc - Initializes structures for standard titles, axes, etc.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clInitStdStruc%@NL@% SHARED DAxis AS AxisType, DWindow AS RegionType%@NL@% SHARED DLegend AS LegendType, DTitle AS TitleType%@NL@% %@NL@% %@AB@%' Set up default components of the default chart%@AE@%%@NL@% %@AB@%' environment; start with default title:%@AE@%%@NL@% %@NL@% %@AB@%' Default title definition:%@AE@%%@NL@% DTitle.Title = "" ' Title text is blank%@NL@% DTitle.TitleFont = 1 ' Title font is first one%@NL@% DTitle.TitleColor = 1 ' Title color is white%@NL@% DTitle.Justify = cCenter ' Center justified%@NL@% %@NL@% %@AB@%' Default axis definition:%@AE@%%@NL@% DAxis.grid = cNo ' No grid%@NL@% DAxis.GridStyle = 1 ' Solid lines for grid%@NL@% DAxis.AxisTitle = DTitle ' Use above to initialize axis title%@NL@% DAxis.AxisColor = 1 ' Axis color is white%@NL@% DAxis.Labeled = cYes ' Label and tic axis%@NL@% DAxis.RangeType = cLinear ' Linear axis%@NL@% DAxis.LogBase = 10 ' Logs to base 10%@NL@% DAxis.AutoScale = cYes ' Automatically scale numbers if needed%@NL@% DAxis.ScaleTitle = DTitle ' Scale title%@NL@% DAxis.TicFont = 1 ' Tic font is first one%@NL@% DAxis.TicDecimals = 0 ' No decimals%@NL@% %@NL@% %@AB@%' Default window definition:%@AE@%%@NL@% DWindow.Background = 0 ' Black background%@NL@% DWindow.Border = cNo ' Window will have no border%@NL@% DWindow.BorderColor = 1 ' Make the borders white%@NL@% DWindow.BorderStyle = 1 ' Solid-line borders%@NL@% %@NL@% %@AB@%' Default legend definition:%@AE@%%@NL@% DLegend.Legend = cYes ' Draw a legend if multi-series chart%@NL@% DLegend.Place = cRight ' On the right side%@NL@% DLegend.TextColor = 1 ' Legend text is white on black%@NL@% DLegend.TextFont = 1 ' Legend text font is first one%@NL@% DLegend.AutoSize = cYes ' Figure out size automatically%@NL@% DLegend.LegendWindow = DWindow ' Use the default window specification%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clLabelXTics - Labels tic marks for X axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Axis - An AxisType variable containing axis specification%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Cat$(1) - One-dimensional array of category labels. Ignored%@AE@%%@NL@% %@AB@%' if axis not category axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' TicX - X coordinate of first tic mark%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' TicY - Y coordinate of tic tip (portion away from axis)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' YBoundry% - Y coordinate of bottom of tic labels%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clLabelXTics (Axis AS AxisType, Cat$(), TicX, TicTotX%, TicY, YBoundry%)%@NL@% SHARED GFI AS FontInfo%@NL@% SHARED GP AS GlobalParams%@NL@% SHARED GE AS ChartEnvironment%@NL@% %@NL@% %@AB@% ' If this axis isn't supposed to be labeled then exit:%@AE@%%@NL@% IF Axis.Labeled <> cYes THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Set the appropriate color, font, and orientation for tic labels:%@AE@%%@NL@% clSetCharColor Axis.AxisColor%@NL@% clSetChartFont Axis.TicFont%@NL@% SetGTextDir 0%@NL@% %@NL@% %@AB@% ' The Y coordinate of the labels will be a constant .5 character%@AE@%%@NL@% %@AB@% ' heights below the end of the tic marks (TicY):%@AE@%%@NL@% Y% = PMAP(TicY, 1) + (GFI.Ascent - GFI.Leading) / 2%@NL@% IF GP.XStagger = cYes THEN%@NL@% YDrop% = (3 * GFI.Ascent - GFI.Leading) / 2%@NL@% ELSE%@NL@% YDrop% = 0%@NL@% END IF%@NL@% YBoundry% = Y% + YDrop% + GFI.PixHeight%@NL@% %@NL@% %@AB@% ' Loop through and write labels%@AE@%%@NL@% TX = TicX%@NL@% CatNum% = 1%@NL@% Stagger% = cFalse%@NL@% FOR i% = 1 TO TicTotX%%@NL@% %@NL@% %@AB@% ' The label depends on axis mode (category, value):%@AE@%%@NL@% SELECT CASE GP.XMode%@NL@% CASE cCategory: Txt$ = Cat$(CatNum%)%@NL@% CASE ELSE: Txt$ = clVal2Str$(TX, Axis.TicDecimals, Axis.TicFormat)%@NL@% END SELECT%@NL@% TxtLen% = GetGTextLen(Txt$)%@NL@% IF GP.XMode = cCategory THEN%@NL@% MaxLen% = 2 * (GE.DataWindow.X2 - GE.DataWindow.X1) / GP.NVals - GFI.AvgWidth%@NL@% IF MaxLen% < 0 THEN MaxLen% = 0%@NL@% DO UNTIL TxtLen% <= MaxLen%%@NL@% Txt$ = LEFT$(Txt$, LEN(Txt$) - 1)%@NL@% TxtLen% = GetGTextLen(Txt$)%@NL@% LOOP%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Center the label under the tic mark and print it:%@AE@%%@NL@% X% = PMAP(TX, 0) - (TxtLen%) / 2%@NL@% %@NL@% IF Stagger% THEN%@NL@% clHPrint X%, Y% + YDrop%, Txt$%@NL@% Stagger% = cFalse%@NL@% ELSE%@NL@% clHPrint X%, Y%, Txt$%@NL@% Stagger% = cTrue%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Move to the next tic mark:%@AE@%%@NL@% TX = TX + Axis.TicInterval%@NL@% CatNum% = CatNum% + 1%@NL@% NEXT i%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clLabelYTics - Labels tic marks and draws Y axis title%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Axis - An AxisType variable containing axis specification%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Cat$(1) - One-dimensional array of category labels. Ignored%@AE@%%@NL@% %@AB@%' if axis not category axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' TicX - X coordinate of first tic's tip (away from axis)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' TicY - Y coordinate of first tic%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clLabelYTics (Axis AS AxisType, Cat$(), TicX, TicY, TicTotY%)%@NL@% SHARED GFI AS FontInfo%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% %@AB@% ' If axis isn't supposed to be labeled then exit:%@AE@%%@NL@% IF Axis.Labeled <> cYes THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Set the appropriate color, font, and orientation for tic labels:%@AE@%%@NL@% clSetCharColor Axis.AxisColor%@NL@% clSetChartFont Axis.TicFont%@NL@% SetGTextDir 0%@NL@% %@NL@% %@AB@% ' Loop through and write labels%@AE@%%@NL@% TY = TicY%@NL@% CatNum% = 1%@NL@% FOR i% = 1 TO TicTotY%%@NL@% %@NL@% %@AB@% ' The label depends on axis mode (category, value):%@AE@%%@NL@% SELECT CASE GP.YMode%@NL@% CASE cCategory: Txt$ = Cat$(GP.NVals - CatNum% + 1)%@NL@% CASE ELSE: Txt$ = clVal2Str$(TY, Axis.TicDecimals, Axis.TicFormat)%@NL@% END SELECT%@NL@% TxtLen% = GetGTextLen(Txt$)%@NL@% %@NL@% %@AB@% ' Space the label 1/2 character width to the left of the tic%@AE@%%@NL@% %@AB@% ' mark and center it vertically on the tic mark (round vertical%@AE@%%@NL@% %@AB@% ' location to the next highest integer):%@AE@%%@NL@% X% = PMAP(TicX, 0) - TxtLen% - (.5 * GFI.MaxWidth)%@NL@% Y% = -INT(-(PMAP(TY, 1) - (GFI.Ascent + GFI.Leading) / 2))%@NL@% %@NL@% %@AB@% ' Print the label:%@AE@%%@NL@% clHPrint X%, Y%, Txt$%@NL@% %@NL@% %@AB@% ' Go to the next tic mark:%@AE@%%@NL@% TY = TY + Axis.TicInterval%@NL@% CatNum% = CatNum% + 1%@NL@% NEXT i%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clLayoutLegend - Calculates size of the legend%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' SeriesLabel$(1) - The labels used in the legend%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' First% - The first series (label) to process%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Last% - The last series (label) to process%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' The coordinates in the legend window portion of Env are altered%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' Sizing the legend window requires finding out where it goes (right%@AE@%%@NL@% %@AB@%' or bottom) and determining how big the labels are and how big%@AE@%%@NL@% %@AB@%' the legend needs to be to hold them.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clLayoutLegend (SeriesLabel$(), First%, Last%)%@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED GFI AS FontInfo%@NL@% SHARED LLayout AS LegendLayout%@NL@% SHARED TTitleLayout AS TitleLayout%@NL@% DIM W AS RegionType%@NL@% %@NL@% %@AB@% ' If "no legend" is specified, then exit:%@AE@%%@NL@% IF GE.Legend.Legend = cNo THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' This may be an auto legend or not, but, in either case we're%@AE@%%@NL@% %@AB@% ' going to need the following information:%@AE@%%@NL@% clSetChartFont GE.Legend.TextFont%@NL@% %@NL@% LLayout.SymbolSize = GFI.Ascent - GFI.Leading - 1%@NL@% LLayout.HorizBorder = GFI.Ascent%@NL@% LLayout.VertBorder = GFI.AvgWidth%@NL@% LLayout.RowSpacing = 1.75 * (LLayout.SymbolSize + 1)%@NL@% LLayout.LabelOffset = LLayout.SymbolSize / GP.Aspect + GFI.AvgWidth%@NL@% %@NL@% %@AB@% 'RowLeading% = LLayout.RowSpacing - LLayout.SymbolSize%@AE@%%@NL@% RowLeading% = .75 * LLayout.SymbolSize + 1.75%@NL@% %@NL@% ColWid% = clMaxStrLen(SeriesLabel$(), First%, Last%) + LLayout.LabelOffset%@NL@% LLayout.ColSpacing = ColWid% + GFI.AvgWidth%@NL@% %@NL@% %@AB@% ' If this isn't an autosize legend:%@AE@%%@NL@% IF GE.Legend.AutoSize = cNo THEN%@NL@% %@NL@% %@AB@% ' Check the legend coordinates supplied by the user to make%@AE@%%@NL@% %@AB@% ' sure that they are valid. If they are, exit:%@AE@%%@NL@% W = GE.Legend.LegendWindow%@NL@% LWid% = W.X2 - W.X1%@NL@% LHgt% = W.Y2 - W.Y1%@NL@% IF LWid% > 0 AND LHgt% > 0 THEN%@NL@% %@NL@% %@AB@% ' Calculate the number of columns and rows of labels that will%@AE@%%@NL@% %@AB@% ' fit in the legend:%@AE@%%@NL@% NumCol% = INT((LWid% - LLayout.VertBorder) / (LLayout.ColSpacing))%@NL@% IF NumCol% <= 0 THEN NumCol% = 1%@NL@% IF NumCol% > GP.NSeries THEN NumCol% = GP.NSeries%@NL@% NumRow% = -INT(-GP.NSeries / NumCol%)%@NL@% LLayout.NumRow = NumRow%%@NL@% LLayout.NumCol = NumCol%%@NL@% %@NL@% %@AB@% ' Re-calculate the column and row spacing:%@AE@%%@NL@% LLayout.ColSpacing = INT((LWid% - LLayout.VertBorder) / NumCol%)%@NL@% LLayout.RowSpacing = INT((LHgt% - 2 * LLayout.HorizBorder + RowLeading%) / NumRow%)%@NL@% %@NL@% EXIT SUB%@NL@% %@NL@% %@AB@% ' If invalid legend coordinates are discovered set an error and%@AE@%%@NL@% %@AB@% ' go on to calculate new ones:%@AE@%%@NL@% ELSE%@NL@% %@NL@% clSetError cBadLegendWindow%@NL@% %@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Do remaining calculations according to the legend placement specified%@AE@%%@NL@% %@AB@% ' (right, bottom, overlay):%@AE@%%@NL@% SELECT CASE GE.Legend.Place%@NL@% %@NL@% CASE cRight, cOverlay:%@NL@% %@NL@% %@AB@% ' Leave room at top for chart titles:%@AE@%%@NL@% Top% = TTitleLayout.TotalSize%@NL@% %@NL@% %@AB@% ' Figure out the maximum number of legend rows that will%@AE@%%@NL@% %@AB@% ' fit in the amount of space you have left for the legend%@AE@%%@NL@% %@AB@% ' height. Then, see how many columns are needed. Once%@AE@%%@NL@% %@AB@% ' the number of columns is set refigure how many rows are%@AE@%%@NL@% %@AB@% ' required:%@AE@%%@NL@% NumRow% = INT((GP.ChartHgt - Top% - 2 * LLayout.HorizBorder) / LLayout.RowSpacing)%@NL@% IF NumRow% > GP.NSeries THEN NumRow% = GP.NSeries%@NL@% NumCol% = -INT(-GP.NSeries / NumRow%)%@NL@% NumRow% = -INT(-GP.NSeries / NumCol%)%@NL@% %@NL@% %@AB@% ' Set the width and height:%@AE@%%@NL@% LWid% = NumCol% * LLayout.ColSpacing - GFI.AvgWidth + 2 * LLayout.VertBorder%@NL@% LHgt% = (NumRow% * LLayout.RowSpacing - RowLeading% + 2 * LLayout.HorizBorder)%@NL@% %@NL@% %@AB@% ' Place the legend one character width from right and even with%@AE@%%@NL@% %@AB@% ' what will be the top of the data window:%@AE@%%@NL@% LLft% = GP.ChartWid - 1 - LWid% - GFI.AvgWidth%@NL@% LTop% = Top%%@NL@% %@NL@% CASE cBottom:%@NL@% %@NL@% %@AB@% ' The number of label columns that will fit (using the same%@AE@%%@NL@% %@AB@% ' procedure as above except figure columns first):%@AE@%%@NL@% NumCol% = INT((GP.ChartWid - 2 * LLayout.HorizBorder) / LLayout.ColSpacing)%@NL@% IF NumCol% > GP.NSeries THEN NumCol% = GP.NSeries%@NL@% NumRow% = -INT(-GP.NSeries / NumCol%)%@NL@% NumCol% = -INT(-GP.NSeries / NumRow%)%@NL@% %@NL@% %@AB@% ' Set the width and height:%@AE@%%@NL@% LWid% = NumCol% * LLayout.ColSpacing - GFI.AvgWidth + 2 * LLayout.VertBorder%@NL@% LHgt% = (NumRow% * LLayout.RowSpacing - RowLeading% + 2 * LLayout.HorizBorder)%@NL@% %@NL@% %@AB@% ' Center the legend horizontally one character from the bottom:%@AE@%%@NL@% LLft% = (GP.ChartWid - 1 - LWid%) / 2%@NL@% LTop% = GP.ChartHgt - 1 - LHgt% - GFI.Ascent%@NL@% %@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Record legend columns and rows:%@AE@%%@NL@% LLayout.NumRow = NumRow%%@NL@% LLayout.NumCol = NumCol%%@NL@% %@NL@% %@AB@% ' Finally, place the legend coordinates in GE:%@AE@%%@NL@% GE.Legend.LegendWindow.X1 = LLft%%@NL@% GE.Legend.LegendWindow.Y1 = LTop%%@NL@% GE.Legend.LegendWindow.X2 = LLft% + LWid%%@NL@% GE.Legend.LegendWindow.Y2 = LTop% + LHgt%%@NL@% %@NL@% %@AB@% ' If, after all this, the legend window is invalid, set error:%@AE@%%@NL@% IF LLft% < 0 OR LTop% < 0 OR LWid% <= 0 OR LHgt% <= 0 THEN%@NL@% clSetError cBadLegendWindow%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clLayoutTitle - Figures out title layouts for Top, X-axis and%@AE@%%@NL@% %@AB@%' Y-axis titles%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' TL - Layout variable into which to place titles%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' T1 - First title%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' T2 - Second Title%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clLayoutTitle (TL AS TitleLayout, T1 AS TitleType, T2 AS TitleType)%@NL@% SHARED GFI AS FontInfo%@NL@% %@NL@% %@AB@% ' Set the title heights initially to 0:%@AE@%%@NL@% TL.TitleOne = 0%@NL@% TL.TitleTwo = 0%@NL@% %@NL@% %@AB@% ' If the first title is set then get its height:%@AE@%%@NL@% Total% = 0%@NL@% IF LTRIM$(T1.Title) <> "" THEN%@NL@% clSetChartFont T1.TitleFont%@NL@% TL.TitleOne = GFI.PixHeight%@NL@% Total% = Total% + 1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If the second title is set then get it's height:%@AE@%%@NL@% IF LTRIM$(T2.Title) <> "" THEN%@NL@% clSetChartFont T2.TitleFont%@NL@% TL.TitleTwo = GFI.PixHeight%@NL@% Lead2% = GFI.Leading%@NL@% Total% = Total% + 1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Set the "leading" values for label spacing depending on how many%@AE@%%@NL@% %@AB@% ' of the titles were non-blank:%@AE@%%@NL@% TotalHeight% = TL.TitleOne + TL.TitleTwo%@NL@% SELECT CASE Total%%@NL@% CASE 0:%@NL@% TL.Top = 8%@NL@% TL.Middle = 0%@NL@% TL.Bottom = 4%@NL@% %@NL@% CASE 1:%@NL@% TL.Top = 8 + TotalHeight% / 8%@NL@% TL.Middle = 0%@NL@% TL.Bottom = TL.Top%@NL@% %@NL@% CASE 2:%@NL@% TL.Top = 8 + TotalHeight% / 8%@NL@% TL.Middle = 0: IF Lead2% = 0 THEN TL.Middle = TL.TitleOne / 2%@NL@% TL.Bottom = TL.Top%@NL@% END SELECT%@NL@% %@NL@% TL.TotalSize = TL.Top + TL.TitleOne + TL.Middle + TL.TitleTwo + TL.Bottom%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clMap2Attrib% - Maps an integer to a screen attribute for current%@AE@%%@NL@% %@AB@%' screen mode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' N% - The number to map%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' The function returns:%@AE@%%@NL@% %@AB@%' 0 is mapped to 0, all other numbers are mapped to the range%@AE@%%@NL@% %@AB@%' 1 to GP.MaxColor%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION clMap2Attrib% (N%)%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% AbsN% = ABS(N%)%@NL@% IF AbsN% = 0 THEN%@NL@% clMap2Attrib% = AbsN%%@NL@% ELSE%@NL@% clMap2Attrib% = (AbsN% - 1) MOD GP.MaxColor + 1%@NL@% END IF%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== clMap2Pal% - Maps an integer into a palette reference%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' N% - The number to map%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' The function returns (N%-1) MOD cPalLen + 1%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' This FUNCTION is used in almost every reference to a palette to ensure%@AE@%%@NL@% %@AB@%' that an invalid number doesn't cause a reference outside of a palette%@AE@%%@NL@% %@AB@%' array (and thus crash the library). This FUNCTION maps the first%@AE@%%@NL@% %@AB@%' cPalLen values to themselves. Numbers above cPalLen are mapped to%@AE@%%@NL@% %@AB@%' the values 2..cPalLen.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION clMap2Pal% (N%)%@NL@% %@NL@% AbsN% = ABS(N%)%@NL@% IF AbsN% > cPalLen THEN%@NL@% clMap2Pal% = (AbsN% - 2) MOD (cPalLen - 1) + 2%@NL@% ELSE%@NL@% clMap2Pal% = AbsN%%@NL@% END IF%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== clMaxStrLen% - Finds the length of the longest string in a list%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Txt$(1) - One-dimensional array of strings to search%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' First% - First string to consider%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Last% - Last string to consider%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' This FUNCTION returns the length of the longest string%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION clMaxStrLen% (Txt$(), First%, Last%)%@NL@% %@NL@% %@AB@% ' Set Max to 0 then loop through each label updating Max if the%@AE@%%@NL@% %@AB@% ' label is longer:%@AE@%%@NL@% Max% = 0%@NL@% FOR Row% = First% TO Last%%@NL@% L% = GetGTextLen(Txt$(Row%))%@NL@% IF L% > Max% THEN Max% = L%%@NL@% NEXT Row%%@NL@% %@NL@% %@AB@% ' Return Max as the value of the FUNCTION:%@AE@%%@NL@% clMaxStrLen% = Max%%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== clMaxVal - Returns the maximum of two numbers%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' A - The first number%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' B - The second number%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' The function returns the maximum of the two values%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION clMaxVal (A, B)%@NL@% %@NL@% IF A > B THEN clMaxVal = A ELSE clMaxVal = B%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== clPrintTitle - Prints title correctly justified and colored%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' TitleVar - A TitleType variable containing specifications for the%@AE@%%@NL@% %@AB@%' title to be printed%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Y% - Vertical position in window for bottom of line%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clPrintTitle (TitleVar AS TitleType, Y%)%@NL@% SHARED GFI AS FontInfo, GP AS GlobalParams%@NL@% %@NL@% %@AB@% ' Calculate width of the title text:%@AE@%%@NL@% clSetChartFont TitleVar.TitleFont%@NL@% %@NL@% Txt$ = RTRIM$(TitleVar.Title)%@NL@% TxtLen% = GetGTextLen(Txt$)%@NL@% IF TxtLen% = 0 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Calculate horizontal position depending on justification style%@AE@%%@NL@% SELECT CASE TitleVar.Justify%@NL@% %@NL@% CASE cCenter: X% = (GP.ChartWid - 1 - (TxtLen%)) / 2%@NL@% CASE cRight: X% = GP.ChartWid - 1 - TxtLen% - GFI.AvgWidth%@NL@% CASE ELSE: X% = GFI.AvgWidth%@NL@% %@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Set color of text and print it:%@AE@%%@NL@% clSetCharColor TitleVar.TitleColor%@NL@% clHPrint X%, Y%, Txt$%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clRenderBar - Renders a bar for a bar or column chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' X1 - Left side of bar (in data world coordinates)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Y1 - Top of bar (in data world coordinates)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' X2 - Right side of bar (in data world coordinates)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Y2 - Bottom of bar (in data world coordinates)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' C% - Palette entry number to use for border color and fill pattern%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clRenderBar (X1, Y1, X2, Y2, C%)%@NL@% SHARED PaletteC%(), PaletteP$()%@NL@% %@NL@% %@AB@% ' First clear out space for the bar by drawing a bar in black:%@AE@%%@NL@% LINE (X1, Y1)-(X2, Y2), 0, BF%@NL@% %@NL@% %@AB@% ' Put a border around the bar and fill with pattern:%@AE@%%@NL@% MC% = clMap2Pal%(C%)%@NL@% %@NL@% LINE (X1, Y1)-(X2, Y2), 1, B%@NL@% PAINT ((X1 + X2) / 2, (Y1 + Y2) / 2), PaletteP$(MC%), 1%@NL@% LINE (X1, Y1)-(X2, Y2), PaletteC%(MC%), B%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clRenderWindow - Renders a window on the screen%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' W - A RegionType variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' This routine assumes that the viewport is set to the borders of%@AE@%%@NL@% %@AB@%' the window to be rendered%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clRenderWindow (W AS RegionType)%@NL@% SHARED PaletteC%(), PaletteB%()%@NL@% %@NL@% %@AB@% ' Set window since the size of the viewport is unknown and draw%@AE@%%@NL@% %@AB@% ' a filled box of the background color specified by the window%@AE@%%@NL@% %@AB@% ' definition:%@AE@%%@NL@% WINDOW (0, 0)-(1, 1)%@NL@% LINE (0, 0)-(1, 1), PaletteC%(clMap2Pal%(W.Background)), BF%@NL@% %@NL@% %@AB@% ' Draw a border if specified:%@AE@%%@NL@% IF W.Border = cYes THEN%@NL@% LINE (0, 0)-(1, 1), PaletteC%(clMap2Pal%(W.BorderColor)), B, PaletteB%(clMap2Pal%(W.BorderStyle))%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clScaleAxis - Calculates minimum, maximum and scale factor for an axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' A - An AxisType variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' AxisMode%- cCategory or cValue%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' D1(2) - Two-dimensional array of values to be scaled%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' ScaleMin, ScaleMax, ScaleFactor, and ScaleTitle elements in%@AE@%%@NL@% %@AB@%' axis variable will be altered if it is a category axis or%@AE@%%@NL@% %@AB@%' AutoScale is Yes.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clScaleAxis (Axis AS AxisType, AxisMode%, D1())%@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% %@NL@% %@AB@% ' If this is a category axis then ignore all the flags and force%@AE@%%@NL@% %@AB@% ' scale parameters to those needed by charting routines:%@AE@%%@NL@% IF AxisMode% = cCategory THEN%@NL@% Axis.ScaleMin = 0%@NL@% Axis.ScaleMax = 1%@NL@% Axis.ScaleFactor = 1%@NL@% Axis.ScaleTitle.Title = ""%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If AutoScale isn't Yes then exit:%@AE@%%@NL@% IF Axis.AutoScale <> cYes THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' AutoScale was specified, calculate the different scale variables%@AE@%%@NL@% %@AB@% ' Set maximum and minimum to defaults.%@AE@%%@NL@% %@NL@% %@AB@% ' Initialize the value- and row-minimum and maximum values to zero:%@AE@%%@NL@% VMin = 0%@NL@% VMax = 0%@NL@% %@NL@% RMin = 0%@NL@% RMax = 0%@NL@% %@NL@% %@AB@% ' Compare data values for minimum and maximum:%@AE@%%@NL@% FOR Row% = 1 TO GP.NVals%@NL@% %@NL@% %@AB@% ' Initialize positive and negative sum variables:%@AE@%%@NL@% RSumPos = 0%@NL@% RSumNeg = 0%@NL@% %@NL@% %@AB@% ' Evaluate the value from this row in each series:%@AE@%%@NL@% FOR Column% = 1 TO GP.NSeries%@NL@% %@NL@% %@AB@% ' Get the value from the data array:%@AE@%%@NL@% V = D1(Row%, Column%)%@NL@% %@NL@% %@AB@% ' Process values that aren't missing only:%@AE@%%@NL@% IF V <> cMissingValue THEN%@NL@% %@NL@% %@AB@% ' Add positive values to positive sum and negative ones to%@AE@%%@NL@% %@AB@% ' negative sum:%@AE@%%@NL@% IF V > 0 THEN RSumPos = RSumPos + V%@NL@% IF V < 0 THEN RSumNeg = RSumNeg + V%@NL@% %@NL@% %@AB@% ' Compare the value against current maximum and minimum and%@AE@%%@NL@% %@AB@% ' replace them if appropriate:%@AE@%%@NL@% IF V < VMin THEN VMin = V%@NL@% IF V > VMax THEN VMax = V%@NL@% %@NL@% END IF%@NL@% %@NL@% NEXT Column%%@NL@% %@NL@% %@AB@% ' Compare the positive and negative sums for this row with the%@AE@%%@NL@% %@AB@% ' current row maximum and minimum and replace them if appropriate:%@AE@%%@NL@% IF RSumNeg < RMin THEN RMin = RSumNeg%@NL@% IF RSumPos > RMax THEN RMax = RSumPos%@NL@% %@NL@% NEXT Row%%@NL@% %@NL@% %@AB@% ' If the chart style is one, meaning that the data isn't stacked for%@AE@%%@NL@% %@AB@% ' bar and column charts, or it is a line or scatter chart then the scale%@AE@%%@NL@% %@AB@% ' minimum and maximum are the minimum and maximum values found.%@AE@%%@NL@% %@AB@% ' Each value is adjusted so the data is not drawn on or beyond the%@AE@%%@NL@% %@AB@% ' border of the data window:%@AE@%%@NL@% IF GE.ChartStyle = 1 OR GE.ChartType = cLine OR GE.ChartType = cScatter THEN%@NL@% IF VMin < 0 THEN%@NL@% Axis.ScaleMin = VMin - .01 * (VMax - VMin)%@NL@% END IF%@NL@% IF VMax > 0 THEN%@NL@% Axis.ScaleMax = VMax + .01 * (VMax - VMin)%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Otherwise, the scale minimum and maximum are the minimum and maximum%@AE@%%@NL@% %@AB@% ' sums of the data for each row:%@AE@%%@NL@% ELSE%@NL@% IF RMin < 0 THEN%@NL@% Axis.ScaleMin = RMin - .01 * (RMax - RMin)%@NL@% END IF%@NL@% IF RMax > 0 THEN%@NL@% Axis.ScaleMax = RMax + .01 * (RMax - RMin)%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If no data then force range to be non-zero:%@AE@%%@NL@% IF Axis.ScaleMin = Axis.ScaleMax THEN Axis.ScaleMax = 1%@NL@% %@NL@% %@AB@% ' Adjust the scale limits by ScaleFactor if required:%@AE@%%@NL@% clAdjustScale Axis%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clSelectChartFont - Selects a font to use and gets info about it%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' N% - Font number to use%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clSelectChartFont (N%)%@NL@% SHARED GFI AS FontInfo%@NL@% %@NL@% %@AB@% ' Select the font and get information about it:%@AE@%%@NL@% SelectFont N%%@NL@% GetFontInfo GFI%@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clSelectChartWindow - Sets viewport to chart window%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' This routine erases any previous viewport%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clSelectChartWindow%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% %@AB@% ' Set viewport to chart window:%@AE@%%@NL@% VIEW (GP.CwX1, GP.CwY1)-(GP.CwX2, GP.CwY2)%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clSelectRelWindow - Sets viewport to window relative to chart window%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' W - RegionType variable of window to set%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' This routine erases any previous viewport%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clSelectRelWindow (W AS RegionType)%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% %@AB@% ' New viewport is defined relative to the current one:%@AE@%%@NL@% VIEW (GP.CwX1 + W.X1, GP.CwY1 + W.Y1)-(GP.CwX1 + W.X2, GP.CwY1 + W.Y2)%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clSetAxisModes - Sets axis modes for X- and Y-axis according to%@AE@%%@NL@% %@AB@%' ChartType%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Alters XAxis and YAxis axis modes%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clSetAxisModes%@NL@% SHARED GE AS ChartEnvironment%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% SELECT CASE GE.ChartType%@NL@% %@NL@% CASE cBar:%@NL@% GP.XMode = cValue%@NL@% GP.YMode = cCategory%@NL@% %@NL@% CASE cColumn, cLine:%@NL@% GP.XMode = cCategory%@NL@% GP.YMode = cValue%@NL@% %@NL@% CASE cScatter:%@NL@% GP.XMode = cValue%@NL@% GP.YMode = cValue%@NL@% %@NL@% CASE cPie:%@NL@% GP.XMode = cCategory%@NL@% GP.YMode = cCategory%@NL@% %@NL@% END SELECT%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clSetCharColor - Sets color for DRAW characters%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' N% - Color number%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clSetCharColor (N%)%@NL@% SHARED PaletteC%()%@NL@% %@NL@% %@AB@% ' Check for valid color number then set color if correct:%@AE@%%@NL@% SetGTextColor PaletteC%(clMap2Pal%(N%))%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clSetChartFont - Selects the specified font%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' N% - Number of loaded font to select%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clSetChartFont (N AS INTEGER)%@NL@% SHARED GFI AS FontInfo%@NL@% %@NL@% %@AB@% ' Select font and get information on it:%@AE@%%@NL@% SelectFont N%%@NL@% GetFontInfo GFI%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clSetError - Sets the ChartLib error variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' ErrNo - The error number to set%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Sets ChartErr to ErrNo%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clSetError (ErrNo AS INTEGER)%@NL@% %@NL@% ChartErr = ErrNo%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clSetGlobalParams - Sets some global parameters that other routines use%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' GP.ValLenX and GP.ValLenY are altered%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clSetGlobalParams%@NL@% SHARED GP AS GlobalParams, GE AS ChartEnvironment%@NL@% %@NL@% %@AB@% ' Figure out longest label on X axis:%@AE@%%@NL@% clSetChartFont GE.XAxis.TicFont%@NL@% SF = GE.XAxis.ScaleMin%@NL@% Len1 = GetGTextLen(clVal2Str$(SF, GE.XAxis.TicDecimals, GE.XAxis.TicFormat))%@NL@% SF = GE.XAxis.ScaleMax%@NL@% Len2 = GetGTextLen(clVal2Str$(SF, GE.XAxis.TicDecimals, GE.XAxis.TicFormat))%@NL@% GP.ValLenX = clMaxVal(Len1, Len2)%@NL@% %@NL@% %@AB@% ' Figure out longest label on Y axis:%@AE@%%@NL@% clSetChartFont GE.YAxis.TicFont%@NL@% SF = GE.YAxis.ScaleMin%@NL@% Len1 = GetGTextLen(clVal2Str$(SF, GE.YAxis.TicDecimals, GE.YAxis.TicFormat))%@NL@% SF = GE.YAxis.ScaleMax%@NL@% Len2 = GetGTextLen(clVal2Str$(SF, GE.YAxis.TicDecimals, GE.YAxis.TicFormat))%@NL@% GP.ValLenY = clMaxVal(Len1, Len2)%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clSizeDataWindow - Calculates general data window size%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Cat$(1) - One-dimensional array of category labels (only%@AE@%%@NL@% %@AB@%' used if one of the axes is a category one)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' The X1, Y1, X2, Y2 elements of the GE variable will be%@AE@%%@NL@% %@AB@%' set to the data window coordinates%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clSizeDataWindow (Cat$())%@NL@% SHARED GE AS ChartEnvironment%@NL@% SHARED GP AS GlobalParams%@NL@% SHARED GFI AS FontInfo%@NL@% SHARED TTitleLayout AS TitleLayout%@NL@% SHARED XTitleLayout AS TitleLayout%@NL@% SHARED YTitleLayout AS TitleLayout%@NL@% %@NL@% %@AB@% ' *** TOP%@AE@%%@NL@% %@AB@% ' Adjust the top of the data window:%@AE@%%@NL@% DTop% = TTitleLayout.TotalSize%@NL@% %@NL@% %@AB@% ' *** LEFT%@AE@%%@NL@% %@AB@% ' Do left side:%@AE@%%@NL@% DLeft% = YTitleLayout.TotalSize%@NL@% %@NL@% %@AB@% ' Add room for axis labels if the axis is labeled and not a pie chart:%@AE@%%@NL@% IF GE.ChartType <> cPie THEN%@NL@% IF GE.YAxis.Labeled = cYes THEN%@NL@% %@NL@% %@AB@% ' Get the correct font:%@AE@%%@NL@% clSetChartFont GE.YAxis.TicFont%@NL@% %@NL@% %@AB@% ' If it is a category axis then add longest category label:%@AE@%%@NL@% IF GP.YMode = cCategory THEN%@NL@% DLeft% = DLeft% + clMaxStrLen%(Cat$(), 1, GP.NVals) + .5 * GFI.MaxWidth%@NL@% %@NL@% %@AB@% ' If it a value axis just add characters for label (plus 1/2 for%@AE@%%@NL@% %@AB@% ' spacing):%@AE@%%@NL@% ELSE%@NL@% DLeft% = DLeft% + GP.ValLenY + (.5 * GFI.MaxWidth)%@NL@% END IF%@NL@% %@NL@% ELSEIF GP.XMode = cValue AND GE.XAxis.Labeled = cYes THEN%@NL@% %@NL@% %@AB@% ' Then space over 1/2 of the leftmost label on the X Axis if it's%@AE@%%@NL@% %@AB@% ' a value axis; if it's a category axis assume the label will be%@AE@%%@NL@% %@AB@% ' correct:%@AE@%%@NL@% DLeft% = DLeft% + GP.ValLenX \ 2%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' *** RIGHT%@AE@%%@NL@% %@AB@% ' For the right, space over 8 pixels from the right:%@AE@%%@NL@% DRight% = 12%@NL@% %@NL@% %@AB@% ' Then space over 1/2 of the rightmost label on the X Axis if it's%@AE@%%@NL@% %@AB@% ' a value axis; if it's a category axis assume the label will be%@AE@%%@NL@% %@AB@% ' correct:%@AE@%%@NL@% IF GP.XMode = cValue AND GE.XAxis.Labeled = cYes THEN%@NL@% DRight% = DRight% + (GP.ValLenX) \ 2%@NL@% END IF%@NL@% %@NL@% DRight% = GP.ChartWid - DRight%%@NL@% %@NL@% %@AB@% ' *** YTIC MARKS%@AE@%%@NL@% %@AB@% ' Finally, adjust the window coordinates for tic marks (if it's not a%@AE@%%@NL@% %@AB@% ' pie chart):%@AE@%%@NL@% IF GE.ChartType <> cPie THEN%@NL@% IF GE.YAxis.Labeled = cYes THEN%@NL@% DLeft% = DRight% - (DRight% - DLeft%) / (1 + cTicSize)%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' *** LEGEND%@AE@%%@NL@% %@AB@% ' Account for the legend if its on the right:%@AE@%%@NL@% IF GE.Legend.Legend = cYes AND GP.MSeries = cYes THEN%@NL@% IF GE.Legend.Place = cRight THEN%@NL@% A% = GE.Legend.LegendWindow.X1%@NL@% DRight% = DRight% - ABS(GP.ChartWid - A%)%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Now we have DLeft%, DRight% we can check if the labels fit on the%@AE@%%@NL@% %@AB@% ' X axis or if we need to put them on two rows:%@AE@%%@NL@% GP.XStagger = cFalse%@NL@% IF GP.XMode = cCategory AND GE.ChartType <> cPie THEN%@NL@% clSetChartFont GE.XAxis.TicFont%@NL@% TicInterval% = (DRight% - DLeft%) \ GP.NVals%@NL@% IF clMaxStrLen%(Cat$(), 1, GP.NVals) + .5 * GFI.MaxWidth > TicInterval% THEN%@NL@% GP.XStagger = cTrue%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If we do have to stagger, check if there is enough space to the%@AE@%%@NL@% %@AB@% ' left and right for long categories. Make adjustments as necessary:%@AE@%%@NL@% IF GP.XStagger THEN%@NL@% LenLeft% = GetGTextLen%(Cat$(1)) + GFI.AvgWidth%@NL@% LenRight% = GetGTextLen%(Cat$(GP.NVals)) + GFI.AvgWidth%@NL@% SizeRight% = cTrue%@NL@% SizeLeft% = cTrue%@NL@% OldRight% = DRight%%@NL@% OldLeft% = DLeft%%@NL@% DO WHILE SizeRight% OR SizeLeft%%@NL@% IF LenRight% - TicInterval% > 2 * (GP.ChartWid - DRight%) AND 2 * (GP.ChartWid - DRight%) < TicInterval% THEN%@NL@% SizeRight% = cTrue%@NL@% ELSE%@NL@% SizeRight% = cFalse%@NL@% END IF%@NL@% IF SizeRight% THEN%@NL@% TicInterval% = (2 * (GP.ChartWid - DLeft%) - LenRight%) \ (2 * GP.NVals - 1)%@NL@% IF LenRight% > 2 * TicInterval% THEN%@NL@% TicInterval% = (GP.ChartWid - DLeft%) / (GP.NVals + .5)%@NL@% END IF%@NL@% DRight% = DLeft% + GP.NVals * TicInterval%%@NL@% END IF%@NL@% IF LenLeft% - TicInterval% > 2 * DLeft% AND 2 * DLeft% < TicInterval% THEN%@NL@% SizeLeft% = cTrue%@NL@% ELSE%@NL@% SizeLeft% = cFalse%@NL@% END IF%@NL@% IF SizeLeft% THEN%@NL@% TicInterval% = (2 * DRight% - LenLeft%) \ (2 * GP.NVals - 1)%@NL@% IF LenLeft% > 2 * TicInterval% THEN%@NL@% TicInterval% = DRight% / (GP.NVals + .5)%@NL@% END IF%@NL@% DLeft% = DRight% - GP.NVals * TicInterval%%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Make sure we haven't gone too far on either side:%@AE@%%@NL@% IF DRight% > OldRight% THEN%@NL@% DRight% = OldRight%%@NL@% END IF%@NL@% IF DLeft% < OldLeft% THEN%@NL@% DLeft% = OldLeft%%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Check if there has been a change, if not, we are done:%@AE@%%@NL@% IF ABS(ChangeRight% - DRight%) + ABS(ChangeLeft% - DLeft%) > 0 THEN%@NL@% EXIT DO%@NL@% ELSE%@NL@% ChangeRight% = DRight%%@NL@% ChangeLeft% = DLeft%%@NL@% END IF%@NL@% LOOP%@NL@% END IF%@NL@% %@NL@% %@AB@% ' *** BOTTOM%@AE@%%@NL@% DBot% = XTitleLayout.TotalSize%@NL@% %@NL@% %@AB@% ' If axis is labeled (and not a pie chart), add row for tic%@AE@%%@NL@% %@AB@% ' labels + 1/2 row spacing:%@AE@%%@NL@% IF GE.XAxis.Labeled = cYes AND GE.ChartType <> cPie THEN%@NL@% IF GP.XStagger = cTrue THEN%@NL@% DBot% = DBot% + 3 * GFI.PixHeight%@NL@% ELSE%@NL@% DBot% = DBot% + 1.5 * GFI.PixHeight%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Make the setting relative to the chart window:%@AE@%%@NL@% DBot% = GP.ChartHgt - 1 - DBot%%@NL@% %@NL@% %@NL@% %@AB@% ' *** XTIC MARKS%@AE@%%@NL@% %@AB@% ' Finally, adjust the window coordinates for tic marks (if it's not a%@AE@%%@NL@% %@AB@% ' pie chart):%@AE@%%@NL@% IF GE.ChartType <> cPie THEN%@NL@% IF GE.XAxis.Labeled = cYes THEN%@NL@% DBot% = DTop% + (DBot% - DTop%) / (1 + cTicSize)%@NL@% END IF%@NL@% %@NL@% END IF%@NL@% %@NL@% %@AB@% ' *** LEGEND%@AE@%%@NL@% %@AB@% ' Account for the legend if its on the bottom:%@AE@%%@NL@% IF GE.Legend.Legend = cYes AND GP.MSeries = cYes THEN%@NL@% IF GE.Legend.Place = cBottom THEN%@NL@% A% = GE.Legend.LegendWindow.Y1%@NL@% DBot% = DBot% - ABS(GP.ChartHgt - A%)%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Install values in the DataWindow definition:%@AE@%%@NL@% GE.DataWindow.X1 = DLeft%%@NL@% GE.DataWindow.X2 = DRight%%@NL@% GE.DataWindow.Y1 = DTop%%@NL@% GE.DataWindow.Y2 = DBot%%@NL@% %@NL@% %@AB@% ' If the window is invalid then set error:%@AE@%%@NL@% IF DLeft% >= DRight% OR DTop% >= DBot% THEN%@NL@% clSetError cBadDataWindow%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clSpaceTics - Calculates TicInterval%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' The TicInterval will be altered%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' The TicInterval is the distance between tic marks in WORLD%@AE@%%@NL@% %@AB@%' coordinates (i.e. the coordinates your data are in)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clSpaceTics%@NL@% SHARED GE AS ChartEnvironment, GP AS GlobalParams%@NL@% SHARED GFI AS FontInfo%@NL@% %@NL@% %@AB@% ' X-Axis:%@AE@%%@NL@% %@AB@% ' Calculate the length of the axis and of the longest tic label. Then,%@AE@%%@NL@% %@AB@% ' use that information to calculate the number of tics that will fit:%@AE@%%@NL@% clSetChartFont GE.XAxis.TicFont%@NL@% AxisLen% = GE.DataWindow.X2 - GE.DataWindow.X1 + 1%@NL@% TicWid% = GP.ValLenX + GFI.MaxWidth%@NL@% clSpaceTicsA GE.XAxis, GP.XMode, AxisLen%, TicWid%%@NL@% %@NL@% %@AB@% ' Y-Axis:%@AE@%%@NL@% %@AB@% ' Same procedure as above:%@AE@%%@NL@% clSetChartFont GE.YAxis.TicFont%@NL@% AxisLen% = GE.DataWindow.Y2 - GE.DataWindow.Y1 + 1%@NL@% TicWid% = 2 * GFI.Ascent%@NL@% clSpaceTicsA GE.YAxis, GP.YMode, AxisLen%, TicWid%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clSpaceTicsA - Figures out TicInterval for an axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Axis - An AxisType variable to space tics for%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' AxisMode%- cCategory or cValue%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' AxisLen% - Length of the axis in pixels%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' The TicInterval value may be changed for an axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' The TicInterval is the distance between tic marks in adjusted world%@AE@%%@NL@% %@AB@%' coordinates (i.e. the coordinates your data are in scaled by%@AE@%%@NL@% %@AB@%' ScaleFactor and adjusted by LogBase if it is a log axis).%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clSpaceTicsA (Axis AS AxisType, AxisMode%, AxisLen%, TicWid%)%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% %@AB@% ' If this is a category axis the tic interval is 1%@AE@%%@NL@% %@AB@% ' divided by the number-of-categories:%@AE@%%@NL@% IF AxisMode% = cCategory THEN%@NL@% Axis.TicInterval = 1 / GP.NVals%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Otherwise, if we're supposed to scale this axis then the tic interval%@AE@%%@NL@% %@AB@% ' depends on how many will fit and some aesthetic considerations:%@AE@%%@NL@% IF Axis.AutoScale = cYes THEN%@NL@% %@NL@% %@AB@% ' Figure which is bigger in absolute value between scale maximum%@AE@%%@NL@% %@AB@% ' and minimum:%@AE@%%@NL@% MaxRange = ABS(Axis.ScaleMax)%@NL@% IF ABS(Axis.ScaleMin) > MaxRange THEN MaxRange = ABS(Axis.ScaleMin)%@NL@% %@NL@% %@AB@% ' Calculate the maximum number of tic marks that will fit:%@AE@%%@NL@% MaxTics% = INT(AxisLen% / TicWid%)%@NL@% %@NL@% %@AB@% ' If the maximum number of tics is one or less set the tic%@AE@%%@NL@% %@AB@% ' interval to the axis range and the number of tics to one:%@AE@%%@NL@% IF MaxTics% <= 1 THEN%@NL@% NumTics% = 1%@NL@% TicInterval = Axis.ScaleMax - Axis.ScaleMin%@NL@% %@NL@% ELSE%@NL@% %@AB@% ' Guess that the tic interval is equal to 1/10th of the order%@AE@%%@NL@% %@AB@% ' of magnitude of the largest of the scale max or min:%@AE@%%@NL@% TicInterval = .1 * 10 ^ INT(LOG(MaxRange) / LOG(10!))%@NL@% %@NL@% %@AB@% ' If this doesn't result in too many tic marks then OK. Otherwise%@AE@%%@NL@% %@AB@% ' multiply the tic interval by 2 and 5 alternatively until the%@AE@%%@NL@% %@AB@% ' number of tic marks falls into the acceptable range.%@AE@%%@NL@% NextStep% = 2%@NL@% ScaleRange = Axis.ScaleMax - Axis.ScaleMin%@NL@% DO%@NL@% NumTics% = -INT(-ScaleRange / TicInterval)%@NL@% IF (NumTics% <= MaxTics%) THEN EXIT DO%@NL@% TicInterval = TicInterval * NextStep%%@NL@% NextStep% = 7 - NextStep%%@NL@% LOOP UNTIL NumTics% <= MaxTics%%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Set Axis.TicInterval and adjust scale maximum and minimum:%@AE@%%@NL@% Axis.TicInterval = TicInterval%@NL@% IF ABS(TicInterval) < 1 THEN%@NL@% Axis.TicDecimals = -INT(-ABS(LOG(1.1 * TicInterval) / LOG(10!)))%@NL@% END IF%@NL@% %@NL@% Axis.ScaleMax = -INT(-Axis.ScaleMax / TicInterval) * TicInterval%@NL@% Axis.ScaleMin = INT(Axis.ScaleMin / TicInterval) * TicInterval%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clTitleXAxis - Draws titles on X axis (AxisTitle and ScaleTitle)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Axis - AxisType variable describing axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' X1% - Left of DataWindow%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' X2% - Right of DataWindow%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' YBoundry% - Top boundry of title block%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clTitleXAxis (Axis AS AxisType, X1%, X2%, YBoundry%)%@NL@% SHARED GFI AS FontInfo%@NL@% SHARED XTitleLayout AS TitleLayout%@NL@% %@NL@% CH% = GFI.PixHeight%@NL@% CW% = GFI.MaxWidth%@NL@% %@NL@% %@AB@% ' Set position of first title:%@AE@%%@NL@% Y% = YBoundry% + XTitleLayout.Top%@NL@% %@NL@% %@AB@% ' Loop through the two titles (AxisTitle and ScaleTitle), printing%@AE@%%@NL@% %@AB@% ' them if they aren't blank:%@AE@%%@NL@% FOR i% = 1 TO 2%@NL@% %@NL@% %@AB@% ' Get the test, color, and justification for the title to be printed:%@AE@%%@NL@% SELECT CASE i%%@NL@% %@NL@% CASE 1: ' AxisTitle%@NL@% Txt$ = Axis.AxisTitle.Title%@NL@% C% = Axis.AxisTitle.TitleColor%@NL@% J% = Axis.AxisTitle.Justify%@NL@% F% = Axis.AxisTitle.TitleFont%@NL@% Lead% = XTitleLayout.Middle%@NL@% %@NL@% CASE 2: ' ScaleTitle%@NL@% Txt$ = Axis.ScaleTitle.Title%@NL@% C% = Axis.ScaleTitle.TitleColor%@NL@% J% = Axis.ScaleTitle.Justify%@NL@% F% = Axis.ScaleTitle.TitleFont%@NL@% Lead% = XTitleLayout.Bottom%@NL@% %@NL@% END SELECT%@NL@% clSetChartFont F%%@NL@% Txt$ = RTRIM$(Txt$)%@NL@% TxtLen% = GetGTextLen(Txt$)%@NL@% %@NL@% %@AB@% ' If the title isn't all blank:%@AE@%%@NL@% IF TxtLen% <> 0 THEN%@NL@% %@NL@% %@AB@% ' Set the title's color:%@AE@%%@NL@% clSetCharColor C%%@NL@% %@NL@% %@AB@% ' Calculate x position of title's first character depending on%@AE@%%@NL@% %@AB@% ' the justification flag:%@AE@%%@NL@% SELECT CASE J%%@NL@% CASE cLeft: X% = X1%%@NL@% CASE cCenter: X% = ((X1% + X2%) - TxtLen%) / 2%@NL@% CASE ELSE: X% = X2% - TxtLen%%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Write out the text:%@AE@%%@NL@% clHPrint X%, Y%, Txt$%@NL@% %@NL@% %@AB@% ' Move down to the next title position:%@AE@%%@NL@% Y% = Y% + GFI.PixHeight + XTitleLayout.Middle%@NL@% %@NL@% END IF%@NL@% %@NL@% NEXT i%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clTitleYAxis - Draws titles on Y axis (AxisTitle and ScaleTitle)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Axis - AxisType variable describing axis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Y1% - Top of DataWindow%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Y2% - Bottom of DataWindow%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clTitleYAxis (Axis AS AxisType, Y1%, Y2%) STATIC%@NL@% SHARED GFI AS FontInfo%@NL@% SHARED YTitleLayout AS TitleLayout%@NL@% %@NL@% %@NL@% %@AB@% ' Set position for first title:%@AE@%%@NL@% X% = YTitleLayout.Top%@NL@% %@NL@% %@AB@% ' Loop through the two titles (AxisTitle and ScaleTitle), printing%@AE@%%@NL@% %@AB@% ' them if they aren't blank:%@AE@%%@NL@% FOR i% = 1 TO 2%@NL@% %@NL@% %@AB@% ' Get the test, color, and justification for the title to be printed:%@AE@%%@NL@% SELECT CASE i%%@NL@% %@NL@% CASE 1: ' AxisTitle%@NL@% Txt$ = Axis.AxisTitle.Title%@NL@% C% = Axis.AxisTitle.TitleColor%@NL@% J% = Axis.AxisTitle.Justify%@NL@% F% = Axis.AxisTitle.TitleFont%@NL@% Lead% = YTitleLayout.TitleOne + YTitleLayout.Middle%@NL@% %@NL@% CASE 2: ' ScaleTitle%@NL@% Txt$ = Axis.ScaleTitle.Title%@NL@% C% = Axis.ScaleTitle.TitleColor%@NL@% J% = Axis.ScaleTitle.Justify%@NL@% F% = Axis.ScaleTitle.TitleFont%@NL@% Lead% = 0%@NL@% %@NL@% END SELECT%@NL@% clSetChartFont F%%@NL@% Txt$ = RTRIM$(Txt$)%@NL@% TxtLen% = GetGTextLen(Txt$)%@NL@% %@NL@% IF TxtLen% <> 0 THEN%@NL@% %@NL@% %@AB@% ' Set title's color:%@AE@%%@NL@% clSetCharColor C%%@NL@% %@NL@% %@AB@% ' Calculate y position of title's first character depending on%@AE@%%@NL@% %@AB@% ' the justification flag:%@AE@%%@NL@% SELECT CASE J%%@NL@% CASE cLeft: Y% = Y2%%@NL@% CASE cCenter: Y% = ((Y1% + Y2%) + TxtLen%) / 2%@NL@% CASE ELSE: Y% = Y1% + (TxtLen% - 1)%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Write out the text:%@AE@%%@NL@% clVPrint X%, Y%, Txt$%@NL@% %@NL@% %@AB@% ' Move to next title position:%@AE@%%@NL@% X% = X% + Lead%%@NL@% %@NL@% END IF%@NL@% %@NL@% NEXT i%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clUnFlagSystem - Sets GP.SysFlag to cNo%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Alters the value of GP.SysFlag%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clUnFlagSystem%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% GP.SysFlag = cNo%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== clVal2Str$ - Converts a single precision value to a string%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' X - The value to convert%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Places% - The number of places after the decimal to produce%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Format% - 1 For normal, other than 1 for exponential%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Returns a string representation of the input number%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION clVal2Str$ (X, Places%, Format%)%@NL@% %@NL@% %@AB@% ' Make a local copy of the value:%@AE@%%@NL@% XX = ABS(X)%@NL@% %@NL@% %@AB@% ' Force format to exponential if that is specified or number is%@AE@%%@NL@% %@AB@% ' bigger than a long integer will hold (2^31-1):%@AE@%%@NL@% IF Format% <> cNormFormat OR XX >= 2 ^ 31 THEN%@NL@% %@NL@% %@AB@% ' For exponential format calculate the exponent that will make%@AE@%%@NL@% %@AB@% ' one decimal to left of decimal place. This is done by truncating%@AE@%%@NL@% %@AB@% ' the log (base 10) of XX:%@AE@%%@NL@% IF XX = 0 THEN ExpX = 0 ELSE ExpX = INT(LOG(XX) / LOG(10))%@NL@% XX = XX / (10 ^ ExpX)%@NL@% %@NL@% %@AB@% ' If no decimals are specified then a number of 9.5x will be%@AE@%%@NL@% %@AB@% ' rounded up to 10 leaving two places to left of decimal so check%@AE@%%@NL@% %@AB@% ' for that and if that occurs divide number by 10 and add 1 to exponent:%@AE@%%@NL@% IF Places% <= 0 AND CLNG(XX) > 9 THEN%@NL@% XX = XX / 10%@NL@% ExpX = ExpX + 1%@NL@% END IF%@NL@% %@NL@% END IF%@NL@% %@NL@% %@AB@% ' If no decimal places are specified then generate a rounded integer:%@AE@%%@NL@% IF Places% <= 0 THEN%@NL@% ValStr$ = LTRIM$(STR$(CLNG(XX)))%@NL@% %@NL@% %@AB@% ' If decimal places are called for, round number to requisite number of%@AE@%%@NL@% %@AB@% ' decimals and generate string:%@AE@%%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' Limit places after decimal to six:%@AE@%%@NL@% DP% = Places%%@NL@% IF DP% > 6 THEN DP% = 6%@NL@% RF% = 10 ^ DP%%@NL@% %@NL@% %@AB@% ' Figure out integer portion:%@AE@%%@NL@% IntX = FIX(XX)%@NL@% %@NL@% %@AB@% ' Round the fractional part to correct number of decimals. If%@AE@%%@NL@% %@AB@% ' the fraction carries to the 1's place in the rounding%@AE@%%@NL@% %@AB@% ' adjust IntX by adding 1:%@AE@%%@NL@% FracX = CLNG((1 + XX - IntX) * RF%)%@NL@% IF FracX >= 2 * RF% THEN%@NL@% IntX = IntX + 1%@NL@% END IF%@NL@% %@NL@% %@AB@% 'Finally, generate the output string:%@AE@%%@NL@% ValStr$ = LTRIM$(STR$(IntX)) + "." + MID$(STR$(FracX), 3)%@NL@% %@NL@% END IF%@NL@% %@NL@% %@AB@% ' Add exponent ending if format is exponent:%@AE@%%@NL@% IF Format% <> cNormFormat OR ABS(X) > 2 ^ 31 THEN%@NL@% ValStr$ = ValStr$ + "E"%@NL@% IF ExpX >= 0 THEN ValStr$ = ValStr$ + "+"%@NL@% ValStr$ = ValStr$ + LTRIM$(STR$(ExpX))%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Add minus sign if appropriate:%@AE@%%@NL@% IF X < 0 AND VAL(ValStr$) <> 0 THEN ValStr$ = "-" + ValStr$%@NL@% clVal2Str$ = ValStr$%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== clVPrint - Prints text vertically on the screen%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' X - X position of lower left of first char (in absolute screen%@AE@%%@NL@% %@AB@%' coordinates)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Y - Y position of lower left of first char (in absolute screen%@AE@%%@NL@% %@AB@%' coordinates)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Txt$ - Text to print%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB clVPrint (X%, Y%, Txt$)%@NL@% %@NL@% %@AB@% ' Map the input coordinates relative to the current viewport:%@AE@%%@NL@% X = PMAP(X%, 2)%@NL@% Y = PMAP(Y%, 3)%@NL@% %@NL@% %@AB@% ' Print text out vertically:%@AE@%%@NL@% SetGTextDir 1%@NL@% TextLen% = OutGText(X, Y, Txt$)%@NL@% SetGTextDir 0%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== DefaultChart - Sets up the ChartEnvironment variable to generate a%@AE@%%@NL@% %@AB@%' default chart of the type and style specified%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ChartType - The chart type desired: 1=Bar, 2=Column, 3=Line,%@AE@%%@NL@% %@AB@%' 4=Scatter, 5=Pie%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ChartStyle - The chart style (depends on type, see README file)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Elements of Env variable are set to default values%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' This subprogram should be called to initialize the ChartEnvironment%@AE@%%@NL@% %@AB@%' variable before a charting routine is called.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB DefaultChart (Env AS ChartEnvironment, ChartType AS INTEGER, ChartStyle AS INTEGER)%@NL@% %@NL@% SHARED DTitle AS TitleType, DWindow AS RegionType%@NL@% SHARED DAxis AS AxisType, DLegend AS LegendType%@NL@% %@NL@% %@AB@% ' Clear any previous chart errors:%@AE@%%@NL@% clClearError%@NL@% %@NL@% %@AB@% ' Check initialization:%@AE@%%@NL@% clChkInit%@NL@% %@NL@% %@AB@% ' Put type in environment:%@AE@%%@NL@% IF ChartType < 1 OR ChartType > 5 THEN%@NL@% clSetError cBadType%@NL@% EXIT SUB%@NL@% END IF%@NL@% Env.ChartType = ChartType%@NL@% %@NL@% %@AB@% ' Put chart style in environment:%@AE@%%@NL@% IF ChartStyle < 1 OR ChartStyle > 2 THEN%@NL@% clSetError cBadStyle%@NL@% ChartStyle = 1%@NL@% END IF%@NL@% Env.ChartStyle = ChartStyle%@NL@% %@NL@% %@AB@% ' Set elements of chart to default:%@AE@%%@NL@% Env.DataFont = 1%@NL@% %@NL@% Env.MainTitle = DTitle%@NL@% Env.SubTitle = DTitle%@NL@% %@NL@% Env.ChartWindow = DWindow ' Chart window is default window%@NL@% Env.ChartWindow.Border = cYes ' with a border.%@NL@% %@NL@% Env.DataWindow = DWindow%@NL@% %@NL@% Env.XAxis = DAxis%@NL@% Env.YAxis = DAxis%@NL@% %@NL@% Env.Legend = DLegend%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== GetPaletteDef - Changes an entry in the internal palette%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' C%() - Color palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' S%() - Style palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' P$() - Pattern palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Char%() - Plot character palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' B%() - Border style palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Chart error may be set%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB GetPaletteDef (C() AS INTEGER, s() AS INTEGER, P$(), Char() AS INTEGER, B() AS INTEGER)%@NL@% SHARED GP AS GlobalParams%@NL@% SHARED PaletteC%(), PaletteS%(), PaletteP$(), PaletteCh%(), PaletteB%()%@NL@% %@NL@% %@AB@% ' Reset any outstanding errors:%@AE@%%@NL@% clClearError%@NL@% %@NL@% %@AB@% ' Make sure palettes have been initialized:%@AE@%%@NL@% IF NOT GP.PaletteSet THEN%@NL@% clSetError cPalettesNotSet%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Make sure the user's palettes are the correct size:%@AE@%%@NL@% clChkPalettes C(), s(), P$(), Char(), B()%@NL@% IF (ChartErr <> 0) THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Replace the palette values with input variables (making sure that%@AE@%%@NL@% %@AB@% ' the color and character numbers are in range):%@AE@%%@NL@% FOR N% = 0 TO cPalLen%@NL@% C(N%) = PaletteC%(N%)%@NL@% s(N%) = PaletteS%(N%)%@NL@% P$(N%) = PaletteP$(N%)%@NL@% Char(N%) = PaletteCh%(N%)%@NL@% B(N%) = PaletteB%(N%)%@NL@% NEXT N%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== GetPattern - Returns a pattern from among 3 pattern palettes%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Bits% - The number of bits per pixel for the pattern%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' PatternNum% - The pattern number to return%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Returns a pattern tile from the list below.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' Below are three pattern sets. There is a set of patterns for one, two%@AE@%%@NL@% %@AB@%' and eight bit-per-pixel screens.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION GetPattern$ (Bits%, PatternNum%)%@NL@% %@NL@% SELECT CASE Bits%%@NL@% %@NL@% %@AB@% ' One bit-per-pixel patterns:%@AE@%%@NL@% CASE 1:%@NL@% SELECT CASE PatternNum%%@NL@% CASE 1: P$ = CHR$(&HFF)%@NL@% CASE 2: P$ = CHR$(&H55) + CHR$(&HAA)%@NL@% CASE 3: P$ = CHR$(&H33) + CHR$(&HCC)%@NL@% CASE 4: P$ = CHR$(&H0) + CHR$(&HE7)%@NL@% CASE 5: P$ = CHR$(&H7F) + CHR$(&HBF) + CHR$(&HDF) + CHR$(&HEF) + CHR$(&HF7) + CHR$(&HFB) + CHR$(&HFD) + CHR$(&HFE)%@NL@% CASE 6: P$ = CHR$(&H7E) + CHR$(&HBD) + CHR$(&HDB) + CHR$(&HE7) + CHR$(&HE7) + CHR$(&HDB) + CHR$(&HBD) + CHR$(&H7E)%@NL@% CASE 7: P$ = CHR$(&HFE) + CHR$(&HFD) + CHR$(&HFB) + CHR$(&HF7) + CHR$(&HEF) + CHR$(&HDF) + CHR$(&HBF) + CHR$(&H7F)%@NL@% CASE 8: P$ = CHR$(&H33) + CHR$(&HCC) + CHR$(&HCC) + CHR$(&H33)%@NL@% CASE 9: P$ = CHR$(&H0) + CHR$(&HFD) + CHR$(&H0) + CHR$(&HF7) + CHR$(&H0) + CHR$(&HDF) + CHR$(&H0) + CHR$(&H7F)%@NL@% CASE 10: P$ = CHR$(&HF) + CHR$(&H87) + CHR$(&HC3) + CHR$(&HE1) + CHR$(&HF0) + CHR$(&H78) + CHR$(&H3C) + CHR$(&H1E)%@NL@% CASE 11: P$ = CHR$(&HA8) + CHR$(&H51) + CHR$(&HA2) + CHR$(&H45) + CHR$(&H8A) + CHR$(&H15) + CHR$(&H2A) + CHR$(&H54)%@NL@% CASE 12: P$ = CHR$(&HAA) + CHR$(&H55) + CHR$(&H0) + CHR$(&H0) + CHR$(&HAA) + CHR$(&H55) + CHR$(&H0) + CHR$(&H0)%@NL@% CASE 13: P$ = CHR$(&H2A) + CHR$(&H15) + CHR$(&H8A) + CHR$(&H45) + CHR$(&HA2) + CHR$(&H51) + CHR$(&HA8) + CHR$(&H54)%@NL@% CASE 14: P$ = CHR$(&H88) + CHR$(&H0) + CHR$(&H22) + CHR$(&H0) + CHR$(&H88) + CHR$(&H0) + CHR$(&H22) + CHR$(&H0)%@NL@% CASE 15: P$ = CHR$(&HFF) + CHR$(&H0) + CHR$(&HFF) + CHR$(&H0) + CHR$(&HFF) + CHR$(&H0) + CHR$(&HFF) + CHR$(&H0)%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Two bit-per-pixel patterns:%@AE@%%@NL@% CASE 2:%@NL@% SELECT CASE PatternNum%%@NL@% CASE 1: P$ = CHR$(&HFF)%@NL@% CASE 2: P$ = CHR$(&HCC) + CHR$(&H33)%@NL@% CASE 3: P$ = CHR$(&HF0) + CHR$(&H3C) + CHR$(&HF) + CHR$(&HC3)%@NL@% CASE 4: P$ = CHR$(&HF0) + CHR$(&HF)%@NL@% CASE 5: P$ = CHR$(&H3) + CHR$(&HC) + CHR$(&H30) + CHR$(&HC0)%@NL@% CASE 6: P$ = CHR$(&HFF) + CHR$(&HC)%@NL@% CASE 7: P$ = CHR$(&HF0) + CHR$(&HF0) + CHR$(&HF) + CHR$(&HF)%@NL@% CASE 8: P$ = CHR$(&HFF) + CHR$(&HC) + CHR$(&H30) + CHR$(&HC0)%@NL@% CASE 9: P$ = CHR$(&HC0) + CHR$(&H30) + CHR$(&HC) + CHR$(&H3)%@NL@% CASE 10: P$ = CHR$(&HC0) + CHR$(&HC)%@NL@% CASE 11: P$ = CHR$(&HCC) + CHR$(&HCC) + CHR$(&H33) + CHR$(&H33)%@NL@% CASE 12: P$ = CHR$(&HCC) + CHR$(&HCC) + CHR$(&H0) + CHR$(&H0)%@NL@% CASE 13: P$ = CHR$(&HFF) + CHR$(&H33) + CHR$(&H33)%@NL@% CASE 14: P$ = CHR$(&HFF) + CHR$(&H0)%@NL@% CASE 15: P$ = CHR$(&HCC) + CHR$(&H30) + CHR$(&H0)%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Eight bit-per-pixel patterns:%@AE@%%@NL@% CASE 8:%@NL@% P$ = CHR$(&HFF)%@NL@% %@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Return the pattern as the value of the function:%@AE@%%@NL@% GetPattern$ = P$%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== LabelChartH - Prints horizontal text on a chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' X - Horizontal position of text relative to the left of%@AE@%%@NL@% %@AB@%' the Chart window (in pixels)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Y - Vertical position of text relative to the top of%@AE@%%@NL@% %@AB@%' the Chart window (in pixels)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Font% - Font number to use for the text%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' TxtColor - Color number (in internal color palette) for text%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' TxtString$ - String variable containing text to print%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB LabelChartH (Env AS ChartEnvironment, X AS INTEGER, Y AS INTEGER, Font AS INTEGER, TxtColor AS INTEGER, TxtString$)%@NL@% %@NL@% %@AB@% ' Reset any outstanding errors:%@AE@%%@NL@% clClearError%@NL@% %@NL@% %@AB@% ' Check initialization and fonts:%@AE@%%@NL@% clChkInit%@NL@% clChkFonts%@NL@% IF ChartErr >= 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Select ChartWindow as reference viewport:%@AE@%%@NL@% clSelectChartWindow%@NL@% %@NL@% %@AB@% ' Select font and set color:%@AE@%%@NL@% SelectFont Font%@NL@% clSetCharColor TxtColor%@NL@% %@NL@% %@AB@% ' Call internal print routine to print text:%@AE@%%@NL@% clHPrint X, Y, TxtString$%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== LabelChartV - Prints vertical text on a chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Env - A ChartEnvironment variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' X - Horizontal position of text relative to the left of%@AE@%%@NL@% %@AB@%' the Chart window (in pixels)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Y - Vertical position of text relative to the top of%@AE@%%@NL@% %@AB@%' the Chart window (in pixels)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Font% - Font number to use for the text%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' TxtColor - Color number (in internal color palette) for text%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' TxtString$ - String variable containing text to print%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB LabelChartV (Env AS ChartEnvironment, X AS INTEGER, Y AS INTEGER, Font AS INTEGER, TxtColor AS INTEGER, TxtString$)%@NL@% %@NL@% %@AB@% ' Reset any outstanding errors:%@AE@%%@NL@% clClearError%@NL@% %@NL@% %@AB@% ' Check initialization and fonts:%@AE@%%@NL@% clChkInit%@NL@% clChkFonts%@NL@% IF ChartErr >= 100 THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Select ChartWindow as reference viewport:%@AE@%%@NL@% clSelectChartWindow%@NL@% %@NL@% %@AB@% ' Select font and set color:%@AE@%%@NL@% SelectFont Font%%@NL@% clSetCharColor TxtColor%@NL@% %@NL@% %@AB@% ' Call internal print routine to print text:%@AE@%%@NL@% clVPrint X, Y, TxtString$%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== MakeChartPattern$ - Makes a pattern given reference pattern and%@AE@%%@NL@% %@AB@%' foreground and background colors%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' RefPattern$ - Reference pattern%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' FG% - Foreground color%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' BG% - Background color%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Returns a pattern in standard PAINT format%@AE@%%@NL@% %@AB@%' Sets error cBadScreen if ChartScreen hasn't been called%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION MakeChartPattern$ (RefPattern$, FG AS INTEGER, BG AS INTEGER)%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% %@AB@% ' Reset any outstanding errors:%@AE@%%@NL@% clClearError%@NL@% %@NL@% %@AB@% ' Check initialization:%@AE@%%@NL@% clChkInit%@NL@% IF ChartErr >= 100 THEN EXIT FUNCTION%@NL@% IF NOT GP.PaletteSet THEN%@NL@% clSetError cBadScreen%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% FGColor% = clMap2Attrib%(FG%)%@NL@% BGColor% = clMap2Attrib%(BG%)%@NL@% %@NL@% %@AB@% ' Screens 1, 2, 11 and 13 are 1 bit plane modes and require one method%@AE@%%@NL@% %@AB@% ' of generating pattern tiles. The other modes supported are multiple%@AE@%%@NL@% %@AB@% ' bit plane modes and require another method of generating pattern%@AE@%%@NL@% %@AB@% ' tiles. Select the appropriate method for this screen mode:%@AE@%%@NL@% SELECT CASE GP.PaletteScrn%@NL@% %@NL@% %@AB@% ' One bit plane modes:%@AE@%%@NL@% CASE 1, 2, 11, 13: SinglePlane% = cTrue%@NL@% CASE ELSE: SinglePlane% = cFalse%@NL@% %@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Do foreground part of pattern:%@AE@%%@NL@% IF SinglePlane% THEN%@NL@% FGPattern$ = clBuildBitP$(GP.PaletteBits, FGColor%, RefPattern$)%@NL@% ELSE%@NL@% FGPattern$ = clBuildPlaneP$(GP.PaletteBits, FGColor%, RefPattern$)%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Do background part of pattern (if background color is black then%@AE@%%@NL@% %@AB@% ' the pattern is just the foreground pattern):%@AE@%%@NL@% IF BGColor% = 0 THEN%@NL@% Pattern$ = FGPattern$%@NL@% %@NL@% ELSE%@NL@% %@AB@% ' Background reference pattern is inverted foreground pattern:%@AE@%%@NL@% BGPattern$ = ""%@NL@% FOR i% = 1 TO LEN(RefPattern$)%@NL@% BGPattern$ = BGPattern$ + CHR$(ASC(MID$(RefPattern$, i%, 1)) XOR &HFF)%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' Build the corresponding PAINT style pattern:%@AE@%%@NL@% IF SinglePlane% THEN%@NL@% BGPattern$ = clBuildBitP$(GP.PaletteBits, BGColor%, BGPattern$)%@NL@% ELSE%@NL@% BGPattern$ = clBuildPlaneP$(GP.PaletteBits, BGColor%, BGPattern$)%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Put foreground and background patterns back together:%@AE@%%@NL@% Pattern$ = ""%@NL@% FOR i% = 1 TO LEN(FGPattern$)%@NL@% Pattern$ = Pattern$ + CHR$(ASC(MID$(FGPattern$, i%, 1)) OR ASC(MID$(BGPattern$, i%, 1)))%@NL@% NEXT i%%@NL@% %@NL@% END IF%@NL@% %@NL@% MakeChartPattern$ = Pattern$%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== ResetPaletteDef - Resets charting palettes for last screen%@AE@%%@NL@% %@AB@%' mode set with ChartScreen.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB ResetPaletteDef%@NL@% SHARED GP AS GlobalParams%@NL@% %@NL@% %@AB@% ' Clear outstanding errors:%@AE@%%@NL@% clClearError%@NL@% %@NL@% %@AB@% ' Check initialization:%@AE@%%@NL@% clChkInit%@NL@% %@NL@% %@AB@% ' Make sure that ChartScreen has been called at least once:%@AE@%%@NL@% IF NOT GP.PaletteSet THEN%@NL@% clSetError cBadScreen%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Now rebuild the palette with the last set screen mode:%@AE@%%@NL@% clBuildPalette GP.PaletteScrn, GP.PaletteBits%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== SetPaletteDef - Changes an entry in the internal palette%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' C%() - Color palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' S%() - Style palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' P$() - Pattern palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Char%() - Plot character palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' B%() - Border style palette array%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Internal chart palettes may be modified or ChartErr set%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB SetPaletteDef (C() AS INTEGER, s() AS INTEGER, P$(), Char() AS INTEGER, B() AS INTEGER)%@NL@% SHARED PaletteC%(), PaletteS%(), PaletteP$(), PaletteCh%(), PaletteB%()%@NL@% %@NL@% %@AB@% ' Reset any outstanding errors and check that palettes are dimesioned%@AE@%%@NL@% %@AB@% ' correctly:%@AE@%%@NL@% clClearError%@NL@% clChkPalettes C(), s(), P$(), Char(), B()%@NL@% IF (ChartErr <> 0) THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' Check initialization:%@AE@%%@NL@% clChkInit%@NL@% %@NL@% %@AB@% ' Replace the palette values with input variables (making sure that%@AE@%%@NL@% %@AB@% ' the color and character numbers are in range):%@AE@%%@NL@% FOR N% = 0 TO cPalLen%@NL@% PaletteC%(N%) = clMap2Attrib%(C%(N%))%@NL@% PaletteS%(N%) = s(N%)%@NL@% PaletteP$(N%) = P$(N%)%@NL@% PaletteCh%(N%) = ABS(Char(N%)) MOD (cMaxChars + 1)%@NL@% PaletteB%(N%) = B(N%)%@NL@% NEXT N%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%CHRTDEM1.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\CHRTDEM1.BAS%@AE@%%@NL@% %@NL@% %@AB@%' CHRTDEM1.BAS - second module of the CHRTB demonstration program.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Copyright (C) 1989, Microsoft Corporation%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Main module - CHRTDEMO.BAS%@AE@%%@NL@% %@AB@%' Include files - CHRTDEMO.BI%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'$INCLUDE: 'chrtdemo.bi'%@AE@%%@NL@% %@NL@% %@AB@%'local subs%@AE@%%@NL@% DECLARE SUB ChangeStyle ()%@NL@% %@NL@% DEFINT A-Z%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ChangeAxis%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Allows user to view and change attributes of either%@AE@%%@NL@% %@AB@%' chart axis.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: title$ - window title%@AE@%%@NL@% %@AB@%' axis - X or Y axis variable%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ChangeAxis (title$, axis AS AxisType)%@NL@% %@NL@% DIM colorBox AS ListBox%@NL@% DIM styleBox AS ListBox%@NL@% DIM fontBox AS ListBox%@NL@% %@NL@% %@AB@% ' set up color list box%@AE@%%@NL@% colorBox.scrollButton = 2%@NL@% colorBox.areaButton = 3%@NL@% colorBox.listLen = numColors%@NL@% colorBox.topRow = 3%@NL@% colorBox.botRow = 16%@NL@% colorBox.leftCol = 4%@NL@% colorBox.rightCol = 18%@NL@% colorBox.listPos = axis.AxisColor + 1%@NL@% %@NL@% %@AB@% ' set up border style list box%@AE@%%@NL@% styleBox.scrollButton = 5%@NL@% styleBox.areaButton = 6%@NL@% styleBox.listLen = MAXSTYLES%@NL@% styleBox.topRow = 5%@NL@% styleBox.botRow = 16%@NL@% styleBox.leftCol = 24%@NL@% styleBox.rightCol = 40%@NL@% styleBox.listPos = axis.GridStyle%@NL@% %@NL@% %@AB@% ' set up font list box%@AE@%%@NL@% fontBox.scrollButton = 8%@NL@% fontBox.areaButton = 9%@NL@% fontBox.listLen = numFonts%@NL@% fontBox.topRow = 5%@NL@% fontBox.botRow = 9%@NL@% fontBox.leftCol = 46%@NL@% fontBox.rightCol = 65%@NL@% fontBox.listPos = axis.TicFont%@NL@% %@NL@% %@AB@% ' open window for display%@AE@%%@NL@% winRow = 4%@NL@% winCol = 6%@NL@% WindowOpen 1, winRow, winCol, 22, 73, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 2, title$%@NL@% WindowBox 1, 2, 17, 20%@NL@% WindowLocate 2, 4%@NL@% WindowPrint 2, "Axis Color:"%@NL@% WindowBox 1, 22, 17, 42%@NL@% WindowLocate 4, 24%@NL@% WindowPrint 2, "Grid Style:"%@NL@% WindowBox 1, 44, 17, 67%@NL@% WindowLocate 4, 46%@NL@% WindowPrint 2, "Label Font:"%@NL@% WindowLocate 10, 46%@NL@% WindowPrint 2, "Range Type:"%@NL@% WindowBox 11, 46, 16, 65%@NL@% WindowLocate 14, 48%@NL@% WindowPrint 2, "Log Base:"%@NL@% WindowBox 13, 57, 15, 63%@NL@% WindowLine 18%@NL@% %@NL@% %@AB@% ' create list boxes%@AE@%%@NL@% CreateListBox colors$(), colorBox, 0%@NL@% CreateListBox styles$(), styleBox, 0%@NL@% CreateListBox fonts$(), fontBox, 0%@NL@% %@NL@% %@AB@% ' open control buttons%@AE@%%@NL@% ButtonOpen 4, 1, "Display Grid", 2, 24, 0, 0, 2%@NL@% ButtonOpen 7, 1, "Display Labels", 2, 46, 0, 0, 2%@NL@% ButtonOpen 10, 1, "Lin", 12, 48, 0, 0, 3%@NL@% ButtonOpen 11, 1, "Log", 12, 57, 0, 0, 3%@NL@% ButtonOpen 12, 2, "OK ", 19, 10, 0, 0, 1%@NL@% ButtonOpen 13, 1, "Cancel ", 19, 26, 0, 0, 1%@NL@% ButtonOpen 14, 1, "Axis Title ", 19, 46, 0, 0, 1%@NL@% %@NL@% %@AB@% ' edit field for log base%@AE@%%@NL@% EditFieldOpen 1, LTRIM$(STR$(axis.LogBase)), 14, 58, 0, 7, 5, 20%@NL@% %@NL@% %@NL@% currButton = 3 ' start with cursor on first button (Autoscale)%@NL@% currEditField = 0%@NL@% %@NL@% optionButton = axis.RangeType + 9 ' set proper state for buttons%@NL@% ButtonToggle optionButton%@NL@% IF axis.Labeled THEN ButtonToggle 7%@NL@% IF axis.Grid THEN ButtonToggle 4%@NL@% %@NL@% pushButton = 12 ' active command button%@NL@% %@NL@% %@AB@% ' window control loop%@AE@%%@NL@% finished = FALSE%@NL@% WHILE NOT finished%@NL@% WindowDo currButton, currEditField ' wait for event%@NL@% SELECT CASE Dialog(0)%@NL@% CASE 1 ' button pressed%@NL@% currButton = Dialog(1)%@NL@% SELECT CASE currButton%@NL@% CASE 4, 7%@NL@% ButtonToggle currButton%@NL@% currEditField = 0%@NL@% CASE 10, 11%@NL@% ButtonToggle optionButton%@NL@% optionButton = currButton%@NL@% ButtonToggle optionButton%@NL@% currEditField = 0%@NL@% CASE 2, 3%@NL@% currEditField = 0%@NL@% ScrollList colors$(), colorBox, currButton, 1, 0, winRow, winCol%@NL@% currButton = 3%@NL@% CASE 5, 6%@NL@% currEditField = 0%@NL@% ScrollList styles$(), styleBox, currButton, 1, 0, winRow, winCol%@NL@% currButton = 6%@NL@% CASE 8, 9%@NL@% currEditField = 0%@NL@% ScrollList fonts$(), fontBox, currButton, 1, 0, winRow, winCol%@NL@% currButton = 9%@NL@% CASE 12, 13%@NL@% pushButton = currButton%@NL@% finished = TRUE%@NL@% CASE 14%@NL@% currEditField = 0%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% ChangeTitle 2, title$ + " Title", axis.AxisTitle, 6, 14%@NL@% END SELECT%@NL@% CASE 2 ' edit field%@NL@% currEditField = 1%@NL@% currButton = 0%@NL@% CASE 6 ' enter%@NL@% SELECT CASE pushButton%@NL@% CASE 12, 13: finished = TRUE%@NL@% CASE 14: ChangeTitle 2, title$ + " Title", axis.AxisTitle, 6, 14%@NL@% END SELECT%@NL@% currButton = pushButton%@NL@% CASE 7 ' tab%@NL@% SELECT CASE currButton%@NL@% CASE 0:%@NL@% currEditField = 0%@NL@% currButton = 12%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% CASE 2, 3: currButton = 4%@NL@% CASE 4: currButton = 6%@NL@% CASE 5, 6: currButton = 7%@NL@% CASE 7: currButton = 9%@NL@% CASE 8, 9: currButton = optionButton%@NL@% CASE 10, 11:%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% CASE 12, 13:%@NL@% currButton = currButton + 1%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% CASE 14:%@NL@% ButtonSetState currButton, 1%@NL@% pushButton = 12%@NL@% ButtonSetState pushButton, 2%@NL@% currButton = 3%@NL@% END SELECT%@NL@% CASE 8 ' back tab%@NL@% SELECT CASE currButton%@NL@% CASE 0:%@NL@% currEditField = 0%@NL@% currButton = optionButton%@NL@% CASE 2, 3:%@NL@% currButton = 14%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% CASE 4: currButton = 3%@NL@% CASE 5, 6: currButton = 4%@NL@% CASE 7: currButton = 6%@NL@% CASE 8, 9: currButton = 7%@NL@% CASE 10, 11: currButton = 9%@NL@% CASE 12:%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% CASE 13, 14:%@NL@% currButton = currButton - 1%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% END SELECT%@NL@% CASE 9 ' escape%@NL@% pushButton = 13%@NL@% finished = TRUE%@NL@% CASE 10, 12 ' up, left arrow%@NL@% SELECT CASE currButton%@NL@% CASE 4, 7: ButtonSetState currButton, 2%@NL@% CASE 2, 3: ScrollList colors$(), colorBox, currButton, 2, 0, winRow, winCol%@NL@% CASE 5, 6: ScrollList styles$(), styleBox, currButton, 2, 0, winRow, winCol%@NL@% CASE 8, 9: ScrollList fonts$(), fontBox, currButton, 2, 0, winRow, winCol%@NL@% CASE 10, 11:%@NL@% ButtonToggle currButton%@NL@% currButton = 21 - currButton%@NL@% optionButton = currButton%@NL@% ButtonToggle optionButton%@NL@% END SELECT%@NL@% CASE 11, 13 ' down, right arrow%@NL@% SELECT CASE currButton%@NL@% CASE 1, 4, 7: ButtonSetState currButton, 1%@NL@% CASE 2, 3: ScrollList colors$(), colorBox, currButton, 3, 0, winRow, winCol%@NL@% CASE 5, 6: ScrollList styles$(), styleBox, currButton, 3, 0, winRow, winCol%@NL@% CASE 8, 9: ScrollList fonts$(), fontBox, currButton, 3, 0, winRow, winCol%@NL@% CASE 10, 11:%@NL@% ButtonToggle currButton%@NL@% currButton = 21 - currButton%@NL@% optionButton = currButton%@NL@% ButtonToggle optionButton%@NL@% END SELECT%@NL@% CASE 14 ' space bar%@NL@% SELECT CASE currButton%@NL@% CASE 1, 4, 7: ButtonToggle currButton%@NL@% CASE 12, 13: finished = TRUE%@NL@% CASE 14: ChangeTitle 2, title$ + " Title", axis.AxisTitle, 6, 14%@NL@% END SELECT%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' error checking on log base before exiting%@AE@%%@NL@% IF finished AND pushButton = 12 THEN%@NL@% IF VAL(EditFieldInquire(1)) <= 0 THEN%@NL@% PrintError " Log base must be greater than zero."%@NL@% currEditField = 1%@NL@% currButton = 0%@NL@% finished = FALSE%@NL@% ELSEIF VAL(EditFieldInquire(1)) = 1 THEN%@NL@% PrintError " Log base cannot equal one. Overflow results."%@NL@% currEditField = 1%@NL@% currButton = 0%@NL@% finished = FALSE%@NL@% END IF%@NL@% END IF%@NL@% WEND%@NL@% %@NL@% %@AB@% ' if not canceled then assign and return new values%@AE@%%@NL@% IF pushButton = 12 THEN%@NL@% IF setNum > 0 THEN chartChanged = TRUE%@NL@% %@NL@% axis.LogBase = VAL(EditFieldInquire(1))%@NL@% axis.Grid = (ButtonInquire(4) = 2)%@NL@% axis.Labeled = (ButtonInquire(7) = 2)%@NL@% axis.RangeType = optionButton - 9%@NL@% axis.AxisColor = colorBox.listPos - 1%@NL@% axis.ScaleTitle.TitleColor = axis.AxisTitle.TitleColor%@NL@% axis.ScaleTitle.Justify = axis.AxisTitle.Justify%@NL@% axis.GridStyle = styleBox.listPos%@NL@% axis.TicFont = fontBox.listPos%@NL@% END IF%@NL@% %@NL@% WindowClose 1%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ChangeChartType%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Changes chart type based on menu selection and%@AE@%%@NL@% %@AB@%' allows the user access to changing the chart style.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: ctype - new chart type%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ChangeChartType (ctype)%@NL@% %@NL@% %@AB@% 'change type if user selected a different type%@AE@%%@NL@% IF CEnv.ChartType <> ctype THEN%@NL@% IF setNum > 0 THEN chartChanged = TRUE%@NL@% %@NL@% %@AB@% ' reset chosen type%@AE@%%@NL@% MenuItemToggle GALLERYTITLE, CEnv.ChartType%@NL@% %@AB@% ' reset other affected menu items%@AE@%%@NL@% IF CEnv.ChartType = cPie THEN%@NL@% MenuSetState CHARTTITLE, 4, 1%@NL@% MenuSetState CHARTTITLE, 5, 1%@NL@% MenuSetState TITLETITLE, 3, 1%@NL@% MenuSetState TITLETITLE, 4, 1%@NL@% END IF%@NL@% %@NL@% CEnv.ChartType = ctype%@NL@% %@NL@% %@AB@% 'if new type is pie then turn off some items%@AE@%%@NL@% IF CEnv.ChartType = cPie THEN%@NL@% MenuSetState CHARTTITLE, 4, 0%@NL@% MenuSetState CHARTTITLE, 5, 0%@NL@% MenuSetState TITLETITLE, 3, 0%@NL@% MenuSetState TITLETITLE, 4, 0%@NL@% END IF%@NL@% %@NL@% %@AB@% ' set type in menu bar%@AE@%%@NL@% MenuItemToggle GALLERYTITLE, CEnv.ChartType%@NL@% END IF%@NL@% %@NL@% %@AB@% ' allow user to change chart style%@AE@%%@NL@% ChangeStyle%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ChangeLegend%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Allows user to view and modify all attributes of the chart%@AE@%%@NL@% %@AB@%' legend%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ChangeLegend%@NL@% %@NL@% DIM fgColorBox AS ListBox%@NL@% DIM fontBox AS ListBox%@NL@% %@NL@% %@AB@% ' set up foreground color box%@AE@%%@NL@% fgColorBox.scrollButton = 6%@NL@% fgColorBox.areaButton = 7%@NL@% fgColorBox.listLen = numColors%@NL@% fgColorBox.topRow = 3%@NL@% fgColorBox.botRow = 10%@NL@% fgColorBox.leftCol = 27%@NL@% fgColorBox.rightCol = 41%@NL@% fgColorBox.listPos = CEnv.Legend.TextColor + 1%@NL@% %@NL@% %@AB@% ' set up font box%@AE@%%@NL@% fontBox.scrollButton = 8%@NL@% fontBox.areaButton = 9%@NL@% fontBox.listLen = numFonts%@NL@% fontBox.topRow = 3%@NL@% fontBox.botRow = 10%@NL@% fontBox.leftCol = 43%@NL@% fontBox.rightCol = 57%@NL@% fontBox.listPos = CEnv.Legend.TextFont%@NL@% %@NL@% %@AB@% ' set up display window%@AE@%%@NL@% winRow = 6%@NL@% winCol = 10%@NL@% WindowOpen 1, winRow, winCol, 18, 69, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 2, "Chart Legend"%@NL@% WindowBox 1, 2, 11, 23%@NL@% WindowLocate 5, 4%@NL@% WindowPrint 2, "Location:"%@NL@% WindowBox 6, 4, 10, 21%@NL@% WindowBox 1, 25, 11, 59%@NL@% WindowLocate 2, 27%@NL@% WindowPrint 2, "Text Color:"%@NL@% WindowLocate 2, 43%@NL@% WindowPrint 2, "Text Font:"%@NL@% WindowLine 12%@NL@% %@NL@% %@AB@% ' create list boxes%@AE@%%@NL@% CreateListBox colors$(), fgColorBox, 0%@NL@% CreateListBox fonts$(), fontBox, 0%@NL@% %@NL@% %@AB@% ' open command buttons%@AE@%%@NL@% ButtonOpen 1, 1, "Display Legend", 2, 4, 0, 0, 2%@NL@% ButtonOpen 2, 1, "Autosize", 3, 4, 0, 0, 2%@NL@% ButtonOpen 3, 1, "Overlay", 7, 6, 0, 0, 3%@NL@% ButtonOpen 4, 1, "Bottom", 8, 6, 0, 0, 3%@NL@% ButtonOpen 5, 1, "Right", 9, 6, 0, 0, 3%@NL@% ButtonOpen 10, 2, "OK ", 13, 8, 0, 0, 1%@NL@% ButtonOpen 11, 1, "Cancel ", 13, 21, 0, 0, 1%@NL@% ButtonOpen 12, 1, "Legend Window ", 13, 38, 0, 0, 1%@NL@% %@NL@% currButton = 1 ' start with cursor on first button%@NL@% %@NL@% %@AB@% ' set button states based on current values%@AE@%%@NL@% optionButton = CEnv.Legend.Place + 2%@NL@% ButtonToggle optionButton%@NL@% IF CEnv.Legend.Legend THEN ButtonToggle 1%@NL@% IF CEnv.Legend.AutoSize THEN ButtonToggle 2%@NL@% pushButton = 10%@NL@% %@NL@% %@AB@% ' window control loop%@AE@%%@NL@% finished = FALSE%@NL@% WHILE NOT finished%@NL@% WindowDo currButton, 0 ' wait for event%@NL@% SELECT CASE Dialog(0)%@NL@% CASE 1 ' button pressed%@NL@% currButton = Dialog(1)%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2: ButtonToggle currButton%@NL@% CASE 3, 4, 5%@NL@% ButtonToggle optionButton%@NL@% optionButton = currButton%@NL@% ButtonToggle optionButton%@NL@% CASE 6, 7:%@NL@% ScrollList colors$(), fgColorBox, currButton, 1, 0, winRow, winCol%@NL@% currButton = 7%@NL@% CASE 8, 9:%@NL@% ScrollList fonts$(), fontBox, currButton, 1, 0, winRow, winCol%@NL@% currButton = 9%@NL@% CASE 10, 11%@NL@% pushButton = currButton%@NL@% finished = TRUE%@NL@% CASE 12%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = 12%@NL@% ChangeWindow 2, "Legend Window", CEnv.Legend.LegendWindow%@NL@% END SELECT%@NL@% CASE 6 ' enter%@NL@% IF pushButton <> 12 THEN%@NL@% finished = TRUE%@NL@% ELSE%@NL@% ChangeWindow 2, "Legend Window", CEnv.Legend.LegendWindow%@NL@% END IF%@NL@% CASE 7 ' tab%@NL@% SELECT CASE currButton%@NL@% CASE 1: currButton = 2%@NL@% CASE 2: currButton = optionButton%@NL@% CASE 3, 4, 5: currButton = 7%@NL@% CASE 6, 7: currButton = 9%@NL@% CASE 8, 9:%@NL@% currButton = 10%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% CASE 10, 11:%@NL@% currButton = currButton + 1%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% CASE 12:%@NL@% ButtonSetState currButton, 1%@NL@% pushButton = 10%@NL@% ButtonSetState pushButton, 2%@NL@% currButton = 1%@NL@% END SELECT%@NL@% CASE 8 ' back tab%@NL@% SELECT CASE currButton%@NL@% CASE 1:%@NL@% currButton = 12%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% CASE 2: currButton = 1%@NL@% CASE 3, 4, 5: currButton = 2%@NL@% CASE 6, 7: currButton = optionButton%@NL@% CASE 8, 9: currButton = 7%@NL@% CASE 10: currButton = 9%@NL@% CASE 11, 12:%@NL@% currButton = currButton - 1%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% END SELECT%@NL@% CASE 9 ' escape%@NL@% pushButton = 11%@NL@% finished = TRUE%@NL@% CASE 10, 12 ' up, left arrow%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2: ButtonSetState currButton, 2%@NL@% CASE 3:%@NL@% ButtonToggle currButton%@NL@% currButton = 5%@NL@% optionButton = currButton%@NL@% ButtonToggle optionButton%@NL@% CASE 4, 5:%@NL@% ButtonToggle currButton%@NL@% currButton = currButton - 1%@NL@% optionButton = currButton%@NL@% ButtonToggle optionButton%@NL@% CASE 6, 7: ScrollList colors$(), fgColorBox, currButton, 2, 0, winRow, winCol%@NL@% CASE 8, 9: ScrollList fonts$(), fontBox, currButton, 2, 0, winRow, winCol%@NL@% END SELECT%@NL@% CASE 11, 13 ' down, right arrow%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2: ButtonSetState currButton, 1%@NL@% CASE 3, 4:%@NL@% ButtonToggle currButton%@NL@% currButton = currButton + 1%@NL@% optionButton = currButton%@NL@% ButtonToggle optionButton%@NL@% CASE 5:%@NL@% ButtonToggle currButton%@NL@% currButton = 3%@NL@% optionButton = currButton%@NL@% ButtonToggle optionButton%@NL@% CASE 6, 7: ScrollList colors$(), fgColorBox, currButton, 3, 0, winRow, winCol%@NL@% CASE 8, 9: ScrollList fonts$(), fontBox, currButton, 3, 0, winRow, winCol%@NL@% END SELECT%@NL@% CASE 14 ' space bar%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2: ButtonToggle currButton%@NL@% CASE 10, 11: finished = TRUE%@NL@% CASE 12: ChangeWindow 2, "Legend Window", CEnv.Legend.LegendWindow%@NL@% END SELECT%@NL@% END SELECT%@NL@% WEND%@NL@% %@NL@% %@AB@% ' if not canceled then return the new values%@AE@%%@NL@% IF pushButton = 10 THEN%@NL@% IF setNum > 0 THEN chartChanged = TRUE%@NL@% %@NL@% CEnv.Legend.TextColor = fgColorBox.listPos - 1%@NL@% CEnv.Legend.TextFont = fontBox.listPos%@NL@% CEnv.Legend.AutoSize = (ButtonInquire(2) = 2)%@NL@% CEnv.Legend.Legend = (ButtonInquire(1) = 2)%@NL@% CEnv.Legend.Place = optionButton - 2%@NL@% END IF%@NL@% %@NL@% WindowClose 1%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ChangeStyle%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Allows user to view and modify the chart style%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ChangeStyle%@NL@% DIM fontBox AS ListBox%@NL@% %@NL@% %@AB@% ' determine button labels based on chart type%@AE@%%@NL@% SELECT CASE CEnv.ChartType%@NL@% CASE cBar, cColumn%@NL@% style1$ = "Adjacent"%@NL@% style2$ = "Stacked"%@NL@% CASE cLine, cScatter%@NL@% style1$ = "Lines"%@NL@% style2$ = "No Lines"%@NL@% CASE cPie%@NL@% style1$ = "Percentages"%@NL@% style2$ = "No Percentages"%@NL@% END SELECT%@NL@% %@NL@% topRow = 8%@NL@% leftCol = 26%@NL@% %@AB@% ' if pie, line or scatter chart then add data font%@AE@%%@NL@% IF CEnv.ChartType > 2 THEN%@NL@% WindowOpen 1, topRow, leftCol, 19, 47, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 2, "Chart Style"%@NL@% okLine = 12%@NL@% %@NL@% WindowLocate 5, 3%@NL@% WindowPrint -2, "Data Font:"%@NL@% %@AB@% ' set up list box containing valid fonts%@AE@%%@NL@% fontBox.scrollButton = 3%@NL@% fontBox.areaButton = 4%@NL@% fontBox.listLen = numFonts%@NL@% fontBox.topRow = 6%@NL@% fontBox.botRow = 10%@NL@% fontBox.leftCol = 3%@NL@% fontBox.rightCol = 20%@NL@% fontBox.listPos = CEnv.DataFont%@NL@% CreateListBox fonts$(), fontBox, 0%@NL@% ELSE%@NL@% WindowOpen 1, topRow, leftCol, 13, 47, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 2, "Chart Style"%@NL@% okLine = 6%@NL@% END IF%@NL@% %@NL@% %@AB@% ' open buttons%@AE@%%@NL@% ButtonOpen 1, 1, style1$, 2, 3, 1, 0, 3%@NL@% ButtonOpen 2, 1, style2$, 3, 3, 1, 0, 3%@NL@% WindowLine okLine - 1%@NL@% ButtonOpen 5, 2, "OK", okLine, 3, 1, 0, 1%@NL@% ButtonOpen 6, 1, "Cancel", okLine, 11, 1, 0, 1%@NL@% %@NL@% pushButton = 5%@NL@% optionButton = CEnv.ChartStyle ' set current style%@NL@% currButton = optionButton%@NL@% ButtonSetState optionButton, 2%@NL@% %@NL@% %@AB@% ' window control loop%@AE@%%@NL@% finished = FALSE%@NL@% WHILE NOT finished%@NL@% WindowDo currButton, 0 ' wait for event%@NL@% SELECT CASE Dialog(0)%@NL@% CASE 1 'button pressed%@NL@% currButton = Dialog(1)%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2:%@NL@% ButtonSetState optionButton, 1%@NL@% optionButton = currButton%@NL@% ButtonSetState optionButton, 2%@NL@% CASE 3, 4:%@NL@% ScrollList fonts$(), fontBox, currButton, 1, 0, topRow, leftCol%@NL@% currButton = 4%@NL@% CASE 5, 6:%@NL@% finished = TRUE%@NL@% END SELECT%@NL@% CASE 6 'enter%@NL@% finished = TRUE%@NL@% CASE 7 'tab%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2:%@NL@% IF CEnv.ChartType > 2 THEN%@NL@% currButton = 4%@NL@% ELSE%@NL@% currButton = 5%@NL@% ButtonSetState pushButton, 1%@NL@% pushButton = currButton%@NL@% ButtonSetState pushButton, 2%@NL@% END IF%@NL@% CASE 3, 4:%@NL@% currButton = 5%@NL@% ButtonSetState pushButton, 1%@NL@% pushButton = currButton%@NL@% ButtonSetState currButton, 2%@NL@% CASE 5:%@NL@% currButton = 6%@NL@% ButtonSetState pushButton, 1%@NL@% pushButton = currButton%@NL@% ButtonSetState currButton, 2%@NL@% CASE 6:%@NL@% currButton = optionButton%@NL@% ButtonSetState pushButton, 1%@NL@% pushButton = 5%@NL@% ButtonSetState pushButton, 2%@NL@% END SELECT%@NL@% CASE 8 'back tab%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2:%@NL@% currButton = 6%@NL@% ButtonSetState pushButton, 1%@NL@% pushButton = currButton%@NL@% ButtonSetState pushButton, 2%@NL@% CASE 3, 4:%@NL@% currButton = optionButton%@NL@% CASE 5:%@NL@% IF CEnv.ChartType > 2 THEN%@NL@% currButton = 4%@NL@% ELSE%@NL@% currButton = optionButton%@NL@% END IF%@NL@% CASE 6:%@NL@% currButton = 5%@NL@% ButtonSetState pushButton, 1%@NL@% pushButton = currButton%@NL@% ButtonSetState currButton, 2%@NL@% END SELECT%@NL@% CASE 9 'escape%@NL@% finished = TRUE%@NL@% pushButton = 5%@NL@% CASE 10, 12 'up, left arrow%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2:%@NL@% ButtonSetState currButton, 1%@NL@% currButton = 3 - currButton%@NL@% optionButton = currButton%@NL@% ButtonSetState currButton, 2%@NL@% CASE 3, 4:%@NL@% ScrollList fonts$(), fontBox, currButton, 2, 0, topRow, leftCol%@NL@% END SELECT%@NL@% CASE 11, 13 'down, right arrow%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2:%@NL@% ButtonSetState currButton, 1%@NL@% currButton = 3 - currButton%@NL@% optionButton = currButton%@NL@% ButtonSetState currButton, 2%@NL@% CASE 3, 4:%@NL@% ScrollList fonts$(), fontBox, currButton, 3, 0, topRow, leftCol%@NL@% END SELECT%@NL@% CASE 14 'space bar%@NL@% IF currButton > 4 THEN finished = TRUE%@NL@% END SELECT%@NL@% WEND%@NL@% %@NL@% %@AB@% ' if not canceled then set new chart style%@AE@%%@NL@% IF pushButton = 5 THEN%@NL@% IF setNum > 0 THEN chartChanged = TRUE%@NL@% CEnv.ChartStyle = optionButton%@NL@% IF CEnv.ChartType > 2 THEN CEnv.DataFont = fontBox.listPos%@NL@% END IF%@NL@% %@NL@% WindowClose 1%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ChangeTitle%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Allows user to view and modify the chart titles%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: handle - window number%@AE@%%@NL@% %@AB@%' wTitle$ - window title%@AE@%%@NL@% %@AB@%' title - chart title%@AE@%%@NL@% %@AB@%' topRow - top row of window%@AE@%%@NL@% %@AB@%' leftCol - left column of window%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ChangeTitle (handle, wTitle$, title AS TitleType, topRow, leftCol)%@NL@% SHARED mode$(), numModes AS INTEGER%@NL@% %@NL@% DIM colorBox AS ListBox%@NL@% DIM fontBox AS ListBox%@NL@% %@NL@% %@AB@% ' set up foreground color box%@AE@%%@NL@% colorBox.scrollButton = 1%@NL@% colorBox.areaButton = 2%@NL@% colorBox.listLen = numColors%@NL@% colorBox.topRow = 6%@NL@% colorBox.botRow = 10%@NL@% colorBox.leftCol = 2%@NL@% colorBox.rightCol = 16%@NL@% colorBox.listPos = title.TitleColor + 1%@NL@% %@NL@% %@AB@% ' set up font box%@AE@%%@NL@% fontBox.scrollButton = 3%@NL@% fontBox.areaButton = 4%@NL@% fontBox.listLen = numFonts%@NL@% fontBox.topRow = 6%@NL@% fontBox.botRow = 10%@NL@% fontBox.leftCol = 18%@NL@% fontBox.rightCol = 36%@NL@% fontBox.listPos = title.TitleFont%@NL@% %@NL@% %@AB@% ' set up display window%@AE@%%@NL@% WindowOpen handle, topRow, leftCol, topRow + 11, leftCol + 50, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 2, wTitle$%@NL@% WindowLocate 2, 2%@NL@% WindowPrint 2, "Title:"%@NL@% WindowBox 1, 8, 3, 50%@NL@% WindowBox 6, 38, 10, 50%@NL@% WindowLine 4%@NL@% WindowLine 11%@NL@% WindowLocate 5, 1%@NL@% WindowPrint -1, " Color: Font: Justify:"%@NL@% %@NL@% %@AB@% ' set color attribute for title editfield background to that of the chart background%@AE@%%@NL@% IF mode$(1) = "10" OR (mode$(1) = "2" AND mode$(2) <> "1") OR mode$(1) = "3" THEN%@NL@% func = 0%@NL@% EditFieldOpen 1, RTRIM$(title.title), 2, 9, 0, 7, 41, 70%@NL@% ELSE%@NL@% SetAtt 5, CEnv.ChartWindow.Background + 1%@NL@% EditFieldOpen 1, RTRIM$(title.title), 2, 9, 12, 5, 41, 70%@NL@% func = 2%@NL@% END IF%@NL@% %@NL@% %@AB@% ' create list boxes%@AE@%%@NL@% CreateListBox colors$(), colorBox, func%@NL@% CreateListBox fonts$(), fontBox, 0%@NL@% %@NL@% %@AB@% ' open buttons%@AE@%%@NL@% ButtonOpen 5, 1, "Left", 7, 39, 0, 0, 3%@NL@% ButtonOpen 6, 1, "Center", 8, 39, 0, 0, 3%@NL@% ButtonOpen 7, 1, "Right", 9, 39, 0, 0, 3%@NL@% ButtonOpen 8, 2, "OK ", 12, 10, 0, 0, 1%@NL@% ButtonOpen 9, 1, "Cancel ", 12, 33, 0, 0, 1%@NL@% %@NL@% currButton = 0 ' start in edit field%@NL@% currEditField = 1%@NL@% optionButton = 4 + title.Justify ' set button state%@NL@% ButtonToggle optionButton%@NL@% pushButton = 8%@NL@% %@NL@% %@AB@% ' window control loop%@AE@%%@NL@% finished = FALSE%@NL@% WHILE NOT finished%@NL@% WindowDo currButton, currEditField ' wait for event%@NL@% SELECT CASE Dialog(0)%@NL@% CASE 1 ' button pressed%@NL@% currButton = Dialog(1)%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2%@NL@% currEditField = 0%@NL@% ScrollList colors$(), colorBox, currButton, 1, func, topRow, leftCol%@NL@% currButton = 2%@NL@% CASE 3, 4%@NL@% currEditField = 0%@NL@% ScrollList fonts$(), fontBox, currButton, 1, 0, topRow, leftCol%@NL@% currButton = 4%@NL@% CASE 5, 6, 7%@NL@% ButtonToggle optionButton%@NL@% optionButton = currButton%@NL@% ButtonToggle optionButton%@NL@% currEditField = 0%@NL@% CASE 8, 9%@NL@% pushButton = currButton%@NL@% finished = TRUE%@NL@% END SELECT%@NL@% CASE 2 ' edit field%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% CASE 6 ' enter%@NL@% finished = TRUE%@NL@% CASE 7 ' tab%@NL@% SELECT CASE currButton%@NL@% CASE 0:%@NL@% currButton = 2%@NL@% currEditField = 0%@NL@% CASE 1, 2: currButton = 4%@NL@% CASE 3, 4: currButton = optionButton%@NL@% CASE 5, 6, 7:%@NL@% currButton = 8%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = 8%@NL@% CASE 8:%@NL@% currButton = currButton + 1%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% CASE 9:%@NL@% ButtonSetState currButton, 1%@NL@% pushButton = 8%@NL@% ButtonSetState pushButton, 2%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% END SELECT%@NL@% CASE 8 ' back tab%@NL@% SELECT CASE currButton%@NL@% CASE 0:%@NL@% currButton = 9%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = 9%@NL@% currEditField = 0%@NL@% CASE 1, 2:%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% CASE 3, 4: currButton = 2%@NL@% CASE 5, 6, 7: currButton = 4%@NL@% CASE 8: currButton = optionButton%@NL@% CASE 9:%@NL@% currButton = currButton - 1%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% END SELECT%@NL@% CASE 9 ' escape%@NL@% pushButton = 9%@NL@% finished = TRUE%@NL@% CASE 10, 12 ' up, left arrow%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2: ScrollList colors$(), colorBox, currButton, 2, func, topRow, leftCol%@NL@% CASE 3, 4: ScrollList fonts$(), fontBox, currButton, 2, 0, topRow, leftCol%@NL@% CASE 5:%@NL@% ButtonToggle currButton%@NL@% currButton = 7%@NL@% optionButton = 7%@NL@% ButtonToggle optionButton%@NL@% CASE 6, 7:%@NL@% ButtonToggle currButton%@NL@% currButton = currButton - 1%@NL@% optionButton = currButton%@NL@% ButtonToggle optionButton%@NL@% END SELECT%@NL@% CASE 11, 13 ' down, right arrow%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2: ScrollList colors$(), colorBox, currButton, 3, func, topRow, leftCol%@NL@% CASE 3, 4: ScrollList fonts$(), fontBox, currButton, 3, 0, topRow, leftCol%@NL@% CASE 5, 6:%@NL@% ButtonToggle currButton%@NL@% currButton = currButton + 1%@NL@% optionButton = currButton%@NL@% ButtonToggle optionButton%@NL@% CASE 7:%@NL@% ButtonToggle currButton%@NL@% currButton = 5%@NL@% optionButton = 5%@NL@% ButtonToggle optionButton%@NL@% END SELECT%@NL@% CASE 14 ' space bar%@NL@% IF currButton > 7 THEN%@NL@% pushButton = currButton%@NL@% finished = TRUE%@NL@% END IF%@NL@% END SELECT%@NL@% WEND%@NL@% %@NL@% %@AB@% ' done and not canceled so return new title information%@AE@%%@NL@% IF pushButton = 8 THEN%@NL@% IF setNum > 0 THEN chartChanged = TRUE%@NL@% %@NL@% title.title = EditFieldInquire(1)%@NL@% title.TitleFont = fontBox.listPos%@NL@% title.TitleColor = colorBox.listPos - 1%@NL@% title.Justify = optionButton - 4%@NL@% END IF%@NL@% %@NL@% WindowClose handle%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ChangeWindow%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Allows user to view and modify any of the chart windows%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: handle - window number%@AE@%%@NL@% %@AB@%' wTitle$ - window title%@AE@%%@NL@% %@AB@%' win - chart window%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ChangeWindow (handle, title$, win AS RegionType)%@NL@% %@NL@% DIM bgColorBox AS ListBox%@NL@% DIM bdColorBox AS ListBox%@NL@% DIM bdStyleBox AS ListBox%@NL@% %@NL@% %@AB@% ' set up background color box%@AE@%%@NL@% bgColorBox.scrollButton = 1%@NL@% bgColorBox.areaButton = 2%@NL@% bgColorBox.listLen = numColors%@NL@% bgColorBox.topRow = 4%@NL@% bgColorBox.botRow = 14%@NL@% bgColorBox.leftCol = 4%@NL@% bgColorBox.rightCol = 18%@NL@% bgColorBox.listPos = win.Background + 1%@NL@% %@NL@% %@AB@% ' set up border color box%@AE@%%@NL@% bdColorBox.scrollButton = 3%@NL@% bdColorBox.areaButton = 4%@NL@% bdColorBox.listLen = numColors%@NL@% bdColorBox.topRow = 5%@NL@% bdColorBox.botRow = 14%@NL@% bdColorBox.leftCol = 24%@NL@% bdColorBox.rightCol = 38%@NL@% bdColorBox.listPos = win.BorderColor + 1%@NL@% %@NL@% %@AB@% ' set up border style box%@AE@%%@NL@% bdStyleBox.scrollButton = 5%@NL@% bdStyleBox.areaButton = 6%@NL@% bdStyleBox.listLen = MAXSTYLES%@NL@% bdStyleBox.topRow = 5%@NL@% bdStyleBox.botRow = 14%@NL@% bdStyleBox.leftCol = 40%@NL@% bdStyleBox.rightCol = 54%@NL@% bdStyleBox.listPos = win.BorderStyle%@NL@% %@NL@% %@AB@% ' set up display window%@AE@%%@NL@% winRow = 5%@NL@% winCol = 3%@NL@% WindowOpen handle, winRow, winCol, 21, 76, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 2, title$%@NL@% WindowBox 1, 2, 15, 20%@NL@% WindowLocate 2, 5%@NL@% WindowPrint 2, "Background"%@NL@% WindowLocate 3, 5%@NL@% WindowPrint 2, "Color:"%@NL@% WindowBox 1, 22, 15, 56%@NL@% WindowLocate 4, 24%@NL@% WindowPrint 2, "Border Color:"%@NL@% WindowLocate 4, 40%@NL@% WindowPrint 2, "Border Style:"%@NL@% WindowBox 1, 58, 15, 73%@NL@% WindowLocate 2, 60%@NL@% WindowPrint 2, "Coordinates:"%@NL@% WindowBox 3, 63, 5, 71%@NL@% WindowLocate 4, 60%@NL@% WindowPrint 2, "X1:"%@NL@% WindowBox 6, 63, 8, 71%@NL@% WindowLocate 7, 60%@NL@% WindowPrint 2, "Y1:"%@NL@% WindowBox 9, 63, 11, 71%@NL@% WindowLocate 10, 60%@NL@% WindowPrint 2, "X2:"%@NL@% WindowBox 12, 63, 14, 71%@NL@% WindowLocate 13, 60%@NL@% WindowPrint 2, "Y2:"%@NL@% WindowLine 16%@NL@% %@NL@% CreateListBox colors$(), bgColorBox, 0%@NL@% CreateListBox colors$(), bdColorBox, 0%@NL@% CreateListBox styles$(), bdStyleBox, 0%@NL@% %@NL@% ButtonOpen 7, 1, "Display Border", 2, 24, 0, 0, 2%@NL@% ButtonOpen 8, 2, "OK ", 17, 14, 0, 0, 1%@NL@% ButtonOpen 9, 1, "Cancel ", 17, 51, 0, 0, 1%@NL@% %@NL@% EditFieldOpen 1, LTRIM$(STR$(win.X1)), 4, 64, 0, 7, 7, 10%@NL@% EditFieldOpen 2, LTRIM$(STR$(win.Y1)), 7, 64, 0, 7, 7, 10%@NL@% EditFieldOpen 3, LTRIM$(STR$(win.X2)), 10, 64, 0, 7, 7, 10%@NL@% EditFieldOpen 4, LTRIM$(STR$(win.Y2)), 13, 64, 0, 7, 7, 10%@NL@% %@NL@% currButton = 2 ' start in first list box%@NL@% currEditField = 0%@NL@% IF win.border = TRUE THEN ButtonSetState 7, 2%@NL@% pushButton = 8%@NL@% %@NL@% %@AB@% ' window control loop%@AE@%%@NL@% finished = FALSE%@NL@% WHILE NOT finished%@NL@% WindowDo currButton, currEditField ' wait for event%@NL@% SELECT CASE Dialog(0)%@NL@% CASE 1 ' button pressed%@NL@% currButton = Dialog(1)%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2%@NL@% currEditField = 0%@NL@% ScrollList colors$(), bgColorBox, currButton, 1, 0, winRow, winCol%@NL@% currButton = 2%@NL@% CASE 3, 4%@NL@% currEditField = 0%@NL@% ScrollList colors$(), bdColorBox, currButton, 1, 0, winRow, winCol%@NL@% currButton = 4%@NL@% CASE 5, 6%@NL@% currEditField = 0%@NL@% ScrollList styles$(), bdStyleBox, currButton, 1, 0, winRow, winCol%@NL@% currButton = 6%@NL@% CASE 7%@NL@% ButtonToggle currButton%@NL@% currEditField = 0%@NL@% CASE 8, 9%@NL@% pushButton = currButton%@NL@% finished = TRUE%@NL@% END SELECT%@NL@% CASE 2 ' edit field%@NL@% currEditField = Dialog(2)%@NL@% currButton = 0%@NL@% CASE 6 ' enter%@NL@% finished = TRUE%@NL@% CASE 7 ' tab%@NL@% SELECT CASE currButton%@NL@% CASE 0:%@NL@% SELECT CASE currEditField%@NL@% CASE 1, 2, 3: currEditField = currEditField + 1%@NL@% CASE 4:%@NL@% currEditField = 0%@NL@% currButton = 8%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% END SELECT%@NL@% CASE 1, 2: currButton = 7%@NL@% CASE 3, 4: currButton = 6%@NL@% CASE 5, 6:%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% CASE 7: currButton = 4%@NL@% CASE 8:%@NL@% currButton = currButton + 1%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% CASE 9:%@NL@% ButtonSetState currButton, 1%@NL@% pushButton = 8%@NL@% ButtonSetState pushButton, 2%@NL@% currButton = 2%@NL@% currEditField = 0%@NL@% END SELECT%@NL@% CASE 8 ' back tab%@NL@% SELECT CASE currButton%@NL@% CASE 0:%@NL@% SELECT CASE currEditField%@NL@% CASE 1:%@NL@% currEditField = 0%@NL@% currButton = 6%@NL@% CASE 2, 3, 4: currEditField = currEditField - 1%@NL@% END SELECT%@NL@% CASE 1, 2:%@NL@% currButton = 9%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% CASE 3, 4: currButton = 7%@NL@% CASE 5, 6: currButton = 4%@NL@% CASE 7: currButton = 2%@NL@% CASE 8:%@NL@% currButton = 0%@NL@% currEditField = 4%@NL@% CASE 9:%@NL@% currButton = currButton - 1%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% END SELECT%@NL@% CASE 9 ' escape%@NL@% pushButton = 9%@NL@% finished = TRUE%@NL@% CASE 10, 12 ' up, left arrow%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2: ScrollList colors$(), bgColorBox, currButton, 2, 0, winRow, winCol%@NL@% CASE 3, 4: ScrollList colors$(), bdColorBox, currButton, 2, 0, winRow, winCol%@NL@% CASE 5, 6: ScrollList styles$(), bdStyleBox, currButton, 2, 0, winRow, winCol%@NL@% CASE 7: ButtonSetState currButton, 2%@NL@% END SELECT%@NL@% CASE 11, 13 ' down, right arrow%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2: ScrollList colors$(), bgColorBox, currButton, 3, 0, winRow, winCol%@NL@% CASE 3, 4: ScrollList colors$(), bdColorBox, currButton, 3, 0, winRow, winCol%@NL@% CASE 5, 6: ScrollList styles$(), bdStyleBox, currButton, 3, 0, winRow, winCol%@NL@% CASE 7: ButtonSetState currButton, 1%@NL@% END SELECT%@NL@% CASE 14 ' space bar%@NL@% SELECT CASE currButton%@NL@% CASE 7: ButtonToggle currButton%@NL@% CASE 8, 9: finished = TRUE%@NL@% END SELECT%@NL@% END SELECT%@NL@% WEND%@NL@% %@NL@% %@AB@% ' return new window information%@AE@%%@NL@% IF pushButton = 8 THEN%@NL@% IF setNum > 0 THEN chartChanged = TRUE%@NL@% %@NL@% win.X1 = VAL(EditFieldInquire(1))%@NL@% win.Y1 = VAL(EditFieldInquire(2))%@NL@% win.X2 = VAL(EditFieldInquire(3))%@NL@% win.Y2 = VAL(EditFieldInquire(4))%@NL@% win.Background = bgColorBox.listPos - 1%@NL@% win.border = (ButtonInquire(7) = 2)%@NL@% win.BorderColor = bdColorBox.listPos - 1%@NL@% win.BorderStyle = bdStyleBox.listPos%@NL@% END IF%@NL@% %@NL@% WindowClose handle%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%CHRTDEM2.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\CHRTDEM2.BAS%@AE@%%@NL@% %@NL@% %@AB@%' CHRTDEM2.BAS - third module of the CHRTB demonstration program.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Copyright (C) 1989, Microsoft Corporation%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Main module - CHRTDEMO.BAS%@AE@%%@NL@% %@AB@%' Include files - CHRTDEMO.BI%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'$INCLUDE: 'chrtdemo.bi'%@AE@%%@NL@% %@NL@% %@AB@%' local functions%@AE@%%@NL@% DECLARE FUNCTION TrueColr% (colr%)%@NL@% %@NL@% %@AB@%' local subs%@AE@%%@NL@% DECLARE SUB OpenChart (newFlag%)%@NL@% DECLARE SUB Quit ()%@NL@% DECLARE SUB InitFonts ()%@NL@% DECLARE SUB InitStyles ()%@NL@% DECLARE SUB SetDisplayColor ()%@NL@% DECLARE SUB SetUpBackground ()%@NL@% DECLARE SUB SetUpMenu ()%@NL@% DECLARE SUB ViewChart ()%@NL@% DECLARE SUB ViewFont ()%@NL@% DECLARE SUB ViewScreenMode ()%@NL@% %@NL@% DIM colorDisplay AS INTEGER%@NL@% DIM egacolor(0 TO 15) AS INTEGER%@NL@% DIM origPath$%@NL@% %@NL@% DEFINT A-Z%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ClearData%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Clears all chart data%@AE@%%@NL@% %@AB@%' Arguments: None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ClearData%@NL@% SHARED Cat$(), catLen AS INTEGER%@NL@% SHARED setVal!(), setLen() AS INTEGER, setName$()%@NL@% %@NL@% %@AB@% ' Can't view chart when no data present%@AE@%%@NL@% MenuSetState VIEWTITLE, 2, 0%@NL@% %@NL@% %@AB@% ' Clear categories%@AE@%%@NL@% FOR i = 1 TO cMaxValues%@NL@% Cat$(i) = ""%@NL@% NEXT i%@NL@% catLen = 0%@NL@% %@NL@% %@AB@% ' Clear set names and values%@AE@%%@NL@% FOR i = 1 TO cMaxSets%@NL@% setName$(i) = ""%@NL@% setLen(i) = 0%@NL@% FOR j = 1 TO cMaxValues%@NL@% setVal!(j, i) = cMissingValue%@NL@% NEXT j%@NL@% NEXT i%@NL@% setNum = 0%@NL@% %@NL@% %@AB@% ' chart not changed%@AE@%%@NL@% chartChanged = FALSE%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ClearFonts%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Sets all chart font pointers to 1. This is called%@AE@%%@NL@% %@AB@%' each time new fonts are loaded to ensure that%@AE@%%@NL@% %@AB@%' all chart fonts specify a meaningful font%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ClearFonts%@NL@% %@NL@% %@AB@% ' reset all font pointers if don't map to current fonts%@AE@%%@NL@% IF CEnv.DataFont > numFonts THEN CEnv.DataFont = 1%@NL@% IF CEnv.MainTitle.TitleFont > numFonts THEN CEnv.MainTitle.TitleFont = 1%@NL@% IF CEnv.SubTitle.TitleFont > numFonts THEN CEnv.SubTitle.TitleFont = 1%@NL@% IF CEnv.XAxis.AxisTitle.TitleFont > numFonts THEN CEnv.XAxis.AxisTitle.TitleFont = 1%@NL@% IF CEnv.XAxis.TicFont > numFonts THEN CEnv.XAxis.TicFont = 1%@NL@% IF CEnv.YAxis.AxisTitle.TitleFont > numFonts THEN CEnv.YAxis.AxisTitle.TitleFont = 1%@NL@% IF CEnv.YAxis.TicFont > numFonts THEN CEnv.YAxis.TicFont = 1%@NL@% IF CEnv.Legend.TextFont > numFonts THEN CEnv.Legend.TextFont = 1%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: CreateListBox%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Creates a list box within the current window%@AE@%%@NL@% %@AB@%' Arguments: text$() - the list%@AE@%%@NL@% %@AB@%' tbox - the listBox%@AE@%%@NL@% %@AB@%' func - function flag for DrawList%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB CreateListBox (text$(), tbox AS ListBox, func)%@NL@% %@NL@% %@AB@% ' get box length%@AE@%%@NL@% tbox.boxLen = tbox.botRow - tbox.topRow - 1%@NL@% %@NL@% %@AB@% ' get displayable length%@AE@%%@NL@% IF tbox.listLen < tbox.boxLen THEN%@NL@% tbox.maxLen = tbox.listLen%@NL@% ELSE%@NL@% tbox.maxLen = tbox.boxLen%@NL@% END IF%@NL@% %@NL@% %@AB@% ' get box width%@AE@%%@NL@% tbox.boxWid = tbox.rightCol - tbox.leftCol - 1%@NL@% %@NL@% %@AB@% ' create box%@AE@%%@NL@% WindowBox tbox.topRow, tbox.leftCol, tbox.botRow, tbox.rightCol%@NL@% %@NL@% %@AB@% ' add scroll bar if necessary or if forced (func = 5)%@AE@%%@NL@% IF tbox.listLen <> tbox.maxLen OR func = 5 THEN%@NL@% ButtonOpen tbox.scrollButton, 1, "", tbox.topRow + 1, tbox.rightCol, tbox.botRow - 1, tbox.rightCol, 6%@NL@% ELSE%@NL@% tbox.scrollButton = 0%@NL@% END IF%@NL@% %@NL@% %@AB@% ' open area button%@AE@%%@NL@% ButtonOpen tbox.areaButton, 1, "", tbox.topRow + 1, tbox.leftCol + 1, tbox.botRow - 1, tbox.rightCol - 1, 4%@NL@% %@NL@% %@AB@% ' set current list element relative to list box top%@AE@%%@NL@% IF tbox.listPos <= tbox.maxLen THEN%@NL@% tbox.currTop = 1%@NL@% tbox.currPos = tbox.listPos%@NL@% ELSEIF tbox.listPos + tbox.maxLen > tbox.listLen + 1 THEN%@NL@% tbox.currTop = tbox.listLen - tbox.maxLen + 1%@NL@% tbox.currPos = tbox.listPos - tbox.currTop + 1%@NL@% ELSE%@NL@% tbox.currTop = tbox.listPos%@NL@% tbox.currPos = 1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Display list within the box%@AE@%%@NL@% DrawList text$(), tbox, func%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: DrawList%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Displays a list within the boundaries of a list box%@AE@%%@NL@% %@AB@%' Arguments: text$() - the list%@AE@%%@NL@% %@AB@%' tbox - the listBox%@AE@%%@NL@% %@AB@%' func - function flag for special operations%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB DrawList (text$(), tbox AS ListBox, func)%@NL@% %@NL@% %@AB@% ' Draw each element of list that should currently appear in box%@AE@%%@NL@% FOR i% = 1 TO tbox.boxLen%@NL@% %@AB@% ' highlight current list element%@AE@%%@NL@% IF i% = tbox.currPos THEN%@NL@% WindowColor 7, 0%@NL@% ELSE%@NL@% WindowColor 0, 7%@NL@% END IF%@NL@% %@NL@% WindowLocate tbox.topRow + i%, tbox.leftCol + 1%@NL@% IF i <= tbox.maxLen THEN%@NL@% WindowPrint -1, LEFT$(text$(tbox.currTop + i% - 1) + STRING$(tbox.boxWid, " "), tbox.boxWid)%@NL@% ELSE%@NL@% WindowPrint -1, STRING$(tbox.boxWid, " ")%@NL@% END IF%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' update scrollbar position indicator if scrollbar present%@AE@%%@NL@% IF tbox.scrollButton <> 0 THEN%@NL@% IF tbox.listLen <> 0 THEN%@NL@% position = (tbox.currTop + tbox.currPos - 1) * (tbox.maxLen - 2) / tbox.listLen%@NL@% IF position < 1 THEN%@NL@% position = 1%@NL@% ELSEIF position > tbox.maxLen - 2 THEN%@NL@% position = tbox.maxLen - 2%@NL@% END IF%@NL@% ELSE%@NL@% position = 1%@NL@% END IF%@NL@% ButtonSetState tbox.scrollButton, position%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Reset color in case current element was last to be drawn%@AE@%%@NL@% WindowColor 0, 7%@NL@% %@NL@% %@AB@% ' update current position in case list has been scrolled%@AE@%%@NL@% tbox.listPos = tbox.currTop + tbox.currPos - 1%@NL@% %@NL@% %@AB@% ' handle special operation of immediately updating colors$ in title editfield%@AE@%%@NL@% SELECT CASE func%@NL@% CASE 2: SetAtt 12, tbox.listPos ' update title editfield foreground color%@NL@% END SELECT%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Func Name: HandleMenuEvent%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Determines the action to be performed when user makes%@AE@%%@NL@% %@AB@%' a menu selection.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB HandleMenuEvent%@NL@% SHARED saveFile$, colorDisplay AS INTEGER%@NL@% %@NL@% menu = MenuCheck(0)%@NL@% item = MenuCheck(1)%@NL@% %@NL@% SELECT CASE menu%@NL@% %@AB@% ' file menu title selection%@AE@%%@NL@% CASE FILETITLE%@NL@% SELECT CASE item%@NL@% %@AB@% ' new chart%@AE@%%@NL@% CASE 1: OpenChart TRUE%@NL@% %@AB@% ' open existing chart%@AE@%%@NL@% CASE 2: OpenChart FALSE%@NL@% %@AB@% ' save current chart%@AE@%%@NL@% CASE 3: junk = SaveChart(saveFile$, FALSE)%@NL@% %@AB@% ' save current chart under new name%@AE@%%@NL@% CASE 4: junk = SaveChart(saveFile$, TRUE)%@NL@% %@AB@% ' exit program%@AE@%%@NL@% CASE 6: Quit%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' view menu title selection%@AE@%%@NL@% CASE VIEWTITLE%@NL@% SELECT CASE item%@NL@% %@AB@% ' Display and edit existing chart data%@AE@%%@NL@% CASE 1: ViewData%@NL@% %@AB@% ' Display chart%@AE@%%@NL@% CASE 2: ViewChart%@NL@% %@AB@% ' Display and load fonts%@AE@%%@NL@% CASE 3: ViewFont%@NL@% %@AB@% ' Display and edit screen mode%@AE@%%@NL@% CASE 4: ViewScreenMode%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Gallery menu title selection%@AE@%%@NL@% CASE GALLERYTITLE%@NL@% %@AB@% ' change chart type%@AE@%%@NL@% ChangeChartType item%@NL@% %@NL@% %@AB@% ' Chart menu title selection%@AE@%%@NL@% CASE CHARTTITLE%@NL@% SELECT CASE item%@NL@% %@AB@% ' Change chart window%@AE@%%@NL@% CASE 1: ChangeWindow 1, "Chart Window", CEnv.ChartWindow%@NL@% %@AB@% ' Change data window%@AE@%%@NL@% CASE 2: ChangeWindow 1, "Data Window", CEnv.DataWindow%@NL@% %@AB@% ' Change legend%@AE@%%@NL@% CASE 3: ChangeLegend%@NL@% %@AB@% ' Change X axis%@AE@%%@NL@% CASE 4: ChangeAxis "X Axis", CEnv.XAxis%@NL@% %@AB@% ' Change Y axis%@AE@%%@NL@% CASE 5: ChangeAxis "Y Axis", CEnv.YAxis%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Title menu title selection%@AE@%%@NL@% CASE TITLETITLE%@NL@% SELECT CASE item%@NL@% %@AB@% ' Display and modify main title%@AE@%%@NL@% CASE 1: ChangeTitle 1, "Main Title", CEnv.MainTitle, 6, 16%@NL@% %@AB@% ' Display and modify sub title%@AE@%%@NL@% CASE 2: ChangeTitle 1, "Sub Title", CEnv.SubTitle, 6, 16%@NL@% %@AB@% ' Display and modify x axis title%@AE@%%@NL@% CASE 3:%@NL@% ChangeTitle 1, "X-axis Title", CEnv.XAxis.AxisTitle, 6, 16%@NL@% CEnv.XAxis.ScaleTitle.TitleColor = CEnv.XAxis.AxisTitle.TitleColor%@NL@% CEnv.XAxis.ScaleTitle.Justify = CEnv.XAxis.AxisTitle.Justify%@NL@% %@AB@% ' Display and modify y axis title%@AE@%%@NL@% CASE 4:%@NL@% ChangeTitle 1, "Y-axis Title", CEnv.YAxis.AxisTitle, 6, 16%@NL@% CEnv.YAxis.ScaleTitle.TitleColor = CEnv.YAxis.AxisTitle.TitleColor%@NL@% CEnv.YAxis.ScaleTitle.Justify = CEnv.YAxis.AxisTitle.Justify%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Options menu title selection%@AE@%%@NL@% CASE OPTIONSTITLE%@NL@% colorDisplay = item - 2%@NL@% SetDisplayColor%@NL@% END SELECT%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Func Name: InitAll%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Performs all initialization for the program%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB InitAll%@NL@% SHARED finished AS INTEGER, screenMode AS INTEGER, saveFile$%@NL@% SHARED origPath$, colorDisplay AS INTEGER%@NL@% %@NL@% saveFile$ = "" ' No save file to begin with%@NL@% origPath$ = CURDIR$ ' get working path%@NL@% colorDisplay = FALSE ' start with mono display%@NL@% GetBestMode screenMode ' get initial screen mode%@NL@% %@NL@% SCREEN 0 ' init screen%@NL@% WIDTH 80, 25%@NL@% CLS%@NL@% %@NL@% MenuInit ' init menu routines%@NL@% WindowInit ' init window routines%@NL@% MouseInit ' init mouse routines%@NL@% %@NL@% %@AB@% ' exit if no graphic mode available%@AE@%%@NL@% IF screenMode = 0 THEN%@NL@% PrintError "No graphic screen modes available for charting. Exiting program."%@NL@% finished = TRUE%@NL@% EXIT SUB%@NL@% ELSE%@NL@% finished = FALSE%@NL@% END IF%@NL@% %@NL@% SetUpMenu ' Set up menu bar%@NL@% SetUpBackground ' Set up screen background%@NL@% InitChart ' Initialize chart%@NL@% InitColors ' Set up color list%@NL@% InitStyles ' Set up border style list%@NL@% InitFonts ' Set up font lists%@NL@% %@NL@% MenuShow ' display menu bar%@NL@% MouseShow ' display mouse%@NL@% %@NL@% %@AB@% ' display program introduction%@AE@%%@NL@% a$ = "Microsoft QuickChart|"%@NL@% a$ = a$ + "A Presentation Graphics Toolbox Demo|"%@NL@% a$ = a$ + "for|"%@NL@% a$ = a$ + "Microsoft BASIC 7.0 Professional Development System|"%@NL@% a$ = a$ + "Copyright (c) 1989 Microsoft Corporation|"%@NL@% %@NL@% temp = Alert(4, a$, 9, 12, 15, 68, "Color", "Monochrome", "")%@NL@% %@NL@% %@AB@% ' set display to color or monochrome depending on colorDislay%@AE@%%@NL@% IF temp = 1 THEN colorDisplay = TRUE%@NL@% %@NL@% SetDisplayColor%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: InitChart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Initializes chart environment variables and other%@AE@%%@NL@% %@AB@%' related information.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB InitChart%@NL@% %@NL@% MenuItemToggle GALLERYTITLE, cBar ' default chart type is BAR so%@NL@% %@AB@% ' set up menu that way%@AE@%%@NL@% %@NL@% DefaultChart CEnv, cBar, cPlain ' Get defaults for chart variable%@NL@% %@NL@% ClearData ' Clear all chart data%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: Initcolors%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Creates color list based on screen mode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB InitColors%@NL@% SHARED screenMode AS INTEGER%@NL@% SHARED egacolor() AS INTEGER%@NL@% %@NL@% %@AB@% ' init EGA colors$ for SetAtt%@AE@%%@NL@% egacolor(0) = 0%@NL@% egacolor(1) = 1%@NL@% egacolor(2) = 2%@NL@% egacolor(3) = 3%@NL@% egacolor(4) = 4%@NL@% egacolor(5) = 5%@NL@% egacolor(6) = 20%@NL@% egacolor(7) = 7%@NL@% egacolor(8) = 56%@NL@% egacolor(9) = 57%@NL@% egacolor(10) = 58%@NL@% egacolor(11) = 59%@NL@% egacolor(12) = 60%@NL@% egacolor(13) = 61%@NL@% egacolor(14) = 62%@NL@% egacolor(15) = 63%@NL@% %@NL@% %@AB@% ' create list of displayable colors$ based on screen mode%@AE@%%@NL@% SELECT CASE screenMode%@NL@% CASE 1%@NL@% numColors = 4%@NL@% REDIM color$(numColors)%@NL@% colors$(1) = "Black"%@NL@% colors$(2) = "White"%@NL@% colors$(3) = "Bright Cyan"%@NL@% colors$(4) = "Bright Magenta"%@NL@% CASE 2, 3, 4, 11%@NL@% numColors = 2%@NL@% REDIM color$(numColors)%@NL@% colors$(1) = "Black"%@NL@% colors$(2) = "White"%@NL@% CASE 7, 8, 9, 12, 13%@NL@% numColors = 16%@NL@% REDIM color$(numColors)%@NL@% colors$(1) = "Black"%@NL@% colors$(2) = "High White"%@NL@% colors$(3) = "Blue"%@NL@% colors$(4) = "Green"%@NL@% colors$(5) = "Cyan"%@NL@% colors$(6) = "Red"%@NL@% colors$(7) = "Magenta"%@NL@% colors$(8) = "Brown"%@NL@% colors$(9) = "White"%@NL@% colors$(10) = "Gray"%@NL@% colors$(11) = "Bright Blue"%@NL@% colors$(12) = "Bright Green"%@NL@% colors$(13) = "Bright Cyan"%@NL@% colors$(14) = "Bright Red"%@NL@% colors$(15) = "Bright Magenta"%@NL@% colors$(16) = "Yellow"%@NL@% CASE 10%@NL@% numColors = 4%@NL@% REDIM color$(numColors)%@NL@% colors$(1) = "Off"%@NL@% colors$(2) = "On High"%@NL@% colors$(3) = "On Normal"%@NL@% colors$(4) = "Blink"%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' reset chart color pointers to default values%@AE@%%@NL@% IF numColors < 16 THEN%@NL@% CEnv.ChartWindow.Background = 0%@NL@% CEnv.ChartWindow.BorderColor = 1%@NL@% CEnv.DataWindow.Background = 0%@NL@% CEnv.DataWindow.BorderColor = 1%@NL@% CEnv.MainTitle.TitleColor = 1%@NL@% CEnv.SubTitle.TitleColor = 1%@NL@% CEnv.XAxis.AxisColor = 1%@NL@% CEnv.XAxis.AxisTitle.TitleColor = 1%@NL@% CEnv.YAxis.AxisColor = 1%@NL@% CEnv.YAxis.AxisTitle.TitleColor = 1%@NL@% CEnv.Legend.TextColor = 1%@NL@% CEnv.Legend.LegendWindow.Background = 0%@NL@% CEnv.Legend.LegendWindow.BorderColor = 1%@NL@% END IF%@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: InitFonts%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: sets up default font and initializes font list%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB InitFonts%@NL@% DIM FI AS FontInfo%@NL@% %@NL@% %@AB@% ' reset%@AE@%%@NL@% UnRegisterFonts%@NL@% SetMaxFonts 1, 1%@NL@% %@NL@% %@AB@% ' get default font%@AE@%%@NL@% DefaultFont Segment%, Offset%%@NL@% reg% = RegisterMemFont%(Segment%, Offset%)%@NL@% %@NL@% %@AB@% ' load default font%@AE@%%@NL@% numFonts = LoadFont("n1")%@NL@% %@NL@% IF numFonts = 0 THEN numFonts = 1%@NL@% %@NL@% fonts$(numFonts) = "IBM 8 Point"%@NL@% %@NL@% UnRegisterFonts%@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: InitStyles%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Initializes border styles list%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB InitStyles%@NL@% %@NL@% %@AB@% ' create list of border styles%@AE@%%@NL@% styles$(1) = "────────────────"%@NL@% styles$(2) = "──── ──── "%@NL@% styles$(3) = "──── ── "%@NL@% styles$(4) = "── ── ── ── "%@NL@% styles$(5) = "── ─ ── ─ "%@NL@% styles$(6) = "─── ─── ─── ── ─ "%@NL@% styles$(7) = "─── ─ ─ ─── ─ ─ "%@NL@% styles$(8) = "──── ── ── ──── "%@NL@% styles$(9) = "──── ── ──── ── "%@NL@% styles$(10) = "──── ─ ─ ── ─ ─ "%@NL@% styles$(11) = "── ─── ─ ─ ─── "%@NL@% styles$(12) = "─ ─ ─ ─ ─ ─ "%@NL@% styles$(13) = "─ ─ ─ ─ ─ ─ ─ ─ "%@NL@% styles$(14) = "─── ─ ─── ─ "%@NL@% styles$(15) = "── ─ ─ ─ ─ "%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Func Name: Min%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Compares two numbers and returns the smallest%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: num1, num2 - numbers to compare%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION Min% (num1, num2)%@NL@% %@NL@% IF num1 <= num2 THEN%@NL@% Min% = num1%@NL@% ELSE%@NL@% Min% = num2%@NL@% END IF%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: Quit%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Exits the program after allowing the user a chance to%@AE@%%@NL@% %@AB@%' save the current chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: None%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB Quit%@NL@% SHARED finished AS INTEGER, saveFile$, origPath$%@NL@% %@NL@% %@AB@% ' Allow user to save chart if necessary%@AE@%%@NL@% IF chartChanged THEN%@NL@% a$ = "| " + "Current chart has not been saved. Save now?"%@NL@% %@NL@% status = Alert(4, a$, 8, 15, 12, 65, "Yes", "No", "Cancel")%@NL@% %@NL@% %@AB@% ' save chart%@AE@%%@NL@% IF status = OK THEN%@NL@% status = SaveChart(saveFile$, FALSE)%@NL@% END IF%@NL@% ELSE%@NL@% status = OK%@NL@% END IF%@NL@% %@NL@% %@AB@% ' quit if operation has not been canceled.%@AE@%%@NL@% IF status <> CANCEL THEN%@NL@% CHDRIVE MID$(origPath$, 1, 2)%@NL@% CHDIR MID$(origPath$, 3, LEN(origPath$))%@NL@% finished = TRUE%@NL@% MouseHide%@NL@% COLOR 15, 0%@NL@% CLS%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ScrollList%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Handles scrolling for a list box.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: text$() - list%@AE@%%@NL@% %@AB@%' tbox - list box%@AE@%%@NL@% %@AB@%' currButton - current button%@AE@%%@NL@% %@AB@%' status - to determine if button was pressed, or up or down arrow%@AE@%%@NL@% %@AB@%' keys were used%@AE@%%@NL@% %@AB@%' func - for special operations (passed to DrawList)%@AE@%%@NL@% %@AB@%' winRow - top row of current window%@AE@%%@NL@% %@AB@%' winCol - left column of current window%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ScrollList (text$(), tbox AS ListBox, currButton, status, func, winRow, winCol)%@NL@% %@NL@% %@AB@% ' scroll using scroll buttons%@AE@%%@NL@% IF currButton = tbox.scrollButton AND status = 1 THEN%@NL@% SELECT CASE Dialog(19)%@NL@% %@AB@% ' scroll up%@AE@%%@NL@% CASE -1:%@NL@% IF tbox.currTop > 1 THEN%@NL@% tbox.currTop = tbox.currTop - 1%@NL@% tbox.currPos = tbox.currPos + 1%@NL@% IF tbox.currPos > tbox.maxLen THEN tbox.currPos = tbox.maxLen%@NL@% END IF%@NL@% %@AB@% ' scroll down%@AE@%%@NL@% CASE -2:%@NL@% IF tbox.currTop + tbox.maxLen <= tbox.listLen THEN%@NL@% tbox.currTop = tbox.currTop + 1%@NL@% tbox.currPos = tbox.currPos - 1%@NL@% IF tbox.currPos < 1 THEN tbox.currPos = 1%@NL@% END IF%@NL@% %@AB@% ' scroll to position%@AE@%%@NL@% CASE ELSE:%@NL@% position = Dialog(19)%@NL@% IF position > 1 THEN%@NL@% position = position * (tbox.listLen) / (tbox.boxLen - 2)%@NL@% IF position < 1 THEN%@NL@% positon = 1%@NL@% ELSEIF position > tbox.listLen THEN%@NL@% position = tbox.listLen%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% IF tbox.currTop <= position AND tbox.currTop + tbox.maxLen > position THEN%@NL@% tbox.currPos = position - tbox.currTop + 1%@NL@% ELSEIF position <= tbox.maxLen THEN%@NL@% tbox.currTop = 1%@NL@% tbox.currPos = position%@NL@% ELSE%@NL@% tbox.currTop = position - tbox.maxLen + 1%@NL@% tbox.currPos = position - tbox.currTop + 1%@NL@% END IF%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' area button chosen%@AE@%%@NL@% ELSEIF status = 1 THEN%@NL@% %@AB@% ' make selected position the current position%@AE@%%@NL@% IF Dialog(17) <= tbox.maxLen THEN%@NL@% tbox.currPos = Dialog(17)%@NL@% DrawList text$(), tbox, func%@NL@% END IF%@NL@% %@NL@% %@AB@% ' poll for repeated scrolling while mouse button is down%@AE@%%@NL@% DO%@NL@% X! = TIMER%@NL@% MousePoll r, c, lb, rb ' poll mouse%@NL@% IF lb = TRUE THEN%@NL@% %@AB@% ' if below list box then scroll down%@AE@%%@NL@% IF r > tbox.botRow + winRow - 2 THEN%@NL@% GOSUB Down1%@NL@% %@AB@% ' if above list box then scroll up%@AE@%%@NL@% ELSEIF r < tbox.topRow + winRow THEN%@NL@% GOSUB Up1%@NL@% %@AB@% ' if to right of list box then scroll down%@AE@%%@NL@% ELSEIF c > tbox.rightCol + winCol - 2 THEN%@NL@% GOSUB Down1%@NL@% %@AB@% ' if to left of list box then scroll up%@AE@%%@NL@% ELSEIF c < tbox.leftCol + winCol THEN%@NL@% GOSUB Up1%@NL@% %@AB@% ' inside box%@AE@%%@NL@% ELSEIF r - winRow - tbox.topRow + 1 <= tbox.maxLen THEN%@NL@% tbox.currPos = r - winRow - tbox.topRow + 1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' draw list%@AE@%%@NL@% DrawList text$(), tbox, func%@NL@% ELSE%@NL@% EXIT DO%@NL@% END IF%@NL@% WHILE TIMER < X! + .05: WEND%@NL@% LOOP%@NL@% %@NL@% %@AB@% ' up arrow key hit%@AE@%%@NL@% ELSEIF status = 2 THEN%@NL@% GOSUB Up1%@NL@% %@NL@% %@AB@% ' down arrow key hit%@AE@%%@NL@% ELSEIF status = 3 THEN%@NL@% GOSUB Down1%@NL@% END IF%@NL@% %@NL@% DrawList text$(), tbox, func ' redraw list%@NL@% %@NL@% EXIT SUB%@NL@% %@NL@% %@AB@%' scroll list up one%@AE@%%@NL@% Up1:%@NL@% IF tbox.currPos > 1 THEN%@NL@% tbox.currPos = tbox.currPos - 1%@NL@% ELSEIF tbox.currTop > 1 THEN%@NL@% tbox.currTop = tbox.currTop - 1%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% %@AB@%' scroll list down one%@AE@%%@NL@% Down1:%@NL@% IF tbox.currPos < tbox.maxLen THEN%@NL@% tbox.currPos = tbox.currPos + 1%@NL@% ELSEIF tbox.currTop + tbox.maxLen <= tbox.listLen THEN%@NL@% tbox.currTop = tbox.currTop + 1%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: Setatt%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Changes a color's attribute to that of another color's.%@AE@%%@NL@% %@AB@%' This is used in the ChangeTitle routine to allow user%@AE@%%@NL@% %@AB@%' color selections to immediately change the foreground%@AE@%%@NL@% %@AB@%' color of the title edit field. This allows the user%@AE@%%@NL@% %@AB@%' to view the colors as they would look on a chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: change - color to change%@AE@%%@NL@% %@AB@%' source - color to change to%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB SetAtt (change, source)%@NL@% SHARED screenMode AS INTEGER%@NL@% SHARED egacolor() AS INTEGER%@NL@% %@NL@% %@AB@% ' map colors$ based on screen mode%@AE@%%@NL@% SELECT CASE screenMode%@NL@% CASE 10:%@NL@% IF source > 2 THEN%@NL@% temp = 9 ' set "normal" and "blink" to white%@NL@% ELSE%@NL@% temp = source ' off = black; high white = bright white%@NL@% END IF%@NL@% CASE 1:%@NL@% IF source = 3 THEN ' map to cyan%@NL@% temp = 13%@NL@% ELSEIF source = 4 THEN ' map to magenta%@NL@% temp = 15%@NL@% ELSE ' others okay%@NL@% temp = source%@NL@% END IF%@NL@% CASE ELSE%@NL@% temp = source ' colors$ okay%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' change attribute%@AE@%%@NL@% DIM regs AS RegType%@NL@% regs.ax = &H1000%@NL@% regs.bx = 256 * egacolor(TrueColr(temp)) + change%@NL@% CALL INTERRUPT(&H10, regs, regs)%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: SetDisplayColor%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Changes the program's display to monochrome (no colors) or%@AE@%%@NL@% %@AB@%' to color (include colors in menu bar) based on the value of%@AE@%%@NL@% %@AB@%' colorDisplay.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB SetDisplayColor%@NL@% SHARED colorDisplay AS INTEGER%@NL@% %@NL@% MouseHide%@NL@% %@NL@% %@AB@% ' redraw background based on display color%@AE@%%@NL@% SetUpBackground%@NL@% %@NL@% %@AB@% ' set menu bar to include colors%@AE@%%@NL@% IF colorDisplay THEN%@NL@% MenuSetState OPTIONSTITLE, 1, 2%@NL@% MenuSetState OPTIONSTITLE, 2, 1%@NL@% MenuColor 0, 7, 4, 8, 0, 4, 7%@NL@% %@AB@% ' set monochrome menu bar%@AE@%%@NL@% ELSE%@NL@% MenuSetState OPTIONSTITLE, 1, 1%@NL@% MenuSetState OPTIONSTITLE, 2, 2%@NL@% MenuColor 0, 7, 15, 8, 7, 0, 15%@NL@% END IF%@NL@% %@NL@% MenuShow%@NL@% MouseShow%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: SetUpBackground%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Creates and displays background screen pattern%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB SetUpBackground%@NL@% SHARED colorDisplay AS INTEGER%@NL@% %@NL@% MouseHide%@NL@% %@NL@% WIDTH , 25%@NL@% IF colorDisplay THEN%@NL@% COLOR 15, 1 ' set color for background%@NL@% ELSE%@NL@% COLOR 15, 0%@NL@% END IF%@NL@% CLS%@NL@% %@NL@% FOR a = 2 TO 80 STEP 4 ' create and display pattern%@NL@% FOR b = 2 TO 25 STEP 2%@NL@% LOCATE b, a%@NL@% PRINT CHR$(250);%@NL@% NEXT b%@NL@% NEXT a%@NL@% %@NL@% MouseShow%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: SetUpMenu%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Creates menu bar for the program%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB SetUpMenu%@NL@% %@NL@% %@AB@% ' file menu title%@AE@%%@NL@% MenuSet FILETITLE, 0, 1, "File", 1%@NL@% MenuSet FILETITLE, 1, 1, "New", 1%@NL@% MenuSet FILETITLE, 2, 1, "Open ...", 1%@NL@% MenuSet FILETITLE, 3, 1, "Save", 1%@NL@% MenuSet FILETITLE, 4, 1, "Save As ...", 6%@NL@% MenuSet FILETITLE, 5, 1, "-", 1%@NL@% MenuSet FILETITLE, 6, 1, "Exit", 2%@NL@% %@NL@% %@AB@% ' view menu title%@AE@%%@NL@% MenuSet VIEWTITLE, 0, 1, "View", 1%@NL@% MenuSet VIEWTITLE, 1, 1, "Data ...", 1%@NL@% MenuSet VIEWTITLE, 2, 1, "Chart F5", 1%@NL@% MenuSet VIEWTITLE, 3, 1, "Fonts ...", 1%@NL@% MenuSet VIEWTITLE, 4, 1, "Screen Mode ...", 1%@NL@% %@NL@% %@AB@% ' gallery menu title%@AE@%%@NL@% MenuSet GALLERYTITLE, 0, 1, "Gallery", 1%@NL@% MenuSet GALLERYTITLE, 1, 1, "Bar ...", 1%@NL@% MenuSet GALLERYTITLE, 2, 1, "Column ...", 1%@NL@% MenuSet GALLERYTITLE, 3, 1, "Line ...", 1%@NL@% MenuSet GALLERYTITLE, 4, 1, "Scatter ...", 1%@NL@% MenuSet GALLERYTITLE, 5, 1, "Pie ...", 1%@NL@% %@NL@% %@AB@% ' chart menu title%@AE@%%@NL@% MenuSet CHARTTITLE, 0, 1, "Chart", 1%@NL@% MenuSet CHARTTITLE, 1, 1, "Chart Window ...", 1%@NL@% MenuSet CHARTTITLE, 2, 1, "Data Window ...", 1%@NL@% MenuSet CHARTTITLE, 3, 1, "Legend ...", 1%@NL@% MenuSet CHARTTITLE, 4, 1, "X Axis ...", 1%@NL@% MenuSet CHARTTITLE, 5, 1, "Y Axis ...", 1%@NL@% %@NL@% %@AB@% ' title menu title%@AE@%%@NL@% MenuSet TITLETITLE, 0, 1, "Title", 1%@NL@% MenuSet TITLETITLE, 1, 1, "Main ...", 1%@NL@% MenuSet TITLETITLE, 2, 1, "Sub ...", 1%@NL@% MenuSet TITLETITLE, 3, 1, "X Axis ...", 1%@NL@% MenuSet TITLETITLE, 4, 1, "Y Axis ...", 1%@NL@% %@NL@% %@AB@% ' options menu title%@AE@%%@NL@% MenuSet OPTIONSTITLE, 0, 1, "Options", 1%@NL@% MenuSet OPTIONSTITLE, 1, 1, "Color", 1%@NL@% MenuSet OPTIONSTITLE, 2, 1, "Monochrome", 1%@NL@% %@NL@% %@AB@% ' setup short cuts for some menu choices%@AE@%%@NL@% ShortCutKeySet VIEWTITLE, 2, CHR$(0) + CHR$(63) ' F5 = View Chart%@NL@% %@NL@% %@AB@% ' set original menu colors for monochrome screen%@AE@%%@NL@% MenuColor 0, 7, 15, 8, 7, 0, 15%@NL@% MenuPreProcess%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Function Name: TrueColr%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Maps a given chart color to its actual color%@AE@%%@NL@% %@AB@%' and returns this color. This is needed because the chart%@AE@%%@NL@% %@AB@%' colors start with BLACK = 1 and HIGH WHITE = 2%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: colr - chart color number%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION TrueColr% (colr)%@NL@% %@NL@% IF colr = 1 THEN ' black%@NL@% TrueColr% = 0 ' bright white%@NL@% ELSEIF colr = 2 THEN%@NL@% TrueColr% = 15%@NL@% ELSE%@NL@% TrueColr% = colr - 2 ' all others%@NL@% END IF%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ViewChart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Displays the chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ViewChart%@NL@% SHARED setVal!(), Cat$(), setLen() AS INTEGER, setName$()%@NL@% SHARED screenMode AS INTEGER%@NL@% %@NL@% %@AB@% ' When a chart is drawn, data is moved from the 2-dimensional array%@AE@%%@NL@% %@AB@% ' into arrays suitable for the charting library routines. The%@AE@%%@NL@% %@AB@% ' following arrays are used directly in calls to the charting routines:%@AE@%%@NL@% DIM ValX1!(1 TO cMaxValues) ' pass to chart routine%@NL@% DIM ValY1!(1 TO cMaxValues)%@NL@% DIM ValX2!(1 TO cMaxValues, 1 TO cMaxSeries) ' pass to chartMS routine%@NL@% DIM ValY2!(1 TO cMaxValues, 1 TO cMaxSeries)%@NL@% %@NL@% DIM explode(1 TO cMaxValues) AS INTEGER ' explode pie chart pieces%@NL@% %@NL@% %@NL@% %@AB@% ' Make sure some data exists%@AE@%%@NL@% IF setNum <= 0 THEN%@NL@% a$ = "|"%@NL@% a$ = a$ + "No data available for chart."%@NL@% junk = Alert(4, a$, 8, 15, 12, 65, "", "", "")%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% ' find the longest series%@AE@%%@NL@% maxLen% = 0%@NL@% FOR i% = 1 TO setNum%@NL@% IF setLen(i%) > maxLen% THEN maxLen% = setLen(i%)%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' Set up the proper screen mode (exit if not valid)%@AE@%%@NL@% ChartScreen screenMode%@NL@% IF ChartErr = cBadScreen THEN%@NL@% PrintError "Invalid screen mode. Can't display chart."%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Process depending on chart type%@AE@%%@NL@% SELECT CASE CEnv.ChartType%@NL@% CASE cBar, cColumn, cLine, cPie:%@NL@% %@AB@% ' If the chart is a single series one or a pie chart:%@AE@%%@NL@% IF setNum = 1 OR CEnv.ChartType = cPie THEN%@NL@% %@NL@% %@AB@% ' Transfer data into a single dimension array:%@AE@%%@NL@% FOR i% = 1 TO maxLen%%@NL@% ValX1!(i%) = setVal!(i%, 1)%@NL@% NEXT i%%@NL@% %@NL@% IF CEnv.ChartType = cPie THEN%@NL@% %@AB@% ' determine which pieces to explode%@AE@%%@NL@% FOR i% = 1 TO maxLen%%@NL@% IF setVal!(i%, 2) <> 0 THEN%@NL@% explode(i%) = 1%@NL@% ELSE%@NL@% explode(i%) = 0%@NL@% END IF%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' display pie chart%@AE@%%@NL@% ChartPie CEnv, Cat$(), ValX1!(), explode(), maxLen%%@NL@% ELSE%@NL@% Chart CEnv, Cat$(), ValX1!(), maxLen%%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If multiple series, then data is OK so just call routine:%@AE@%%@NL@% ELSE%@NL@% ChartMS CEnv, Cat$(), setVal!(), maxLen%, 1, setNum, setName$()%@NL@% END IF%@NL@% %@NL@% CASE cScatter:%@NL@% %@AB@% ' Make sure there's enough data sets:%@AE@%%@NL@% IF setNum = 1 THEN%@NL@% SCREEN 0%@NL@% WIDTH 80%@NL@% SetUpBackground%@NL@% MenuShow%@NL@% MouseShow%@NL@% a$ = "|"%@NL@% a$ = a$ + "Too few data sets for Scatter chart"%@NL@% junk = Alert(4, a$, 8, 15, 12, 65, "", "", "")%@NL@% EXIT SUB%@NL@% %@NL@% %@AB@% ' If it's a single series scatter, transfer data to one-%@AE@%%@NL@% %@AB@% ' dimensional arrays and make chart call:%@AE@%%@NL@% ELSEIF setNum = 2 THEN%@NL@% FOR i% = 1 TO maxLen%%@NL@% ValX1!(i%) = setVal!(i%, 1)%@NL@% ValY1!(i%) = setVal!(i%, 2)%@NL@% NEXT i%%@NL@% ChartScatter CEnv, ValX1!(), ValY1!(), maxLen%%@NL@% %@NL@% %@AB@% ' If it's a multiple series scatter, transfer odd columns to%@AE@%%@NL@% %@AB@% ' X-axis data array and even columns to Y-axis array and make%@AE@%%@NL@% %@AB@% ' chart call:%@AE@%%@NL@% ELSE%@NL@% FOR j% = 2 TO setNum STEP 2%@NL@% FOR i% = 1 TO maxLen%%@NL@% ValX2!(i%, j% \ 2) = setVal!(i%, j% - 1)%@NL@% ValY2!(i%, j% \ 2) = setVal!(i%, j%)%@NL@% NEXT i%%@NL@% NEXT j%%@NL@% %@NL@% ChartScatterMS CEnv, ValX2!(), ValY2!(), maxLen%, 1, setNum \ 2, setName$()%@NL@% END IF%@NL@% %@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' If there's been a "fatal" error, indicate what it was:%@AE@%%@NL@% IF ChartErr <> 0 THEN%@NL@% GOSUB ViewError%@NL@% %@NL@% %@AB@% ' Otherwise, just wait for a keypress:%@AE@%%@NL@% ELSE%@NL@% %@AB@% ' Wait for keypress%@AE@%%@NL@% DO%@NL@% c$ = INKEY$%@NL@% MousePoll r, c, lb, rb%@NL@% LOOP UNTIL c$ <> "" OR lb OR rb%@NL@% SCREEN 0%@NL@% WIDTH 80%@NL@% SetUpBackground%@NL@% MenuShow%@NL@% MouseShow%@NL@% END IF%@NL@% %@NL@% EXIT SUB%@NL@% %@NL@% %@AB@%' handle charting errors%@AE@%%@NL@% ViewError:%@NL@% %@NL@% %@AB@% ' re-init the display%@AE@%%@NL@% SCREEN 0%@NL@% WIDTH 80%@NL@% SetUpBackground%@NL@% MenuShow%@NL@% MouseShow%@NL@% %@NL@% %@AB@% ' display appropriate error message%@AE@%%@NL@% SELECT CASE ChartErr%@NL@% CASE cBadDataWindow:%@NL@% PrintError "Data window cannot be displayed in available space."%@NL@% CASE cBadLegendWindow:%@NL@% PrintError "Invalid legend coordinates."%@NL@% CASE cTooFewSeries:%@NL@% PrintError "Too few series to plot."%@NL@% CASE cTooSmallN:%@NL@% PrintError "No data in series."%@NL@% CASE IS > 200: ' basic error%@NL@% PrintError "BASIC error #" + LTRIM$(STR$(ChartErr - 200)) + " occurred."%@NL@% CASE ELSE: ' extraneous error%@NL@% PrintError "Charting error #" + LTRIM$(STR$(ChartErr)) + " occurred."%@NL@% END SELECT%@NL@% %@NL@% RETURN%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ViewFont%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Displays list of registered fonts and allows user to%@AE@%%@NL@% %@AB@%' select one or more of these fonts to load%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ViewFont%@NL@% SHARED screenMode AS INTEGER%@NL@% SHARED origPath$%@NL@% DIM FI AS FontInfo%@NL@% DIM rfonts$(1 TO MAXFONTS)%@NL@% %@NL@% SetMaxFonts MAXFONTS, MAXFONTS%@NL@% %@NL@% %@AB@% ' get default font%@AE@%%@NL@% DefaultFont Segment%, Offset%%@NL@% numReg = RegisterMemFont%(Segment%, Offset%)%@NL@% %@NL@% %@AB@% ' use font files that are best suited for current screen mode%@AE@%%@NL@% IF MID$(origPath$, LEN(origPath$), 1) = "\" THEN%@NL@% t$ = ""%@NL@% ELSE%@NL@% t$ = "\"%@NL@% END IF%@NL@% SELECT CASE screenMode%@NL@% CASE 2, 8%@NL@% cour$ = origPath$ + t$ + "COURA.FON"%@NL@% helv$ = origPath$ + t$ + "HELVA.FON"%@NL@% tims$ = origPath$ + t$ + "TMSRA.FON"%@NL@% CASE 11, 12%@NL@% cour$ = origPath$ + t$ + "COURE.FON"%@NL@% helv$ = origPath$ + t$ + "HELVE.FON"%@NL@% tims$ = origPath$ + t$ + "TMSRE.FON"%@NL@% CASE ELSE%@NL@% cour$ = origPath$ + t$ + "COURB.FON"%@NL@% helv$ = origPath$ + t$ + "HELVB.FON"%@NL@% tims$ = origPath$ + t$ + "TMSRB.FON"%@NL@% END SELECT%@NL@% %@AB@% ' register courier fonts%@AE@%%@NL@% numReg = numReg + RegisterFonts%(cour$)%@NL@% fontname$ = cour$%@NL@% IF FontErr > 0 THEN GOSUB FontError%@NL@% %@NL@% %@AB@% ' register helvetica fonts%@AE@%%@NL@% numReg = numReg + RegisterFonts%(helv$)%@NL@% fontname$ = helv$%@NL@% IF FontErr > 0 THEN GOSUB FontError%@NL@% %@NL@% %@AB@% ' register times roman fonts%@AE@%%@NL@% numReg = numReg + RegisterFonts%(tims$)%@NL@% fontname$ = tims$%@NL@% IF FontErr > 0 THEN GOSUB FontError%@NL@% %@NL@% %@AB@% ' create a list of registered fonts%@AE@%%@NL@% FOR i = 1 TO numReg%@NL@% GetRFontInfo i, FI%@NL@% rfonts$(i) = RTRIM$(MID$(FI.FaceName, 1, 8)) + STR$(FI.Points) + " Point"%@NL@% NEXT i%@NL@% %@NL@% %@AB@% ' set up window display%@AE@%%@NL@% winRow = 5%@NL@% winCol = 25%@NL@% WindowOpen 1, winRow, winCol, winRow + numReg + 1, 51, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 2, "Chart Fonts"%@NL@% %@NL@% %@AB@% ' open buttons for each font in list%@AE@%%@NL@% FOR i% = 1 TO numReg%@NL@% ButtonOpen i, 1, rfonts$(i), i, 4, 0, 0, 2%@NL@% FOR j% = 1 TO numFonts%@NL@% IF fonts$(j%) = rfonts$(i%) THEN ButtonSetState i, 2%@NL@% NEXT j%%@NL@% NEXT i%%@NL@% %@NL@% WindowLine numReg + 1%@NL@% ButtonOpen numReg + 1, 2, "Load", numReg + 2, 4, 0, 0, 1%@NL@% ButtonOpen numReg + 2, 1, "Cancel ", numReg + 2, 15, 0, 0, 1%@NL@% %@NL@% %@AB@% ' start with cursor on first button%@AE@%%@NL@% currButton = 1%@NL@% pushButton = numReg + 1%@NL@% %@NL@% %@AB@% ' window control loop%@AE@%%@NL@% finished = FALSE%@NL@% WHILE NOT finished%@NL@% WindowDo currButton, 0%@NL@% SELECT CASE Dialog(0)%@NL@% CASE 1 ' button pressed%@NL@% currButton = Dialog(1)%@NL@% IF currButton > numReg THEN%@NL@% pushButton = currButton%@NL@% finished = TRUE%@NL@% ELSE%@NL@% ButtonToggle currButton%@NL@% END IF%@NL@% CASE 6 ' enter%@NL@% finished = TRUE%@NL@% CASE 7 ' tab%@NL@% SELECT CASE currButton%@NL@% CASE numReg, numReg + 1:%@NL@% currButton = currButton + 1%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% CASE numReg + 2:%@NL@% currButton = 1%@NL@% ButtonSetState pushButton, 1%@NL@% pushButton = numReg + 1%@NL@% ButtonSetState pushButton, 2%@NL@% CASE ELSE:%@NL@% currButton = currButton + 1%@NL@% END SELECT%@NL@% CASE 8 ' back tab%@NL@% SELECT CASE currButton%@NL@% CASE 1:%@NL@% currButton = numReg + 2%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% CASE numReg + 2:%@NL@% currButton = numReg + 1%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = currButton%@NL@% CASE ELSE:%@NL@% currButton = currButton - 1%@NL@% END SELECT%@NL@% CASE 9 ' escape%@NL@% pushButton = numReg + 2%@NL@% finished = TRUE%@NL@% CASE 10, 12 ' up, left arrow%@NL@% IF currButton <= numReg THEN ButtonSetState currButton, 2%@NL@% CASE 11, 13 ' down, right arrow%@NL@% IF currButton <= numReg THEN ButtonSetState currButton, 1%@NL@% CASE 14 ' space bar%@NL@% IF currButton <= numReg THEN%@NL@% ButtonToggle currButton%@NL@% ELSE%@NL@% finished = TRUE%@NL@% END IF%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' finished and not cancelled%@AE@%%@NL@% IF finished AND pushButton = numReg + 1 THEN%@NL@% %@AB@% ' create font spec for load operation%@AE@%%@NL@% FontSpec$ = ""%@NL@% FOR i% = 1 TO numReg%@NL@% IF ButtonInquire(i) = 2 THEN%@NL@% FontSpec$ = FontSpec$ + "/n" + LTRIM$(STR$(i))%@NL@% END IF%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' default if none chosen%@AE@%%@NL@% IF FontSpec$ = "" THEN%@NL@% PrintError "No fonts selected - using default."%@NL@% numFonts = LoadFont%("N1")%@NL@% REDIM fonts$(1)%@NL@% fonts$(1) = rfonts$(1)%@NL@% ELSE%@NL@% %@AB@% ' load selected fonts%@AE@%%@NL@% numLoaded = LoadFont%(RIGHT$(FontSpec$, LEN(FontSpec$) - 1))%@NL@% %@NL@% %@AB@% ' notify user of error and let them try again.%@AE@%%@NL@% IF FontErr <> 0 THEN%@NL@% GOSUB FontError%@NL@% finished = FALSE%@NL@% currButton = 1%@NL@% ELSE%@NL@% REDIM fonts$(numLoaded)%@NL@% %@AB@% ' create a list of loaded fonts%@AE@%%@NL@% FOR i = 1 TO numLoaded%@NL@% SelectFont i%@NL@% GetFontInfo FI%@NL@% fonts$(i) = RTRIM$(MID$(FI.FaceName, 1, 8)) + STR$(FI.Points) + " Point"%@NL@% NEXT i%@NL@% numFonts = numLoaded%@NL@% ClearFonts%@NL@% END IF%@NL@% END IF%@NL@% %@AB@% ' reload existing fonts if operation cancelled%@AE@%%@NL@% ELSEIF finished = TRUE AND pushButton = numReg + 2 THEN%@NL@% FontSpec$ = ""%@NL@% FOR i = 1 TO numReg%@NL@% FOR j% = 1 TO numFonts%@NL@% IF fonts$(j%) = rfonts$(i%) THEN FontSpec$ = FontSpec$ + "/n" + LTRIM$(STR$(i))%@NL@% NEXT j%%@NL@% NEXT i%@NL@% numFonts = LoadFont%(RIGHT$(FontSpec$, LEN(FontSpec$) - 1))%@NL@% END IF%@NL@% %@NL@% WEND%@NL@% %@NL@% UnRegisterFonts%@NL@% %@NL@% WindowClose 1%@NL@% %@NL@% EXIT SUB%@NL@% %@NL@% %@AB@%' handle font loading errors%@AE@%%@NL@% FontError:%@NL@% SELECT CASE FontErr%@NL@% CASE cNoFontMem:%@NL@% PrintError "Not enough memory to load selected fonts."%@NL@% CASE cFileNotFound:%@NL@% PrintError fontname$ + " font file not found."%@NL@% CASE cTooManyFonts:%@NL@% numReg = MAXFONTS%@NL@% CASE cBadFontFile:%@NL@% PrintError "Invalid font file format for " + fontname$ + "."%@NL@% CASE cNoFonts:%@NL@% PrintError "No fonts are loaded."%@NL@% CASE cBadFontType:%@NL@% PrintError "Font not a bitmap font."%@NL@% CASE IS > 200: ' basic error%@NL@% PrintError "BASIC error #" + LTRIM$(STR$(FontErr - 200)) + " occurred."%@NL@% CASE ELSE ' unplanned font error%@NL@% PrintError "Font error #" + LTRIM$(STR$(FontErr)) + " occurred."%@NL@% END SELECT%@NL@% %@NL@% RETURN%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ViewScreenMode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Displays list of valid screen modes and allows the%@AE@%%@NL@% %@AB@%' user to select one for viewing the chart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ViewScreenMode%@NL@% SHARED screenMode AS INTEGER, numModes AS INTEGER, mode$()%@NL@% %@NL@% DIM modeBox AS ListBox%@NL@% %@NL@% %@AB@% ' set up list box containing valid screen modes%@AE@%%@NL@% modeBox.scrollButton = 1%@NL@% modeBox.areaButton = 2%@NL@% modeBox.listLen = numModes%@NL@% modeBox.topRow = 1%@NL@% modeBox.botRow = numModes + 2%@NL@% modeBox.leftCol = 7%@NL@% modeBox.rightCol = 21%@NL@% %@NL@% %@AB@% ' determine current screen mode%@AE@%%@NL@% FOR i = 1 TO numModes%@NL@% IF screenMode = VAL(mode$(i)) THEN modeBox.listPos = i%@NL@% NEXT i%@NL@% %@NL@% %@AB@% ' set up display window%@AE@%%@NL@% winRow = 6%@NL@% winCol = 25%@NL@% WindowOpen 1, winRow, winCol, winRow + numModes + 3, 51, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 2, "Screen Mode"%@NL@% WindowLine numModes + 3%@NL@% %@NL@% %@AB@% ' create the list box%@AE@%%@NL@% CreateListBox mode$(), modeBox, 0%@NL@% %@NL@% %@AB@% ' open command buttons%@AE@%%@NL@% ButtonOpen 3, 2, "OK ", numModes + 4, 4, 0, 0, 1%@NL@% ButtonOpen 4, 1, "Cancel ", numModes + 4, 16, 0, 0, 1%@NL@% %@NL@% %@NL@% a$ = "Screen Mode Warning ||"%@NL@% a$ = a$ + "Selecting screen modes that support less than |"%@NL@% a$ = a$ + "than 16 colors will reset all chart colors to |"%@NL@% a$ = a$ + "their black and white defaults. |"%@NL@% a$ = a$ + "|" + " Fonts should be reloaded after screen mode is |"%@NL@% a$ = a$ + " changed to ensure best font match for screen |"%@NL@% a$ = a$ + " resolution. "%@NL@% junk = Alert(4, a$, 6, 15, 16, 65, "", "", "")%@NL@% %@NL@% %@NL@% %@AB@% ' start with cursor in area button%@AE@%%@NL@% currButton = 2%@NL@% pushButton = 3%@NL@% %@NL@% %@AB@% ' window control loop%@AE@%%@NL@% finished = FALSE%@NL@% WHILE NOT finished%@NL@% WindowDo currButton, 0 ' wait for event%@NL@% SELECT CASE Dialog(0)%@NL@% CASE 1 ' button pressed%@NL@% currButton = Dialog(1)%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2:%@NL@% ScrollList mode$(), modeBox, currButton, 1, 0, winRow, winCol%@NL@% currButton = 2%@NL@% CASE 3, 4:%@NL@% pushButton = currButton%@NL@% finished = TRUE%@NL@% END SELECT%@NL@% CASE 6 ' enter%@NL@% finished = TRUE%@NL@% CASE 7 ' tab%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2:%@NL@% currButton = 3%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = 3%@NL@% CASE 3:%@NL@% currButton = 4%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = 4%@NL@% CASE 4:%@NL@% ButtonSetState currButton, 1%@NL@% currButton = 2%@NL@% pushButton = 3%@NL@% ButtonSetState pushButton, 2%@NL@% END SELECT%@NL@% CASE 8 ' back tab%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2:%@NL@% currButton = 4%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = 4%@NL@% CASE 3: currButton = 2%@NL@% CASE 4:%@NL@% currButton = 3%@NL@% ButtonSetState pushButton, 1%@NL@% ButtonSetState currButton, 2%@NL@% pushButton = 3%@NL@% END SELECT%@NL@% CASE 9 ' escape%@NL@% pushButton = 4%@NL@% finished = TRUE%@NL@% CASE 10, 12 ' up, left arrow%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2: ScrollList mode$(), modeBox, currButton, 2, 0, winRow, winCol%@NL@% END SELECT%@NL@% CASE 11, 13 ' down, right arrow%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2: ScrollList mode$(), modeBox, currButton, 3, 0, winRow, winCol%@NL@% END SELECT%@NL@% CASE 14 ' space bar%@NL@% IF currButton > 2 THEN finished = TRUE%@NL@% END SELECT%@NL@% WEND%@NL@% %@NL@% %@AB@% ' if not canceled%@AE@%%@NL@% IF pushButton = 3 THEN%@NL@% %@AB@% ' change screen mode%@AE@%%@NL@% IF screenMode <> VAL(mode$(modeBox.listPos)) THEN%@NL@% IF setNum > 0 THEN chartChanged = TRUE%@NL@% %@NL@% screenMode = VAL(mode$(modeBox.listPos))%@NL@% %@NL@% %@AB@% ' reset window coords%@AE@%%@NL@% CEnv.ChartWindow.X1 = 0%@NL@% CEnv.ChartWindow.Y1 = 0%@NL@% CEnv.ChartWindow.X2 = 0%@NL@% CEnv.ChartWindow.Y2 = 0%@NL@% %@NL@% %@AB@% ' change color list based on new screen mode%@AE@%%@NL@% InitColors%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% WindowClose 1%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%CHRTDEMO.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\CHRTDEMO.BAS%@AE@%%@NL@% %@NL@% %@AB@%' CHRTDEMO.BAS - Main module of CHRTB demonstration program%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Copyright (C) 1989, Microsoft Corporation%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' This demo program uses the Presentation Graphics and User Interface%@AE@%%@NL@% %@AB@%' toolboxes to implement a general purpose charting package.%@AE@%%@NL@% %@AB@%' It consists of three modules (CHRTDEMO.BAS, CHRTDEM1.BAS and CHRTDEM2.BAS)%@AE@%%@NL@% %@AB@%' and one include file (CHRTDEMO.BI). It requires access to both the%@AE@%%@NL@% %@AB@%' Presentation Graphics and User Interface toolboxes.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' EMS is needed to load and run the demo under QBX. If you do not%@AE@%%@NL@% %@AB@%' have EMS, refer to the command line compile instructions below which%@AE@%%@NL@% %@AB@%' will allow you to run the demo from the DOS prompt. Running the%@AE@%%@NL@% %@AB@%' demo under QBX requires access to the Presentation Graphics and User%@AE@%%@NL@% %@AB@%' Interface toolboxes. This can be done in one of two methods:%@AE@%%@NL@% %@AB@%' 1) One large QuickLib covering both toolboxes can be created. The%@AE@%%@NL@% %@AB@%' library "CHRTDEM.LIB" and QuickLib "CHRTDEM.QLB" are created%@AE@%%@NL@% %@AB@%' as follows:%@AE@%%@NL@% %@AB@%' BC /X/FS chrtb.bas;%@AE@%%@NL@% %@AB@%' BC /X/FS fontb.bas;%@AE@%%@NL@% %@AB@%' LIB chrtdem.lib + uitbefr.lib + fontasm + chrtasm + fontb + chrtb;%@AE@%%@NL@% %@AB@%' LINK /Q chrtdem.lib, chrtdem.qlb,,qbxqlb.lib;%@AE@%%@NL@% %@AB@%' Once created, just start QBX with this QuickLib and load the%@AE@%%@NL@% %@AB@%' demo's modules (chrtdemo.bas, chrtdem1.bas and chrtdem2.bas).%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' 2) Either the Presentation Graphics or User Interface QuickLib%@AE@%%@NL@% %@AB@%' may be used alone provided the other's source code files%@AE@%%@NL@% %@AB@%' are loaded into the QBX environment. If CHRTBEFR.QLB is%@AE@%%@NL@% %@AB@%' is used then WINDOW.BAS, GENERAL.BAS, MENU.BAS and MOUSE.BAS%@AE@%%@NL@% %@AB@%' must be loaded. If UITBEFR.QLB is used then CHRTB.BAS and%@AE@%%@NL@% %@AB@%' FONTB.BAS must be loaded. Once a QuickLib is specified and%@AE@%%@NL@% %@AB@%' all necessary source files are loaded, load the program%@AE@%%@NL@% %@AB@%' modules (chrtdemo.bas, chrtdem1.bas and chrtdem2.bas)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' To create a compiled version of the chart demo program perform the%@AE@%%@NL@% %@AB@%' following steps:%@AE@%%@NL@% %@AB@%' BC /X/FS chrtb.bas;%@AE@%%@NL@% %@AB@%' BC /X/FS fontb.bas;%@AE@%%@NL@% %@AB@%' LIB chrtdem.lib + uitbefr.lib + fontasm + chrtasm + fontb + chrtb;%@AE@%%@NL@% %@AB@%' BC /X/FS chrtdemo.bas;%@AE@%%@NL@% %@AB@%' BC /FS chrtdem1.bas;%@AE@%%@NL@% %@AB@%' BC /FS chrtdem2.bas;%@AE@%%@NL@% %@AB@%' LINK /EX chrtdemo chrtdem1 chrtdem2, chrtdemo.exe,, chrtdem.lib;%@AE@%%@NL@% %@AB@%' "CHRTDEMO" can now be run from the command line.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% DEFINT A-Z%@NL@% %@NL@% %@AB@%'$INCLUDE: 'chrtdemo.bi'%@AE@%%@NL@% %@NL@% %@AB@%' local functions%@AE@%%@NL@% DECLARE FUNCTION GetLoadFile% (FileName$)%@NL@% DECLARE FUNCTION GetSaveFile% (FileName$)%@NL@% DECLARE FUNCTION GetFileCount% (fileSpec$)%@NL@% %@NL@% %@AB@%' local subs%@AE@%%@NL@% DECLARE SUB LoadChart (fileNum%)%@NL@% DECLARE SUB ShowError (errorNum%)%@NL@% %@NL@% %@NL@% %@AB@%' necessary variables for the toolboxes%@AE@%%@NL@% DIM GloTitle(MAXMENU) AS MenuTitleType%@NL@% DIM GloItem(MAXMENU, MAXITEM) AS MenuItemType%@NL@% DIM GloWindow(MAXWINDOW) AS windowType%@NL@% DIM GloButton(MAXBUTTON) AS buttonType%@NL@% DIM GloEdit(MAXEDITFIELD) AS EditFieldType%@NL@% DIM GloWindowStack(MAXWINDOW) AS INTEGER%@NL@% DIM GloBuffer$(MAXWINDOW + 1, 2)%@NL@% %@NL@% %@AB@%' variables shared across modules%@AE@%%@NL@% DIM colors$(1 TO MAXCOLORS) 'valid colors$%@NL@% DIM styles$(1 TO MAXSTYLES) 'border style list%@NL@% DIM fonts$(1 TO MAXFONTS) 'fonts list%@NL@% DIM Cat$(1 TO cMaxValues) 'category names%@NL@% DIM setName$(1 TO cMaxSets) 'set names%@NL@% DIM setLen(1 TO cMaxSets) AS INTEGER '# values per set%@NL@% DIM setVal!(1 TO cMaxValues, 1 TO cMaxSets) ' actual values%@NL@% DIM mode$(1 TO 13) 'list of modes%@NL@% %@NL@% %@NL@% %@AB@% ' set up main error handler%@AE@%%@NL@% ON ERROR GOTO ErrorHandle%@NL@% %@NL@% %@AB@% ' initialize the program%@AE@%%@NL@% InitAll%@NL@% %@NL@% %@AB@% ' Main loop%@AE@%%@NL@% WHILE NOT finished%@NL@% kbd$ = MenuInkey$%@NL@% WHILE MenuCheck(2)%@NL@% HandleMenuEvent%@NL@% WEND%@NL@% WEND%@NL@% %@NL@% END%@NL@% %@NL@% %@AB@%'catch all error handler%@AE@%%@NL@% ErrorHandle:%@NL@% ShowError ERR%@NL@% WindowClose 1 ' close any active windows%@NL@% WindowClose 2%@NL@% RESUME NEXT%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Function Name: GetBestMode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Creates a list of valid screen modes for use by charting functions%@AE@%%@NL@% %@AB@%' and sets the initial screen mode to the highest resolution%@AE@%%@NL@% %@AB@%' possible. If no graphic screen modes are available then%@AE@%%@NL@% %@AB@%' it causes the program to exit.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: screenMode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB GetBestMode (screenMode)%@NL@% SHARED mode$(), numModes AS INTEGER%@NL@% %@NL@% ON LOCAL ERROR GOTO badmode ' trap screen mode errors%@NL@% %@NL@% %@AB@% ' test all possible screen modes creating a list of valid ones as we go%@AE@%%@NL@% numModes = 0%@NL@% FOR i = 13 TO 1 STEP -1%@NL@% valid = TRUE%@NL@% SCREEN i%@NL@% IF valid THEN%@NL@% numModes = numModes + 1%@NL@% mode$(numModes) = LTRIM$(STR$(i))%@NL@% END IF%@NL@% NEXT i%@NL@% %@NL@% %@AB@% ' exit if no modes available%@AE@%%@NL@% IF numModes = 0 THEN%@NL@% screenMode = 0%@NL@% %@AB@% ' set current screen mode to best possible%@AE@%%@NL@% ELSEIF mode$(1) = "13" THEN%@NL@% screenMode = VAL(mode$(2))%@NL@% ELSE%@NL@% screenMode = VAL(mode$(1))%@NL@% END IF%@NL@% %@NL@% EXIT SUB%@NL@% %@NL@% badmode:%@NL@% valid = FALSE%@NL@% RESUME NEXT%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Func Name: GetFileCount%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Returns number of DOS files matching a given file spec%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: fileSpec$ - DOS file spec (i.e. "*.*")%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION GetFileCount% (fileSpec$)%@NL@% %@NL@% ON LOCAL ERROR GOTO GetCountError%@NL@% %@NL@% count = 0%@NL@% %@NL@% FileName$ = DIR$(fileSpec$) ' Get first match if any%@NL@% %@NL@% DO WHILE FileName$ <> "" ' continue until no more matches%@NL@% count = count + 1%@NL@% FileName$ = DIR$%@NL@% LOOP%@NL@% %@NL@% GetFileCount = count ' return count%@NL@% %@NL@% EXIT FUNCTION%@NL@% %@NL@% GetCountError:%@NL@% %@NL@% ShowError ERR ' display error message%@NL@% %@NL@% RESUME NEXT%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Func Name: GetLoadFile%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Called by OpenChart, this prompts the user for a%@AE@%%@NL@% %@AB@%' DOS file to open. It returns the file number of%@AE@%%@NL@% %@AB@%' the chart file with the actual file name being%@AE@%%@NL@% %@AB@%' passed back via the argument.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: FileName$ - name of file to open%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION GetLoadFile% (FileName$)%@NL@% DIM fileList$(1 TO 10)%@NL@% DIM fileBox AS ListBox%@NL@% %@NL@% ON LOCAL ERROR GOTO GetLoadError ' handle file opening errors%@NL@% %@NL@% fileSpec$ = "*.CHT" ' default file spec%@NL@% origDir$ = CURDIR$%@NL@% origPos = 0 ' no file list element selected%@NL@% %@NL@% %@AB@% ' get list of files matching spec%@AE@%%@NL@% fileCount = GetFileCount(fileSpec$)%@NL@% IF fileCount THEN%@NL@% REDIM fileList$(fileCount)%@NL@% END IF%@NL@% fileList$(1) = DIR$(fileSpec$)%@NL@% FOR i% = 2 TO fileCount%@NL@% fileList$(i%) = DIR$%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' set up list box for file list%@AE@%%@NL@% fileBox.scrollButton = 1%@NL@% fileBox.areaButton = 2%@NL@% fileBox.listLen = fileCount%@NL@% fileBox.topRow = 8%@NL@% fileBox.botRow = 14%@NL@% fileBox.leftCol = 7%@NL@% fileBox.rightCol = 22%@NL@% fileBox.listPos = origPos%@NL@% %@NL@% %@AB@% ' create window for display%@AE@%%@NL@% winRow = 6%@NL@% winCol = 25%@NL@% WindowOpen 1, winRow, winCol, 21, 52, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 2, "Open Chart"%@NL@% WindowLocate 2, 2%@NL@% WindowPrint 2, "File Name:"%@NL@% WindowBox 1, 13, 3, 27%@NL@% WindowLocate 5, 2%@NL@% WindowPrint -1, origDir$%@NL@% WindowLocate 7, 11%@NL@% WindowPrint 2, "Files"%@NL@% WindowLine 15%@NL@% %@NL@% %@AB@% ' create list box for file list%@AE@%%@NL@% CreateListBox fileList$(), fileBox, 5%@NL@% %@NL@% %@AB@% ' open edit field for file spec%@AE@%%@NL@% EditFieldOpen 1, fileSpec$, 2, 14, 0, 7, 13, 70%@NL@% %@NL@% %@AB@% ' open command buttons%@AE@%%@NL@% ButtonOpen 3, 2, "OK", 16, 5, 0, 0, 1%@NL@% ButtonOpen 4, 1, "Cancel", 16, 15, 0, 0, 1%@NL@% %@NL@% %@AB@% ' start with cursor in edit field%@AE@%%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% pushButton = 3%@NL@% %@NL@% %@AB@% ' control loop%@AE@%%@NL@% finished = FALSE%@NL@% WHILE NOT finished%@NL@% WindowDo currButton, currEditField ' wait for event%@NL@% SELECT CASE Dialog(0)%@NL@% CASE 1 ' button pressed%@NL@% currButton = Dialog(1)%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2: currEditField = 0%@NL@% ScrollList fileList$(), fileBox, currButton, 1, 0, winRow, winCol%@NL@% currButton = 2%@NL@% CASE 3, 4: pushButton = currButton%@NL@% finished = TRUE%@NL@% END SELECT%@NL@% CASE 2 ' Edit Field%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% CASE 6 ' enter%@NL@% IF INSTR(EditFieldInquire$(1), "*") = 0 THEN finished = TRUE%@NL@% CASE 7 ' tab%@NL@% SELECT CASE currButton%@NL@% CASE 0: currButton = 2%@NL@% currEditField = 0%@NL@% CASE 1, 2:%@NL@% currButton = 3%@NL@% ButtonSetState 3, 2%@NL@% ButtonSetState 4, 1%@NL@% pushButton = 3%@NL@% CASE 3:%@NL@% currButton = 4%@NL@% ButtonSetState 3, 1%@NL@% ButtonSetState 4, 2%@NL@% pushButton = 4%@NL@% CASE 4:%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% ButtonSetState 3, 2%@NL@% ButtonSetState 4, 1%@NL@% pushButton = 3%@NL@% END SELECT%@NL@% CASE 8 ' back tab%@NL@% SELECT CASE currButton%@NL@% CASE 0: currButton = 4%@NL@% currEditField = 0%@NL@% ButtonSetState 3, 1%@NL@% ButtonSetState 4, 2%@NL@% pushButton = 4%@NL@% CASE 1, 2:%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% CASE 3:%@NL@% currButton = 2%@NL@% CASE 4:%@NL@% currButton = 3%@NL@% ButtonSetState 3, 2%@NL@% ButtonSetState 4, 1%@NL@% pushButton = 3%@NL@% END SELECT%@NL@% CASE 9 ' escape%@NL@% pushButton = 4%@NL@% finished = TRUE%@NL@% CASE 10, 12 ' up, left arrow%@NL@% IF currButton = 1 OR currButton = 2 THEN ScrollList fileList$(), fileBox, currButton, 2, 0, winRow, winCol%@NL@% CASE 11, 13 'down, right arrow%@NL@% IF currButton = 1 OR currButton = 2 THEN ScrollList fileList$(), fileBox, currButton, 3, 0, winRow, winCol%@NL@% CASE 14 ' space bar%@NL@% IF currButton > 2 THEN%@NL@% pushButton = currButton%@NL@% finished = TRUE%@NL@% END IF%@NL@% END SELECT%@NL@% %@NL@% temp$ = EditFieldInquire$(1)%@NL@% %@NL@% %@AB@% ' simple error checking before finishing%@AE@%%@NL@% IF finished AND pushButton <> 4 THEN%@NL@% %@AB@% ' invalid file specified%@AE@%%@NL@% IF INSTR(temp$, "*") THEN%@NL@% PrintError "Invalid file specification."%@NL@% finished = FALSE%@NL@% ELSEIF LEN(temp$) = 0 THEN%@NL@% PrintError "Must specify a name."%@NL@% finished = FALSE%@NL@% ELSE%@NL@% fileSpec$ = temp$%@NL@% fileNum% = FREEFILE%@NL@% OPEN fileSpec$ FOR INPUT AS fileNum%%@NL@% %@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' more processing to do%@AE@%%@NL@% IF NOT finished THEN%@NL@% %@AB@% ' update edit field display based on list box selection%@AE@%%@NL@% IF fileBox.listPos <> origPos THEN%@NL@% fileSpec$ = fileList$(fileBox.listPos)%@NL@% origPos = fileBox.listPos%@NL@% EditFieldClose 1%@NL@% EditFieldOpen 1, fileSpec$, 2, 14, 0, 7, 13, 70%@NL@% %@AB@% ' update list box contents based on new edit field contents%@AE@%%@NL@% ELSEIF LTRIM$(RTRIM$(fileSpec$)) <> LTRIM$(RTRIM$(temp$)) THEN%@NL@% fileSpec$ = UCASE$(temp$)%@NL@% IF fileSpec$ <> "" THEN%@NL@% IF MID$(fileSpec$, 2, 1) = ":" THEN%@NL@% CHDRIVE MID$(fileSpec$, 1, 2)%@NL@% fileSpec$ = MID$(fileSpec$, 3, LEN(fileSpec$))%@NL@% END IF%@NL@% position = 0%@NL@% WHILE INSTR(position + 1, fileSpec$, "\") <> 0%@NL@% position = INSTR(position + 1, fileSpec$, "\")%@NL@% WEND%@NL@% IF position = 1 THEN%@NL@% CHDIR "\"%@NL@% ELSEIF position > 0 THEN%@NL@% CHDIR LEFT$(fileSpec$, position - 1)%@NL@% END IF%@NL@% fileSpec$ = MID$(fileSpec$, position + 1, LEN(fileSpec$))%@NL@% WindowLocate 5, 2%@NL@% IF LEN(CURDIR$) > 26 THEN%@NL@% direct$ = LEFT$(CURDIR$, 26)%@NL@% ELSE%@NL@% direct$ = CURDIR$%@NL@% END IF%@NL@% WindowPrint -1, direct$ + STRING$(26 - LEN(direct$), " ")%@NL@% %@NL@% fileCount = GetFileCount(fileSpec$)%@NL@% ELSE%@NL@% fileCount = 0%@NL@% END IF%@NL@% %@NL@% EditFieldClose 1%@NL@% EditFieldOpen 1, fileSpec$, 2, 14, 0, 7, 13, 70%@NL@% %@NL@% fileBox.listLen = fileCount%@NL@% fileBox.maxLen = Min(fileCount, fileBox.boxLen)%@NL@% origPos = 0%@NL@% fileBox.listPos = origPos%@NL@% fileBox.currTop = 1%@NL@% fileBox.currPos = 0%@NL@% %@AB@% ' get new file list%@AE@%%@NL@% IF fileCount = 0 THEN%@NL@% REDIM fileList$(10)%@NL@% ELSE%@NL@% REDIM fileList$(fileCount)%@NL@% fileList$(1) = DIR$(fileSpec$)%@NL@% FOR i% = 2 TO fileCount%@NL@% fileList$(i%) = DIR$%@NL@% NEXT i%%@NL@% END IF%@NL@% %@NL@% DrawList fileList$(), fileBox, 0 ' redraw file list%@NL@% END IF%@NL@% END IF%@NL@% WEND%@NL@% %@NL@% %@AB@% ' if operation not canceled return file name and file number%@AE@%%@NL@% IF pushButton = 3 THEN%@NL@% FileName$ = fileSpec$%@NL@% GetLoadFile% = fileNum%%@NL@% ELSE%@NL@% GetLoadFile% = 0%@NL@% %@NL@% CHDRIVE MID$(origDir$, 1, 2)%@NL@% CHDIR MID$(origDir$, 3, LEN(origDir$))%@NL@% END IF%@NL@% %@NL@% WindowClose 1%@NL@% %@NL@% EXIT FUNCTION%@NL@% %@NL@% %@AB@%' handle any file opening errors%@AE@%%@NL@% GetLoadError:%@NL@% CLOSE fileNum%%@NL@% finished = FALSE ' don't allow exit until valid file chosen%@NL@% %@NL@% ShowError ERR ' display error message%@NL@% RESUME NEXT%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Func Name: GetSaveFile%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Prompts the user for a DOS file to save the current%@AE@%%@NL@% %@AB@%' chart data and settings in. It returns the file number%@AE@%%@NL@% %@AB@%' with the actual file name being passed back via the%@AE@%%@NL@% %@AB@%' argument.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: fileName$ - name of save file%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION GetSaveFile% (FileName$)%@NL@% %@NL@% ON LOCAL ERROR GOTO GetSaveError ' handle file open errors%@NL@% %@NL@% %@AB@% ' Open window for display%@AE@%%@NL@% WindowOpen 1, 8, 20, 12, 58, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 1, "Save Chart As"%@NL@% WindowLocate 2, 2%@NL@% WindowPrint 2, "File Name:"%@NL@% WindowBox 1, 13, 3, 38%@NL@% WindowLine 4%@NL@% %@NL@% %@AB@% ' open edit field for file name%@AE@%%@NL@% EditFieldOpen 1, RTRIM$(FileName$), 2, 14, 0, 7, 24, 70%@NL@% %@NL@% %@AB@% ' open command buttons%@AE@%%@NL@% ButtonOpen 1, 2, "OK", 5, 6, 0, 0, 1%@NL@% ButtonOpen 2, 1, "Cancel", 5, 25, 0, 0, 1%@NL@% %@NL@% %@AB@% ' start with cursor in edit field%@AE@%%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% pushButton = 1%@NL@% %@NL@% %@AB@% ' control loop for window%@AE@%%@NL@% finished = FALSE%@NL@% WHILE NOT finished%@NL@% WindowDo currButton, currEditField ' wait for event%@NL@% SELECT CASE Dialog(0)%@NL@% CASE 1 ' Button pressed%@NL@% pushButton = Dialog(1)%@NL@% finished = TRUE%@NL@% CASE 2 ' Edit Field%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% CASE 6 ' enter%@NL@% finished = TRUE%@NL@% CASE 7 ' tab%@NL@% SELECT CASE currButton%@NL@% CASE 0, 1:%@NL@% ButtonSetState currButton, 1%@NL@% currButton = currButton + 1%@NL@% pushButton = currButton%@NL@% ButtonSetState pushButton, 2%@NL@% currEditField = 0%@NL@% CASE 2%@NL@% currButton = 0%@NL@% pushButton = 1%@NL@% currEditField = 1%@NL@% ButtonSetState 1, 2%@NL@% ButtonSetState 2, 1%@NL@% END SELECT%@NL@% CASE 8 ' back tab%@NL@% SELECT CASE currButton%@NL@% CASE 0:%@NL@% currButton = 2%@NL@% pushButton = 2%@NL@% currEditField = 0%@NL@% ButtonSetState 1, 1%@NL@% ButtonSetState 2, 2%@NL@% CASE 1%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% CASE 2%@NL@% currButton = 1%@NL@% pushButton = 1%@NL@% ButtonSetState 1, 2%@NL@% ButtonSetState 2, 1%@NL@% END SELECT%@NL@% CASE 9 ' escape%@NL@% pushButton = 2%@NL@% finished = TRUE%@NL@% CASE 14 ' space bar%@NL@% IF currButton <> 0 THEN%@NL@% finished = TRUE%@NL@% END IF%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' simple error checking before finishing%@AE@%%@NL@% IF finished = TRUE AND pushButton = 1 THEN%@NL@% temp$ = EditFieldInquire$(1)%@NL@% %@AB@% ' must specify a file%@AE@%%@NL@% IF temp$ = "" THEN%@NL@% PrintError "Must specify a name."%@NL@% finished = FALSE%@NL@% %@AB@% ' check if file is valid and can be opened%@AE@%%@NL@% ELSE%@NL@% %@AB@% ' open file%@AE@%%@NL@% fileNum% = FREEFILE%@NL@% OPEN temp$ FOR OUTPUT AS fileNum%%@NL@% %@NL@% END IF%@NL@% END IF%@NL@% WEND%@NL@% %@NL@% %@AB@% ' if operation not canceled return file name and file number%@AE@%%@NL@% IF pushButton = 1 THEN%@NL@% FileName$ = EditFieldInquire$(1)%@NL@% GetSaveFile% = fileNum%%@NL@% ELSE%@NL@% GetSaveFile% = 0%@NL@% END IF%@NL@% %@NL@% WindowClose 1%@NL@% %@NL@% EXIT FUNCTION%@NL@% %@NL@% %@AB@%' local error handler%@AE@%%@NL@% GetSaveError:%@NL@% finished = FALSE ' don't exit until valid file specified%@NL@% CLOSE fileNum%%@NL@% %@NL@% ShowError ERR ' display errors%@NL@% RESUME NEXT%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: LoadChart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Loads chart data and settings from the given file.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: fileNum% - file number%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB LoadChart (fileNum%)%@NL@% SHARED Cat$(), catLen AS INTEGER%@NL@% SHARED setLen() AS INTEGER, setName$(), setVal!()%@NL@% SHARED screenMode AS INTEGER, numModes AS INTEGER, mode$()%@NL@% %@NL@% ON LOCAL ERROR GOTO LoadError ' handle file loading errors%@NL@% %@NL@% %@AB@% ' Read file until EOF is reached:%@AE@%%@NL@% DO UNTIL EOF(fileNum%)%@NL@% %@AB@% ' get data type from file (C=category, V=value, T=title, S=setting):%@AE@%%@NL@% INPUT #fileNum%, type$%@NL@% %@NL@% %@AB@% ' category data%@AE@%%@NL@% IF UCASE$(type$) = "C" THEN%@NL@% INPUT #fileNum%, catLen%@NL@% FOR i% = 1 TO catLen%@NL@% INPUT #fileNum%, Cat$(i%)%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' value data%@AE@%%@NL@% ELSEIF UCASE$(type$) = "V" THEN%@NL@% %@AB@% ' too many sets in file%@AE@%%@NL@% IF setNum >= cMaxSets THEN%@NL@% PrintError "Too many data sets in file. Extra sets lost."%@NL@% EXIT DO%@NL@% END IF%@NL@% %@NL@% setNum = setNum + 1%@NL@% INPUT #fileNum%, setName$(setNum) ' get set name%@NL@% INPUT #fileNum%, setLen(setNum) ' get set length%@NL@% FOR i% = 1 TO setLen(setNum)%@NL@% INPUT #fileNum%, setVal!(i%, setNum) ' get set values%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% ' title data%@AE@%%@NL@% ELSEIF UCASE$(type$) = "T" THEN%@NL@% INPUT #fileNum%, CEnv.MainTitle.title%@NL@% INPUT #fileNum%, CEnv.SubTitle.title%@NL@% INPUT #fileNum%, CEnv.XAxis.AxisTitle.title%@NL@% INPUT #fileNum%, CEnv.YAxis.AxisTitle.title%@NL@% %@NL@% %@AB@% ' chart settings%@AE@%%@NL@% ELSEIF UCASE$(type$) = "S" THEN%@NL@% INPUT #fileNum%, screenMode%@NL@% %@AB@% ' test for valid screen mode%@AE@%%@NL@% valid = FALSE%@NL@% FOR i = 1 TO numModes%@NL@% IF screenMode = VAL(mode$(i)) THEN valid = TRUE%@NL@% NEXT i%@NL@% IF NOT valid THEN%@NL@% IF mode$(1) = "13" THEN%@NL@% screenMode = VAL(mode$(2))%@NL@% ELSE%@NL@% screenMode = VAL(mode$(1))%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% INPUT #fileNum%, CEnv.ChartType, CEnv.ChartStyle, CEnv.DataFont%@NL@% %@NL@% INPUT #fileNum%, CEnv.ChartWindow.X1, CEnv.ChartWindow.Y1, CEnv.ChartWindow.X2, CEnv.ChartWindow.Y2%@NL@% INPUT #fileNum%, CEnv.ChartWindow.Background, CEnv.ChartWindow.border, CEnv.ChartWindow.BorderStyle, CEnv.ChartWindow.BorderColor%@NL@% INPUT #fileNum%, CEnv.DataWindow.X1, CEnv.DataWindow.Y1, CEnv.DataWindow.X2, CEnv.DataWindow.Y2%@NL@% INPUT #fileNum%, CEnv.DataWindow.Background, CEnv.DataWindow.border, CEnv.DataWindow.BorderStyle, CEnv.DataWindow.BorderColor%@NL@% %@NL@% INPUT #fileNum%, CEnv.MainTitle.TitleFont, CEnv.MainTitle.TitleColor, CEnv.MainTitle.Justify%@NL@% INPUT #fileNum%, CEnv.SubTitle.TitleFont, CEnv.SubTitle.TitleColor, CEnv.SubTitle.Justify%@NL@% %@NL@% INPUT #fileNum%, CEnv.XAxis.Grid, CEnv.XAxis.GridStyle, CEnv.XAxis.AxisColor, CEnv.XAxis.Labeled%@NL@% INPUT #fileNum%, CEnv.XAxis.AxisTitle.TitleFont, CEnv.XAxis.AxisTitle.TitleColor, CEnv.XAxis.AxisTitle.Justify%@NL@% INPUT #fileNum%, CEnv.XAxis.RangeType, CEnv.XAxis.LogBase, CEnv.XAxis.AutoScale, CEnv.XAxis.ScaleMin%@NL@% INPUT #fileNum%, CEnv.XAxis.ScaleMax, CEnv.XAxis.ScaleFactor, CEnv.XAxis.TicFont, CEnv.XAxis.TicInterval, CEnv.XAxis.TicFormat, CEnv.XAxis.TicDecimals%@NL@% INPUT #fileNum%, CEnv.XAxis.ScaleTitle.title%@NL@% INPUT #fileNum%, CEnv.XAxis.ScaleTitle.TitleFont, CEnv.XAxis.ScaleTitle.TitleColor, CEnv.XAxis.ScaleTitle.Justify%@NL@% %@NL@% INPUT #fileNum%, CEnv.YAxis.Grid, CEnv.YAxis.GridStyle, CEnv.YAxis.AxisColor, CEnv.YAxis.Labeled%@NL@% INPUT #fileNum%, CEnv.YAxis.AxisTitle.TitleFont, CEnv.YAxis.AxisTitle.TitleColor, CEnv.YAxis.AxisTitle.Justify%@NL@% INPUT #fileNum%, CEnv.YAxis.RangeType, CEnv.YAxis.LogBase, CEnv.YAxis.AutoScale, CEnv.YAxis.ScaleMin%@NL@% INPUT #fileNum%, CEnv.YAxis.ScaleMax, CEnv.YAxis.ScaleFactor, CEnv.YAxis.TicFont, CEnv.YAxis.TicInterval, CEnv.YAxis.TicFormat, CEnv.YAxis.TicDecimals%@NL@% INPUT #fileNum%, CEnv.YAxis.ScaleTitle.title%@NL@% INPUT #fileNum%, CEnv.YAxis.ScaleTitle.TitleFont, CEnv.YAxis.ScaleTitle.TitleColor, CEnv.YAxis.ScaleTitle.Justify%@NL@% %@NL@% INPUT #fileNum%, CEnv.Legend.Legend, CEnv.Legend.Place, CEnv.Legend.TextColor, CEnv.Legend.TextFont, CEnv.Legend.AutoSize%@NL@% INPUT #fileNum%, CEnv.Legend.LegendWindow.X1, CEnv.Legend.LegendWindow.Y1, CEnv.Legend.LegendWindow.X2, CEnv.Legend.LegendWindow.Y2%@NL@% INPUT #fileNum%, CEnv.Legend.LegendWindow.Background, CEnv.Legend.LegendWindow.border, CEnv.Legend.LegendWindow.BorderStyle, CEnv.Legend.LegendWindow.BorderColor%@NL@% ELSE%@NL@% GOSUB LoadError%@NL@% END IF%@NL@% LOOP%@NL@% %@NL@% %@AB@% ' close the file%@AE@%%@NL@% CLOSE fileNum%%@NL@% %@NL@% %@AB@% ' clear any font pointers that don't map to current fonts%@AE@%%@NL@% ClearFonts%@NL@% %@NL@% %@AB@% ' initialize color list depending on newly loaded screen mode%@AE@%%@NL@% InitColors%@NL@% %@NL@% EXIT SUB%@NL@% %@NL@% %@AB@%' handle any file format errors%@AE@%%@NL@% LoadError:%@NL@% %@NL@% IF ERR THEN%@NL@% ShowError ERR%@NL@% ELSE%@NL@% PrintError "Invalid file format. Can't continue loading."%@NL@% END IF%@NL@% %@NL@% CLOSE fileNum% ' close and exit%@NL@% EXIT SUB%@NL@% %@NL@% RESUME NEXT%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: OpenChart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Handles both the "New" and "Open" operations from the%@AE@%%@NL@% %@AB@%' "File" menu title.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: newFlag - flag for determining which operation (New or Open)%@AE@%%@NL@% %@AB@%' to perform.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB OpenChart (newFlag)%@NL@% SHARED saveFile$%@NL@% %@NL@% %@AB@% ' allow user to save current chart if necessary%@AE@%%@NL@% IF chartChanged THEN%@NL@% a$ = "|"%@NL@% a$ = a$ + "Current chart has not been saved. Save now?"%@NL@% %@NL@% status = Alert(4, a$, 8, 15, 12, 65, "Yes", "No", "Cancel")%@NL@% %@NL@% %@AB@% ' save current chart%@AE@%%@NL@% IF status = OK THEN%@NL@% status = SaveChart(saveFile$, FALSE)%@NL@% END IF%@NL@% ELSE%@NL@% status = OK%@NL@% END IF%@NL@% %@NL@% IF status <> CANCEL THEN%@NL@% %@AB@% ' New option chosen so clear existing data, leave chart settings alone.%@AE@%%@NL@% IF newFlag = TRUE THEN%@NL@% MenuItemToggle GALLERYTITLE, CEnv.ChartType%@NL@% IF CEnv.ChartType = cPie THEN%@NL@% MenuSetState CHARTTITLE, 4, 1%@NL@% MenuSetState CHARTTITLE, 5, 1%@NL@% MenuSetState TITLETITLE, 3, 1%@NL@% MenuSetState TITLETITLE, 4, 1%@NL@% END IF%@NL@% InitChart%@NL@% saveFile$ = ""%@NL@% %@AB@% ' Open operation chosen so get file and load data%@AE@%%@NL@% ELSE%@NL@% fileNum% = GetLoadFile(saveFile$)%@NL@% %@AB@% ' if no errors opening file and operation not canceled then load data%@AE@%%@NL@% IF fileNum <> 0 THEN%@NL@% %@AB@% ' reset menu bar to nothing selected%@AE@%%@NL@% MenuItemToggle GALLERYTITLE, CEnv.ChartType%@NL@% IF CEnv.ChartType = cPie THEN%@NL@% MenuSetState CHARTTITLE, 4, 1%@NL@% MenuSetState CHARTTITLE, 5, 1%@NL@% MenuSetState TITLETITLE, 3, 1%@NL@% MenuSetState TITLETITLE, 4, 1%@NL@% END IF%@NL@% %@NL@% ClearData 'clear current data%@NL@% %@NL@% setNum = 0%@NL@% LoadChart fileNum% ' load the data%@NL@% %@NL@% %@AB@% ' set menu bar according to new chart settings%@AE@%%@NL@% MenuItemToggle GALLERYTITLE, CEnv.ChartType%@NL@% IF CEnv.ChartType = cPie THEN%@NL@% MenuSetState CHARTTITLE, 4, 0%@NL@% MenuSetState CHARTTITLE, 5, 0%@NL@% MenuSetState TITLETITLE, 3, 0%@NL@% MenuSetState TITLETITLE, 4, 0%@NL@% END IF%@NL@% %@NL@% %@AB@% ' new chart not changed%@AE@%%@NL@% chartChanged = FALSE%@NL@% %@NL@% %@AB@% ' chart data exists so allow user to view chart%@AE@%%@NL@% IF setNum > 0 THEN%@NL@% MenuSetState VIEWTITLE, 2, 1%@NL@% END IF%@NL@% END IF%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: PrintError%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Prints error messages on the screen in an Alert box.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: text$ - error message%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB PrintError (text$)%@NL@% %@NL@% textLen = LEN(text$) + 2%@NL@% lefCol = ((80 - textLen) / 2) - 1%@NL@% a$ = "| " + text$%@NL@% junk = Alert(4, a$, 8, lefCol, 12, textLen + lefCol, "", "", "")%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Func Name: SaveChart%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Performs both the "Save" and "Save AS" operations from%@AE@%%@NL@% %@AB@%' the "File" menu title. If "Save As" was chosen or if%@AE@%%@NL@% %@AB@%' "Save" was chosen and no save file has been previously%@AE@%%@NL@% %@AB@%' specified, it prompts the user for a new file in%@AE@%%@NL@% %@AB@%' which to save the current chart. Also returns the status of%@AE@%%@NL@% %@AB@%' save operation for use in other routines%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: fileName$ - name of previously specified save file (may be nil)%@AE@%%@NL@% %@AB@%' saveAsFlag - flag for invoking the "Save As" operation.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION SaveChart% (FileName$, saveAsFlag)%@NL@% SHARED Cat$(), catLen AS INTEGER%@NL@% SHARED setLen() AS INTEGER, setName$(), setVal!()%@NL@% SHARED screenMode AS INTEGER%@NL@% %@NL@% ON LOCAL ERROR GOTO SaveError ' handle file errors%@NL@% %@NL@% %@AB@% ' get new file name if necessary%@AE@%%@NL@% IF FileName$ = "" OR saveAsFlag THEN%@NL@% fileNum% = GetSaveFile(FileName$)%@NL@% %@AB@% ' otherwise just open the file%@AE@%%@NL@% ELSE%@NL@% fileNum% = FREEFILE%@NL@% OPEN FileName$ FOR OUTPUT AS fileNum%%@NL@% END IF%@NL@% %@NL@% %@AB@% ' quit save if cancel chosen above or error occurred during open.%@AE@%%@NL@% IF fileNum% = 0 THEN%@NL@% SaveChart% = CANCEL ' return status%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% %@AB@% ' save category data%@AE@%%@NL@% IF catLen > 0 THEN%@NL@% PRINT #fileNum%, "C"%@NL@% PRINT #fileNum%, catLen%@NL@% %@NL@% FOR i% = 1 TO catLen%@NL@% PRINT #fileNum%, Cat$(i%)%@NL@% NEXT i%%@NL@% END IF%@NL@% %@NL@% %@AB@% ' save value data%@AE@%%@NL@% IF setNum > 0 THEN%@NL@% FOR j% = 1 TO setNum%@NL@% PRINT #fileNum%, "V"%@NL@% PRINT #fileNum%, setName$(j%)%@NL@% PRINT #fileNum%, setLen(j%)%@NL@% %@NL@% FOR i% = 1 TO setLen(j%)%@NL@% PRINT #fileNum%, setVal!(i%, j%)%@NL@% NEXT i%%@NL@% NEXT j%%@NL@% END IF%@NL@% %@NL@% %@AB@% ' save titles%@AE@%%@NL@% PRINT #fileNum%, "T"%@NL@% PRINT #fileNum%, CEnv.MainTitle.title%@NL@% PRINT #fileNum%, CEnv.SubTitle.title%@NL@% PRINT #fileNum%, CEnv.XAxis.AxisTitle.title%@NL@% PRINT #fileNum%, CEnv.YAxis.AxisTitle.title%@NL@% %@NL@% %@AB@% 'save chart settings%@AE@%%@NL@% PRINT #fileNum%, "S"%@NL@% PRINT #fileNum%, screenMode%@NL@% %@NL@% PRINT #fileNum%, CEnv.ChartType, CEnv.ChartStyle, CEnv.DataFont%@NL@% %@NL@% PRINT #fileNum%, CEnv.ChartWindow.X1, CEnv.ChartWindow.Y1, CEnv.ChartWindow.X2, CEnv.ChartWindow.Y2%@NL@% PRINT #fileNum%, CEnv.ChartWindow.Background, CEnv.ChartWindow.border, CEnv.ChartWindow.BorderStyle, CEnv.ChartWindow.BorderColor%@NL@% PRINT #fileNum%, CEnv.DataWindow.X1, CEnv.DataWindow.Y1, CEnv.DataWindow.X2, CEnv.DataWindow.Y2%@NL@% PRINT #fileNum%, CEnv.DataWindow.Background, CEnv.DataWindow.border, CEnv.DataWindow.BorderStyle, CEnv.DataWindow.BorderColor%@NL@% %@NL@% PRINT #fileNum%, CEnv.MainTitle.TitleFont, CEnv.MainTitle.TitleColor, CEnv.MainTitle.Justify%@NL@% PRINT #fileNum%, CEnv.SubTitle.TitleFont, CEnv.SubTitle.TitleColor, CEnv.SubTitle.Justify%@NL@% %@NL@% PRINT #fileNum%, CEnv.XAxis.Grid, CEnv.XAxis.GridStyle, CEnv.XAxis.AxisColor, CEnv.XAxis.Labeled%@NL@% PRINT #fileNum%, CEnv.XAxis.AxisTitle.TitleFont, CEnv.XAxis.AxisTitle.TitleColor, CEnv.XAxis.AxisTitle.Justify%@NL@% PRINT #fileNum%, CEnv.XAxis.RangeType, CEnv.XAxis.LogBase, CEnv.XAxis.AutoScale, CEnv.XAxis.ScaleMin%@NL@% PRINT #fileNum%, CEnv.XAxis.ScaleMax, CEnv.XAxis.ScaleFactor, CEnv.XAxis.TicFont, CEnv.XAxis.TicInterval, CEnv.XAxis.TicFormat, CEnv.XAxis.TicDecimals%@NL@% PRINT #fileNum%, CEnv.XAxis.ScaleTitle.title%@NL@% PRINT #fileNum%, CEnv.XAxis.ScaleTitle.TitleFont, CEnv.XAxis.ScaleTitle.TitleColor, CEnv.XAxis.ScaleTitle.Justify%@NL@% %@NL@% PRINT #fileNum%, CEnv.YAxis.Grid, CEnv.YAxis.GridStyle, CEnv.YAxis.AxisColor, CEnv.YAxis.Labeled%@NL@% PRINT #fileNum%, CEnv.YAxis.AxisTitle.TitleFont, CEnv.YAxis.AxisTitle.TitleColor, CEnv.YAxis.AxisTitle.Justify%@NL@% PRINT #fileNum%, CEnv.YAxis.RangeType, CEnv.YAxis.LogBase, CEnv.YAxis.AutoScale, CEnv.YAxis.ScaleMin%@NL@% PRINT #fileNum%, CEnv.YAxis.ScaleMax, CEnv.YAxis.ScaleFactor, CEnv.YAxis.TicFont, CEnv.YAxis.TicInterval, CEnv.YAxis.TicFormat, CEnv.YAxis.TicDecimals%@NL@% PRINT #fileNum%, CEnv.YAxis.ScaleTitle.title%@NL@% PRINT #fileNum%, CEnv.YAxis.ScaleTitle.TitleFont, CEnv.YAxis.ScaleTitle.TitleColor, CEnv.YAxis.ScaleTitle.Justify%@NL@% %@NL@% PRINT #fileNum%, CEnv.Legend.Legend, CEnv.Legend.Place, CEnv.Legend.TextColor, CEnv.Legend.TextFont, CEnv.Legend.AutoSize%@NL@% PRINT #fileNum%, CEnv.Legend.LegendWindow.X1, CEnv.Legend.LegendWindow.Y1, CEnv.Legend.LegendWindow.X2, CEnv.Legend.LegendWindow.Y2%@NL@% PRINT #fileNum%, CEnv.Legend.LegendWindow.Background, CEnv.Legend.LegendWindow.border, CEnv.Legend.LegendWindow.BorderStyle, CEnv.Legend.LegendWindow.BorderColor%@NL@% %@NL@% CLOSE fileNum%%@NL@% %@NL@% SaveChart% = OK ' return status%@NL@% %@NL@% chartChanged = FALSE ' reset global change flag%@NL@% %@NL@% EXIT FUNCTION%@NL@% %@NL@% %@AB@%' local error handler%@AE@%%@NL@% SaveError:%@NL@% SaveChart% = CANCEL ' return cancel status%@NL@% CLOSE fileNum%%@NL@% %@NL@% ShowError ERR ' display error message%@NL@% %@NL@% EXIT FUNCTION ' exit on error%@NL@% RESUME NEXT%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ShowError%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Displays an appropriate error message for the given error%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: errorNum - error number%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ShowError (errorNum)%@NL@% SELECT CASE errorNum%@NL@% CASE 6: ' overflow%@NL@% PrintError "Overflow occurred."%@NL@% CASE 14: ' out of space%@NL@% PrintError "Out of string space. Please restart."%@NL@% CASE 53: ' file not found%@NL@% PrintError "File not found."%@NL@% CASE 62: ' input past end of file%@NL@% PrintError "Invalid file format. Can't continue loading."%@NL@% CASE 64: ' bad file name%@NL@% PrintError "Invalid file name."%@NL@% CASE 68: ' device unavailable%@NL@% PrintError "Selected device unavailable."%@NL@% CASE 71: ' disk not ready%@NL@% PrintError "Disk not ready."%@NL@% CASE 75: ' path access error%@NL@% PrintError "Invalid path."%@NL@% CASE 76: ' path not found%@NL@% PrintError "Path not found."%@NL@% CASE ELSE ' catch all%@NL@% PrintError "BASIC error #" + LTRIM$(STR$(ERR)) + " occurred."%@NL@% END SELECT%@NL@% %@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Sub Name: ViewData%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Description: Displays the current chart data and allows the user to%@AE@%%@NL@% %@AB@%' modify, delete or add to that data.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments: none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ViewData%@NL@% SHARED setVal!(), setLen() AS INTEGER, setName$()%@NL@% SHARED Cat$(), catLen AS INTEGER%@NL@% SHARED GloEdit() AS EditFieldType%@NL@% %@NL@% %@AB@% ' temporary data storage that allows user to cancel all changes and%@AE@%%@NL@% %@AB@% ' restore original data%@AE@%%@NL@% DIM tsetVal$(1 TO 15, 1 TO 15), tCat$(1 TO 15), tsetName$(1 TO 15)%@NL@% DIM tsetNum AS INTEGER%@NL@% DIM tsetLen(1 TO 15) AS INTEGER%@NL@% DIM tcatLen AS INTEGER%@NL@% %@NL@% ON LOCAL ERROR GOTO ViewDatError%@NL@% %@NL@% %@AB@% ' fill out temp data%@AE@%%@NL@% FOR i = 1 TO cMaxSets%@NL@% tsetName$(i) = setName$(i)%@NL@% tCat$(i) = Cat$(i)%@NL@% tsetLen(i) = setLen(i)%@NL@% FOR j = 1 TO tsetLen(i)%@NL@% tsetVal$(j, i) = LTRIM$(STR$(setVal!(j, i)))%@NL@% NEXT j%@NL@% FOR j = tsetLen(i) + 1 TO cMaxValues%@NL@% tsetVal$(j, i) = ""%@NL@% NEXT j%@NL@% NEXT i%@NL@% tsetNum = setNum%@NL@% tcatLen = catLen%@NL@% %@NL@% %@AB@% ' set up window%@AE@%%@NL@% winRow = 4%@NL@% winCol = 8%@NL@% WindowOpen 1, winRow, winCol, 23, 74, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 2, "Chart Data"%@NL@% WindowLocate 1, 2%@NL@% WindowPrint 2, "Series Name:"%@NL@% WindowBox 2, 2, 18, 24%@NL@% WindowLocate 1, 26%@NL@% WindowPrint 2, "Categories:"%@NL@% WindowBox 2, 26, 18, 48%@NL@% WindowLocate 1, 50%@NL@% WindowPrint 2, "Values:"%@NL@% WindowBox 2, 50, 18, 66%@NL@% WindowLine 19%@NL@% %@NL@% %@AB@% ' display chart data%@AE@%%@NL@% FOR i = 1 TO 15%@NL@% IF i < 10 THEN%@NL@% a$ = " "%@NL@% ELSE%@NL@% a$ = ""%@NL@% END IF%@NL@% a$ = a$ + LTRIM$(STR$(i)) + ". "%@NL@% WindowLocate i + 2, 3%@NL@% WindowPrint 2, a$ + tsetName$(i)%@NL@% WindowLocate i + 2, 27%@NL@% WindowPrint 2, a$ + tCat$(i)%@NL@% WindowLocate i + 2, 51%@NL@% WindowPrint 2, a$ + MID$(tsetVal$(i, 1), 1, 10)%@NL@% NEXT i%@NL@% %@AB@% ' highlight first set name%@AE@%%@NL@% EditFieldOpen 1, tsetName$(1), 3, 7, 7, 0, 17, 16%@NL@% %@NL@% IF tsetNum < cMaxSets THEN tsetNum = tsetNum + 1%@NL@% IF tcatLen < cMaxValues THEN tcatLen = tcatLen + 1%@NL@% IF tsetLen(1) < cMaxValues THEN tsetLen(1) = tsetLen(1) + 1%@NL@% %@NL@% %@AB@% ' area buttons%@AE@%%@NL@% ButtonOpen 1, 1, "", 3, 3, 17, 23, 4%@NL@% ButtonOpen 2, 1, "", 3, 27, 17, 47, 4%@NL@% ButtonOpen 3, 1, "", 3, 51, 17, 65, 4%@NL@% %@NL@% %@AB@% ' command buttons%@AE@%%@NL@% ButtonOpen 4, 1, "OK", 20, 15, 0, 0, 1%@NL@% ButtonOpen 5, 1, "Cancel", 20, 45, 0, 0, 1%@NL@% %@NL@% %@AB@% ' start with cursor in first set name edit field%@AE@%%@NL@% currButton = 1%@NL@% prevButton = 1%@NL@% currRow = 1%@NL@% currEditField = 1%@NL@% currCat = 1%@NL@% currVal = 1%@NL@% currSet = 1%@NL@% %@NL@% IF CEnv.ChartType = cPie THEN%@NL@% a$ = " Pie chart information||"%@NL@% a$ = a$ + " Only data values from the first series are plotted in pie charts. |"%@NL@% a$ = a$ + " Data values from the second series are used in determining whether|"%@NL@% a$ = a$ + " or not pie pieces are exploded. Non-zero values in this series |"%@NL@% a$ = a$ + " will cause corresponding pie pieces to be exploded. All other |"%@NL@% a$ = a$ + " series will be ignored. "%@NL@% %@NL@% junk = Alert(4, a$, 8, 7, 17, 75, "", "", "")%@NL@% END IF%@NL@% %@NL@% %@AB@% ' window control loop%@AE@%%@NL@% finished = FALSE%@NL@% WHILE NOT finished%@NL@% WindowDo currButton, currEditField%@NL@% %@NL@% SELECT CASE Dialog(0)%@NL@% CASE 1 ' button pressed%@NL@% currButton = Dialog(1)%@NL@% SELECT CASE currButton%@NL@% CASE 1, 2, 3%@NL@% currRow = Dialog(17)%@NL@% CASE 4, 5%@NL@% finished = TRUE%@NL@% END SELECT%@NL@% GOSUB UpdateEdit%@NL@% CASE 2 ' Edit Field%@NL@% currEditField = Dialog(2)%@NL@% CASE 6, 11 ' enter, down arrow%@NL@% IF currButton > 3 AND Dialog(0) = 6 THEN%@NL@% finished = TRUE%@NL@% ELSE%@NL@% currRow = currRow + 1%@NL@% GOSUB UpdateEdit%@NL@% END IF%@NL@% CASE 7 'tab%@NL@% SELECT CASE currButton%@NL@% CASE 1:%@NL@% currButton = 2%@NL@% currRow = currCat%@NL@% GOSUB UpdateEdit%@NL@% CASE 2:%@NL@% currButton = 3%@NL@% currRow = currVal%@NL@% GOSUB UpdateEdit%@NL@% CASE 3:%@NL@% currButton = 4%@NL@% ButtonToggle 4%@NL@% GOSUB UpdateEdit%@NL@% CASE 4:%@NL@% currButton = 5%@NL@% ButtonToggle 4%@NL@% ButtonToggle 5%@NL@% CASE 5:%@NL@% currButton = 1%@NL@% currRow = currSet%@NL@% ButtonToggle 5%@NL@% GOSUB UpdateEdit%@NL@% END SELECT%@NL@% CASE 8 'back tab%@NL@% SELECT CASE currButton%@NL@% CASE 1:%@NL@% currButton = 5%@NL@% ButtonToggle 5%@NL@% GOSUB UpdateEdit%@NL@% CASE 2:%@NL@% currButton = 1%@NL@% currRow = currSet%@NL@% GOSUB UpdateEdit%@NL@% CASE 3:%@NL@% currButton = 2%@NL@% currRow = currCat%@NL@% GOSUB UpdateEdit%@NL@% CASE 4:%@NL@% currButton = 3%@NL@% currRow = currVal%@NL@% ButtonToggle 4%@NL@% GOSUB UpdateEdit%@NL@% CASE 5:%@NL@% currButton = 4%@NL@% ButtonToggle 5%@NL@% ButtonToggle 4%@NL@% END SELECT%@NL@% CASE 9 'escape%@NL@% currButton = 5%@NL@% finished = TRUE%@NL@% CASE 10: 'up arrow%@NL@% IF currButton < 4 THEN%@NL@% currRow = currRow - 1%@NL@% GOSUB UpdateEdit%@NL@% END IF%@NL@% CASE 14 'space%@NL@% IF currButton > 3 THEN finished = TRUE%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' give delete warning before exit%@AE@%%@NL@% IF finished = TRUE AND currButton = 4 THEN%@NL@% temp = FALSE%@NL@% FOR i = 1 TO tsetNum%@NL@% IF tsetName$(i) = "" AND tsetLen(i) > 0 AND NOT (tsetLen(i) = 1 AND tsetVal$(1, i) = "") THEN temp = TRUE%@NL@% NEXT i%@NL@% IF temp = TRUE THEN%@NL@% a$ = "|"%@NL@% a$ = a$ + "Series without names will be deleted upon exit."%@NL@% reply = Alert(4, a$, 8, 10, 12, 70, "OK", "Cancel", "")%@NL@% IF reply <> 1 THEN finished = FALSE%@NL@% END IF%@NL@% END IF%@NL@% WEND%@NL@% %@NL@% %@AB@% ' finished so save new data%@AE@%%@NL@% IF currButton = 4 THEN%@NL@% ClearData ' clear existing data%@NL@% %@NL@% %@AB@% ' copy temporary values to permanent locations%@AE@%%@NL@% indx = 0%@NL@% FOR i = 1 TO tsetNum%@NL@% IF tsetName$(i) <> "" THEN%@NL@% indx = indx + 1%@NL@% setName$(indx) = tsetName$(i) ' store set names%@NL@% indx2 = 0%@NL@% FOR j = 1 TO tsetLen(i)%@NL@% IF tsetVal$(j, i) <> "" THEN%@NL@% indx2 = indx2 + 1%@NL@% setVal!(indx2, i) = VAL(tsetVal$(j, i)) ' store set values%@NL@% END IF%@NL@% NEXT j%@NL@% setLen(indx) = indx2 ' get set lengths%@NL@% END IF%@NL@% NEXT i%@NL@% setNum = indx%@NL@% %@NL@% %@AB@% ' clear leftover names and set lengths%@AE@%%@NL@% FOR i = setNum + 1 TO cMaxSets%@NL@% setName$(i) = ""%@NL@% setLen(i) = 0%@NL@% NEXT i%@NL@% %@NL@% %@AB@% ' store category names%@AE@%%@NL@% FOR i = 1 TO tcatLen%@NL@% Cat$(i) = tCat$(i)%@NL@% NEXT i%@NL@% catLen = tcatLen%@NL@% %@NL@% FOR i = tcatLen TO 1 STEP -1%@NL@% IF Cat$(i) = "" THEN%@NL@% catLen = catLen - 1%@NL@% IF catLen <= 0 THEN EXIT FOR%@NL@% ELSE%@NL@% EXIT FOR%@NL@% END IF%@NL@% NEXT i%@NL@% %@NL@% %@AB@% ' clear leftover category names%@AE@%%@NL@% FOR i = catLen + 1 TO cMaxValues%@NL@% Cat$(i) = ""%@NL@% NEXT i%@NL@% %@NL@% %@AB@% ' update active menu titles based on current data%@AE@%%@NL@% IF setNum > 0 THEN%@NL@% MenuSetState VIEWTITLE, 2, 1%@NL@% chartChanged = TRUE%@NL@% ELSE%@NL@% MenuSetState VIEWTITLE, 2, 0%@NL@% END IF%@NL@% END IF%@NL@% WindowClose 1%@NL@% %@NL@% %@NL@% EXIT SUB%@NL@% %@NL@% ViewDatError:%@NL@% PrintError "BASIC error #" + LTRIM$(STR$(ERR)) + " occurred."%@NL@% RESUME NEXT%@NL@% %@NL@% %@AB@%' redraws the value edit column so it displays the current set's values%@AE@%%@NL@% ResetVal:%@NL@% %@AB@% ' display new values%@AE@%%@NL@% FOR i = 1 TO cMaxValues%@NL@% WindowLocate i + 2, 55%@NL@% WindowPrint 2, tsetVal$(i, currSet) + STRING$(10 - LEN(tsetVal$(i, currSet)), " ")%@NL@% NEXT i%@NL@% %@NL@% IF tsetLen(currSet) = 0 THEN%@NL@% tsetLen(currSet) = tsetLen(currSet) + 1%@NL@% ELSEIF tsetLen(currSet) < cMaxValues AND tsetVal$(tsetLen(currSet), currSet) <> "" THEN%@NL@% tsetLen(currSet) = tsetLen(currSet) + 1%@NL@% END IF%@NL@% %@NL@% currVal = 31%@NL@% %@NL@% RETURN%@NL@% %@NL@% UpdateEdit:%@NL@% IF prevButton < 4 THEN GOSUB ClosePrevEdit%@NL@% %@NL@% SELECT CASE currButton%@NL@% CASE 1:%@NL@% IF currRow <= 0 THEN%@NL@% currRow = tsetNum%@NL@% ELSEIF currRow > 15 THEN%@NL@% currRow = 1%@NL@% ELSEIF currRow = tsetNum + 1 AND tsetName$(tsetNum) <> "" THEN%@NL@% tsetNum = tsetNum + 1%@NL@% ELSEIF currRow > tsetNum THEN%@NL@% currRow = 1%@NL@% END IF%@NL@% WindowColor 0, 7%@NL@% WindowLocate currSet + 2, 7%@NL@% WindowPrint 2, tsetName$(currSet) + STRING$(17 - LEN(tsetName$(currSet)), " ")%@NL@% %@NL@% FG = 7%@NL@% BG = 0%@NL@% vislen = 17%@NL@% totlen = 16%@NL@% currSet = currRow%@NL@% currCol = 7%@NL@% temp$ = tsetName$(currSet)%@NL@% IF prevButton = 1 THEN GOSUB ResetVal%@NL@% CASE 2:%@NL@% IF currRow <= 0 THEN%@NL@% currRow = tcatLen%@NL@% ELSEIF currRow > 15 THEN%@NL@% currRow = 1%@NL@% ELSEIF currRow > tcatLen THEN%@NL@% tcatLen = currRow%@NL@% END IF%@NL@% FG = 0%@NL@% BG = 7%@NL@% vislen = 17%@NL@% totlen = 16%@NL@% currCat = currRow%@NL@% currCol = 31%@NL@% temp$ = tCat$(currCat)%@NL@% CASE 3:%@NL@% IF currRow <= 0 THEN%@NL@% currRow = tsetLen(currSet)%@NL@% ELSEIF currRow > 15 THEN%@NL@% currRow = 1%@NL@% ELSEIF currRow = tsetLen(currSet) + 1 AND tsetVal$(tsetLen(currSet), currSet) <> "" AND currRow THEN%@NL@% tsetLen(currSet) = tsetLen(currSet) + 1%@NL@% ELSEIF currRow > tsetLen(currSet) THEN%@NL@% currRow = 1%@NL@% END IF%@NL@% FG = 0%@NL@% BG = 7%@NL@% vislen = 11%@NL@% totlen = 20%@NL@% currVal = currRow%@NL@% currCol = 55%@NL@% temp$ = tsetVal$(currVal, currSet)%@NL@% CASE ELSE%@NL@% prevButton = currButton%@NL@% RETURN%@NL@% END SELECT%@NL@% %@NL@% EditFieldOpen 1, temp$, currRow + 2, currCol, FG, BG, vislen, totlen%@NL@% currEditField = 1%@NL@% prevButton = currButton%@NL@% RETURN%@NL@% %@NL@% ClosePrevEdit:%@NL@% temp$ = RTRIM$(EditFieldInquire$(1))%@NL@% EditFieldClose 1%@NL@% currEditField = 0%@NL@% IF prevButton = 1 THEN%@NL@% WindowColor 7, 0%@NL@% ELSE%@NL@% WindowColor 0, 7%@NL@% END IF%@NL@% %@NL@% SELECT CASE prevButton%@NL@% CASE 1:%@NL@% tsetName$(currSet) = temp$%@NL@% temp$ = temp$ + STRING$(17 - LEN(temp$), " ")%@NL@% editRow = currSet + 2%@NL@% editCol = 7%@NL@% CASE 2:%@NL@% tCat$(currCat) = temp$%@NL@% editRow = currCat + 2%@NL@% editCol = 31%@NL@% CASE 3:%@NL@% tsetVal$(currVal, currSet) = temp$%@NL@% tval# = VAL(temp$)%@NL@% IF tval# = 0 AND temp$ <> "0" AND LEN(RTRIM$(temp$)) <> 0 THEN%@NL@% PrintError "Warning: Non-numeric values will default to zero for charting."%@NL@% END IF%@NL@% temp$ = MID$(temp$, 1, 10)%@NL@% editRow = currVal + 2%@NL@% editCol = 55%@NL@% END SELECT%@NL@% %@NL@% WindowLocate editRow, editCol%@NL@% WindowPrint 2, temp$%@NL@% WindowColor 0, 7%@NL@% RETURN%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%COLORS.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\COLORS.BAS%@AE@%%@NL@% %@NL@% SCREEN 1%@NL@% %@NL@% Esc$ = CHR$(27)%@NL@% %@AB@%' Draw three boxes and paint the interior%@AE@%%@NL@% %@AB@%' of each box with a different color:%@AE@%%@NL@% FOR ColorVal = 1 TO 3%@NL@% LINE (X, Y) -STEP(60, 50), ColorVal, BF%@NL@% X = X + 61%@NL@% Y = Y + 51%@NL@% NEXT ColorVal%@NL@% %@NL@% LOCATE 21, 1%@NL@% PRINT "Press ESC to end."%@NL@% PRINT "Press any other key to continue."%@NL@% %@NL@% %@AB@%' Restrict additional printed output to the 23rd line:%@AE@%%@NL@% VIEW PRINT 23 TO 23%@NL@% DO%@NL@% PaletteVal = 1%@NL@% DO%@NL@% %@NL@% %@AB@% ' PaletteVal is either 1 or 0:%@AE@%%@NL@% PaletteVal = 1 - PaletteVal%@NL@% %@NL@% %@AB@% ' Set the background color and choose the palette:%@AE@%%@NL@% COLOR BackGroundVal, PaletteVal%@NL@% PRINT "Background ="; BackGroundVal;%@NL@% PRINT "Palette ="; PaletteVal;%@NL@% %@NL@% Pause$ = INPUT$(1) ' Wait for a keystroke.%@NL@% PRINT%@NL@% %@AB@% ' Exit the loop if both palettes have been shown,%@AE@%%@NL@% %@AB@% ' or if the user pressed the ESC key:%@AE@%%@NL@% LOOP UNTIL PaletteVal = 1 OR Pause$ = Esc$%@NL@% %@NL@% BackGroundVal = BackGroundVal + 1%@NL@% %@NL@% %@AB@%' Exit this loop if all 16 background colors have%@AE@%%@NL@% %@AB@%' been shown, or if the user pressed the ESC key:%@AE@%%@NL@% LOOP UNTIL BackGroundVal > 15 OR Pause$ = Esc$%@NL@% %@NL@% SCREEN 0 ' Restore text mode and%@NL@% WIDTH 80 ' 80-column screen width.%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%CRLF.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\CRLF.BAS%@AE@%%@NL@% %@NL@% DEFINT A-Z ' Default variable type is integer.%@NL@% %@NL@% %@AB@%' The Backup$ FUNCTION makes a backup file with%@AE@%%@NL@% %@AB@%' the same base as FileName$ plus a .BAK extension:%@AE@%%@NL@% DECLARE FUNCTION Backup$ (FileName$)%@NL@% %@NL@% %@AB@%' Initialize symbolic constants and variables:%@AE@%%@NL@% CONST FALSE = 0, TRUE = NOT FALSE%@NL@% %@NL@% CarReturn$ = CHR$(13)%@NL@% LineFeed$ = CHR$(10)%@NL@% %@NL@% DO%@NL@% CLS%@NL@% %@NL@% %@AB@% ' Input the name of the file to change:%@AE@%%@NL@% INPUT "Which file do you want to convert"; OutFile$%@NL@% %@NL@% InFile$ = Backup$(OutFile$) ' Get backup file's name.%@NL@% %@NL@% ON ERROR GOTO ErrorHandler ' Turn on error trapping.%@NL@% %@NL@% NAME OutFile$ AS InFile$ ' Rename input file as%@NL@% %@AB@% ' backup file.%@AE@%%@NL@% %@NL@% ON ERROR GOTO 0 ' Turn off error trapping.%@NL@% %@NL@% %@AB@% ' Open backup file for input and old file for output:%@AE@%%@NL@% OPEN InFile$ FOR INPUT AS #1%@NL@% OPEN OutFile$ FOR OUTPUT AS #2%@NL@% %@NL@% %@AB@% ' The PrevCarReturn variable is a flag set to TRUE%@AE@%%@NL@% %@AB@% ' whenever the program reads a carriage-return character:%@AE@%%@NL@% PrevCarReturn = FALSE%@NL@% %@AB@%' Read from input file until reaching end of file:%@AE@%%@NL@% DO UNTIL EOF(1)%@NL@% %@NL@% %@AB@% ' This is not end of file, so read a character:%@AE@%%@NL@% FileChar$ = INPUT$(1, #1)%@NL@% %@NL@% SELECT CASE FileChar$%@NL@% %@NL@% CASE CarReturn$ ' The character is a CR.%@NL@% %@NL@% %@AB@% ' If the previous character was also a%@AE@%%@NL@% %@AB@% ' CR, put a LF before the character:%@AE@%%@NL@% IF PrevCarReturn THEN%@NL@% FileChar$ = LineFeed$ + FileChar$%@NL@% END IF%@NL@% %@NL@% %@AB@% ' In any case, set the PrevCarReturn%@AE@%%@NL@% %@AB@% ' variable to TRUE:%@AE@%%@NL@% PrevCarReturn = TRUE%@NL@% %@NL@% CASE LineFeed$ ' The character is a LF.%@NL@% %@NL@% %@AB@% ' If the previous character was not a%@AE@%%@NL@% %@AB@% ' CR, put a CR before the character:%@AE@%%@NL@% IF NOT PrevCarReturn THEN%@NL@% FileChar$ = CarReturn$ + FileChar$%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Set the PrevCarReturn variable to FALSE:%@AE@%%@NL@% PrevCarReturn = FALSE%@NL@% %@NL@% CASE ELSE ' Neither a CR nor a LF.%@NL@% %@NL@% %@AB@% ' If the previous character was a CR,%@AE@%%@NL@% %@AB@% ' set the PrevCarReturn variable to FALSE%@AE@%%@NL@% %@AB@% ' and put a LF before the current character:%@AE@%%@NL@% IF PrevCarReturn THEN%@NL@% PrevCarReturn = FALSE%@NL@% FileChar$ = LineFeed$ + FileChar$%@NL@% END IF%@NL@% %@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Write the character(s) to the new file:%@AE@%%@NL@% PRINT #2, FileChar$;%@NL@% LOOP%@NL@% %@NL@% %@AB@% ' Write a LF if the last character in the file was a CR:%@AE@%%@NL@% IF PrevCarReturn THEN PRINT #2, LineFeed$;%@NL@% CLOSE ' Close both files.%@NL@% PRINT "Another file (Y/N)?" ' Prompt to continue.%@NL@% %@NL@% %@AB@% ' Change the input to uppercase (capital letter):%@AE@%%@NL@% More$ = UCASE$(INPUT$(1))%@NL@% %@NL@% %@AB@%' Continue the program if the user entered a "Y" or a "Y":%@AE@%%@NL@% LOOP WHILE More$ = "Y"%@NL@% END%@NL@% %@NL@% ErrorHandler: ' Error-handling routine%@NL@% CONST NOFILE = 53, FILEEXISTS = 58%@NL@% %@NL@% %@AB@% ' The ERR function returns the error code for last error:%@AE@%%@NL@% SELECT CASE ERR%@NL@% CASE NOFILE ' Program couldn't find file%@NL@% %@AB@% ' with input name.%@AE@%%@NL@% %@NL@% PRINT "No such file in current directory."%@NL@% INPUT "Enter new name: ", OutFile$%@NL@% InFile$ = Backup$(OutFile$)%@NL@% RESUME%@NL@% CASE FILEEXISTS ' There is already a file named%@NL@% %@AB@% ' <filename>.BAK in this directory:%@AE@%%@NL@% %@AB@% ' remove it, then continue.%@AE@%%@NL@% KILL InFile$%@NL@% RESUME%@NL@% CASE ELSE ' An unanticipated error occurred:%@NL@% %@AB@% ' stop the program.%@AE@%%@NL@% ON ERROR GOTO 0%@NL@% END SELECT%@NL@% %@NL@% %@AB@%' ======================== BACKUP$ =========================%@AE@%%@NL@% %@AB@%' This procedure returns a file name that consists of the%@AE@%%@NL@% %@AB@%' base name of the input file (everything before the ".")%@AE@%%@NL@% %@AB@%' plus the extension ".BAK"%@AE@%%@NL@% %@AB@%' ==========================================================%@AE@%%@NL@% %@NL@% FUNCTION Backup$ (FileName$) STATIC%@NL@% %@NL@% %@AB@% ' Look for a period:%@AE@%%@NL@% Extension = INSTR(FileName$, ".")%@NL@% %@NL@% %@AB@% ' If there is a period, add .BAK to the base:%@AE@%%@NL@% IF Extension > 0 THEN%@NL@% Backup$ = LEFT$(FileName$, Extension - 1) + ".BAK"%@NL@% %@AB@% ' Otherwise, add .BAK to the whole name:%@AE@%%@NL@% ELSE%@NL@% Backup$ = FileName$ + ".BAK"%@NL@% END IF%@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%CUBE.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\CUBE.BAS%@AE@%%@NL@% %@NL@% %@AB@%' Define the macro string used to draw the cube%@AE@%%@NL@% %@AB@%' and paint its sides:%@AE@%%@NL@% One$ = "BR30 BU25 C1 R54 U45 L54 D45 BE20 P1,1 G20 C2 G20"%@NL@% Two$ = "R54 E20 L54 BD5 P2,2 U5 C4 G20 U45 E20 D45 BL5 P4,4"%@NL@% Plot$ = One$ + Two$%@NL@% %@NL@% APage% = 1 ' Initialize values for the active and visual%@NL@% VPage% = 0 ' pages as well as the angle of rotation.%@NL@% Angle% = 0%@NL@% %@NL@% DO%@NL@% SCREEN 7, , APage%, VPage% ' Draw to the active page%@NL@% %@AB@% ' while showing the visual page.%@AE@%%@NL@% %@NL@% CLS 1 ' Clear the active page.%@NL@% %@NL@% %@AB@% ' Rotate the cube "Angle%" degrees:%@AE@%%@NL@% DRAW "TA" + STR$(Angle%) + Plot$%@NL@% %@NL@% %@AB@% ' Angle% is some multiple of 15 degrees:%@AE@%%@NL@% Angle% = (Angle% + 15) MOD 360%@NL@% %@NL@% %@AB@% ' Drawing is complete, so make the cube visible in its%@AE@%%@NL@% %@AB@% ' new position by switching the active and visual pages:%@AE@%%@NL@% SWAP APage%, VPage%%@NL@% %@NL@% LOOP WHILE INKEY$ = "" ' A keystroke ends the program.%@NL@% %@NL@% END%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%EDPAT.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\EDPAT.BAS%@AE@%%@NL@% %@NL@% DECLARE SUB DrawPattern ()%@NL@% DECLARE SUB EditPattern ()%@NL@% DECLARE SUB Initialize ()%@NL@% DECLARE SUB ShowPattern (OK$)%@NL@% %@NL@% DIM Bit%(0 TO 7), Pattern$, PatternSize%%@NL@% DO%@NL@% Initialize%@NL@% EditPattern%@NL@% ShowPattern OK$%@NL@% LOOP WHILE OK$ = "Y"%@NL@% %@NL@% END%@NL@% %@AB@%' ======================= DRAWPATTERN ====================%@AE@%%@NL@% %@AB@%' Draws a patterned rectangle on the right side of screen%@AE@%%@NL@% %@AB@%' ========================================================%@AE@%%@NL@% %@NL@% %@AB@%' ======================= EDITPATTERN =====================%@AE@%%@NL@% %@AB@%' Edits a tile-byte pattern%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% %@NL@% %@AB@%' ======================= INITIALIZE ======================%@AE@%%@NL@% %@AB@%' Sets up starting pattern and screen%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% %@AB@%' ======================== SHOWPATTERN ====================%@AE@%%@NL@% %@AB@%' Prints the CHR$ values used by PAINT to make pattern%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% SUB DrawPattern STATIC%@NL@% SHARED Pattern$%@NL@% VIEW (320, 24)-(622, 160), 0, 1 ' Set view to rectangle.%@NL@% PAINT (1, 1), Pattern$ ' Use PAINT to fill it.%@NL@% VIEW ' Set view to full screen.%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB EditPattern STATIC%@NL@% SHARED Pattern$, Bit%(), PatternSize%%@NL@% %@NL@% ByteNum% = 1 ' Starting position.%@NL@% BitNum% = 7%@NL@% Null$ = CHR$(0) ' CHR$(0) is the first byte of the%@NL@% %@AB@% ' two-byte string returned when a%@AE@%%@NL@% %@AB@% ' direction key such as UP or DOWN is%@AE@%%@NL@% %@AB@% ' pressed.%@AE@%%@NL@% DO%@NL@% %@NL@% %@AB@% ' Calculate starting location on screen of this bit:%@AE@%%@NL@% X% = ((7 - BitNum%) * 16) + 80%@NL@% Y% = (ByteNum% + 2) * 8%@NL@% %@NL@% %@AB@% ' Wait for a key press (flash cursor each 3/10 second):%@AE@%%@NL@% State% = 0%@NL@% RefTime = 0%@NL@% DO%@NL@% %@NL@% %@AB@% ' Check timer and switch cursor state if 3/10 second:%@AE@%%@NL@% IF ABS(TIMER - RefTime) > .3 THEN%@NL@% RefTime = TIMER%@NL@% State% = 1 - State%%@NL@% %@NL@% %@AB@% ' Turn the border of bit on and off:%@AE@%%@NL@% LINE (X% - 1, Y% - 1)-STEP(15, 8), State%, B%@NL@% END IF%@NL@% %@NL@% Check$ = INKEY$ ' Check for keystroke.%@NL@% %@NL@% LOOP WHILE Check$ = "" ' Loop until a key is pressed.%@NL@% %@NL@% %@AB@% ' Erase cursor:%@AE@%%@NL@% LINE (X% - 1, Y% - 1)-STEP(15, 8), 0, B%@NL@% %@NL@% SELECT CASE Check$ ' Respond to keystroke.%@NL@% %@NL@% CASE CHR$(27) ' ESC key pressed:%@NL@% EXIT SUB ' exit this subprogram.%@NL@% CASE CHR$(32) ' SPACEBAR pressed:%@NL@% %@AB@% ' reset state of bit.%@AE@%%@NL@% %@NL@% %@AB@% ' Invert bit in pattern string:%@AE@%%@NL@% CurrentByte% = ASC(MID$(Pattern$, ByteNum%, 1))%@NL@% CurrentByte% = CurrentByte% XOR Bit%(BitNum%)%@NL@% MID$(Pattern$, ByteNum%) = CHR$(CurrentByte%)%@NL@% %@NL@% %@AB@% ' Redraw bit on screen:%@AE@%%@NL@% IF (CurrentByte% AND Bit%(BitNum%)) <> 0 THEN%@NL@% CurrentColor% = 1%@NL@% ELSE%@NL@% CurrentColor% = 0%@NL@% END IF%@NL@% LINE (X% + 1, Y% + 1)-STEP(11, 4), CurrentColor%, BF%@NL@% %@NL@% CASE CHR$(13) ' ENTER key pressed: draw%@NL@% DrawPattern ' pattern in box on right.%@NL@% %@NL@% CASE Null$ + CHR$(75) ' LEFT key: move cursor left.%@NL@% %@NL@% BitNum% = BitNum% + 1%@NL@% IF BitNum% > 7 THEN BitNum% = 0%@NL@% %@NL@% CASE Null$ + CHR$(77) ' RIGHT key: move cursor right.%@NL@% %@NL@% BitNum% = BitNum% - 1%@NL@% IF BitNum% < 0 THEN BitNum% = 7%@NL@% %@NL@% CASE Null$ + CHR$(72) ' UP key: move cursor up.%@NL@% %@NL@% ByteNum% = ByteNum% - 1%@NL@% IF ByteNum% < 1 THEN ByteNum% = PatternSize%%@NL@% %@NL@% CASE Null$ + CHR$(80) ' DOWN key: move cursor down.%@NL@% %@NL@% ByteNum% = ByteNum% + 1%@NL@% IF ByteNum% > PatternSize% THEN ByteNum% = 1%@NL@% END SELECT%@NL@% LOOP%@NL@% END SUB%@NL@% %@NL@% SUB Initialize STATIC%@NL@% SHARED Pattern$, Bit%(), PatternSize%%@NL@% %@NL@% %@AB@% ' Set up an array holding bits in positions 0 to 7:%@AE@%%@NL@% FOR I% = 0 TO 7%@NL@% Bit%(I%) = 2 ^ I%%@NL@% NEXT I%%@NL@% %@NL@% CLS%@NL@% %@NL@% %@AB@% ' Input the pattern size (in number of bytes):%@AE@%%@NL@% LOCATE 5, 5%@NL@% PRINT "Enter pattern size (1-16 rows):";%@NL@% DO%@NL@% LOCATE 5, 38%@NL@% PRINT " ";%@NL@% LOCATE 5, 38%@NL@% INPUT "", PatternSize%%@NL@% LOOP WHILE PatternSize% < 1 OR PatternSize% > 16%@NL@% %@NL@% %@AB@% ' Set initial pattern to all bits set:%@AE@%%@NL@% Pattern$ = STRING$(PatternSize%, 255)%@NL@% %@NL@% SCREEN 2 ' 640 x 200 monochrome graphics mode%@NL@% %@NL@% %@AB@% ' Draw dividing lines:%@AE@%%@NL@% LINE (0, 10)-(635, 10), 1%@NL@% LINE (300, 0)-(300, 199)%@NL@% LINE (302, 0)-(302, 199)%@NL@% %@NL@% %@AB@% ' Print titles:%@AE@%%@NL@% LOCATE 1, 13: PRINT "Pattern Bytes"%@NL@% LOCATE 1, 53: PRINT "Pattern View"%@NL@% %@NL@% %@NL@% %@AB@%' Draw editing screen for pattern:%@AE@%%@NL@% FOR I% = 1 TO PatternSize%%@NL@% %@NL@% %@AB@% ' Print label on left of each line:%@AE@%%@NL@% LOCATE I% + 3, 8%@NL@% PRINT USING "##:"; I%%@NL@% %@NL@% %@AB@% ' Draw "bit" boxes:%@AE@%%@NL@% X% = 80%@NL@% Y% = (I% + 2) * 8%@NL@% FOR J% = 1 TO 8%@NL@% LINE (X%, Y%)-STEP(13, 6), 1, BF%@NL@% X% = X% + 16%@NL@% NEXT J%%@NL@% NEXT I%%@NL@% %@NL@% DrawPattern ' Draw "Pattern View" box.%@NL@% %@NL@% LOCATE 21, 1%@NL@% PRINT "DIRECTION keys........Move cursor"%@NL@% PRINT "SPACEBAR............Changes point"%@NL@% PRINT "ENTER............Displays pattern"%@NL@% PRINT "ESC.........................Quits";%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB ShowPattern (OK$) STATIC%@NL@% SHARED Pattern$, PatternSize%%@NL@% %@NL@% %@AB@% ' Return screen to 80-column text mode:%@AE@%%@NL@% SCREEN 0, 0%@NL@% WIDTH 80%@NL@% %@NL@% PRINT "The following characters make up your pattern:"%@NL@% PRINT%@NL@% %@NL@% %@AB@% ' Print out the value for each pattern byte:%@AE@%%@NL@% FOR I% = 1 TO PatternSize%%@NL@% PatternByte% = ASC(MID$(Pattern$, I%, 1))%@NL@% PRINT "CHR$("; LTRIM$(STR$(PatternByte%)); ")"%@NL@% NEXT I%%@NL@% PRINT%@NL@% LOCATE , , 1%@NL@% PRINT "New pattern? ";%@NL@% OK$ = UCASE$(INPUT$(1))%@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%ENTAB.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\ENTAB.BAS%@AE@%%@NL@% %@NL@% %@AB@%' ENTAB.BAS%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Replace runs of spaces in a file with tabs.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% DECLARE SUB SetTabPos ()%@NL@% DECLARE SUB StripCommand (CLine$)%@NL@% %@NL@% %@NL@% DEFINT A-Z%@NL@% DECLARE FUNCTION ThisIsATab (Column AS INTEGER)%@NL@% %@NL@% CONST MAXLINE = 255%@NL@% CONST TABSPACE = 8%@NL@% CONST NO = 0, YES = NOT NO%@NL@% %@NL@% DIM SHARED TabStops(MAXLINE) AS INTEGER%@NL@% %@NL@% StripCommand (COMMAND$)%@NL@% %@NL@% %@AB@%' Set the tab positions (uses the global array TabStops).%@AE@%%@NL@% SetTabPos%@NL@% %@NL@% LastColumn = 1%@NL@% %@NL@% DO%@NL@% %@NL@% CurrentColumn = LastColumn%@NL@% %@NL@% %@AB@%' Replace a run of blanks with a tab when you reach a tab%@AE@%%@NL@% %@AB@%' column. CurrentColumn is the current column read.%@AE@%%@NL@% %@AB@%' LastColumn is the last column that was printed.%@AE@%%@NL@% DO%@NL@% C$ = INPUT$(1,#1)%@NL@% IF C$ <> " " AND C$ <> CHR$(9) THEN EXIT DO%@NL@% CurrentColumn = CurrentColumn + 1%@NL@% IF C$=CHR$(9) OR ThisIsATab(CurrentColumn) THEN%@NL@% %@AB@% ' Go to a tab column if we have a tab and this%@AE@%%@NL@% %@AB@% ' is not a tab column.%@AE@%%@NL@% DO WHILE NOT ThisIsATab(CurrentColumn)%@NL@% CurrentColumn=CurrentColumn+1%@NL@% LOOP%@NL@% PRINT #2, CHR$(9);%@NL@% LastColumn = CurrentColumn%@NL@% END IF%@NL@% LOOP%@NL@% %@NL@% %@AB@%' Print out any blanks left over.%@AE@%%@NL@% DO WHILE LastColumn < CurrentColumn%@NL@% PRINT #2, " ";%@NL@% LastColumn = LastColumn + 1%@NL@% LOOP%@NL@% %@NL@% %@AB@%' Print the non-blank character.%@AE@%%@NL@% PRINT #2, C$;%@NL@% %@NL@% %@AB@%' Reset the column position if this is the end of a line.%@AE@%%@NL@% IF C$ = CHR$(10) THEN%@NL@% LastColumn = 1%@NL@% ELSE%@NL@% LastColumn = LastColumn + 1%@NL@% END IF%@NL@% %@NL@% LOOP UNTIL EOF(1)%@NL@% CLOSE #1, #2%@NL@% END%@NL@% %@NL@% %@AB@%'------------------SUB SetTabPos-------------------------%@AE@%%@NL@% %@AB@%' Set the tab positions in the array TabStops.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB SetTabPos STATIC%@NL@% FOR I = 1 TO 255%@NL@% TabStops(I) = ((I MOD TABSPACE) = 1)%@NL@% NEXT I%@NL@% END SUB%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'------------------SUB StripCommand----------------------%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB StripCommand (CommandLine$) STATIC%@NL@% IF CommandLine$ = "" THEN%@NL@% INPUT "File to entab: ", InFileName$%@NL@% INPUT "Store entabbed file in: ", OutFileName$%@NL@% ELSE%@NL@% SpacePos = INSTR(CommandLine$, " ")%@NL@% IF SpacePos > 0 THEN%@NL@% InFileName$ = LEFT$(CommandLine$, SpacePos - 1)%@NL@% OutFileName$ = LTRIM$(MID$(CommandLine$, SpacePos))%@NL@% ELSE%@NL@% InFileName$ = CommandLine$%@NL@% INPUT "Store entabbed file in: ", OutFileName$%@NL@% END IF%@NL@% END IF%@NL@% OPEN InFileName$ FOR INPUT AS #1%@NL@% OPEN OutFileName$ FOR OUTPUT AS #2%@NL@% END SUB%@NL@% %@AB@%'---------------FUNCTION ThisIsATab----------------------%@AE@%%@NL@% %@AB@%' Answer the question, "Is this a tab position?"%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION ThisIsATab (LastColumn AS INTEGER) STATIC%@NL@% IF LastColumn > MAXLINE THEN%@NL@% ThisIsATab = YES%@NL@% ELSE%@NL@% ThisIsATab = TabStops(LastColumn)%@NL@% END IF%@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@2@%%@AH@%FLPT.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\FLPT.BAS%@AE@%%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' FLPT.BAS%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Displays how a given real value is stored in memory.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% DEFINT A-Z%@NL@% DECLARE FUNCTION MHex$ (X AS INTEGER)%@NL@% DIM Bytes(3)%@NL@% %@NL@% CLS%@NL@% PRINT "Internal format of IEEE number (all values in hexadecimal)"%@NL@% PRINT%@NL@% DO%@NL@% %@NL@% %@AB@% ' Get the value and calculate the address of the variable.%@AE@%%@NL@% INPUT "Enter a real number (or END to quit): ", A$%@NL@% IF UCASE$(A$) = "END" THEN EXIT DO%@NL@% RealValue! = VAL(A$)%@NL@% %@AB@% ' Convert the real value to a long without changing any of%@AE@%%@NL@% %@AB@% ' the bits.%@AE@%%@NL@% AsLong& = CVL(MKS$(RealValue!))%@NL@% %@AB@% ' Make a string of hex digits, and add leading zeroes.%@AE@%%@NL@% Strout$ = HEX$(AsLong&)%@NL@% Strout$ = STRING$(8 - LEN(Strout$), "0") + Strout$%@NL@% %@NL@% %@AB@% ' Save the sign bit, and then eliminate it so it doesn't%@AE@%%@NL@% %@AB@% ' affect breaking out the bytes%@AE@%%@NL@% SignBit& = AsLong& AND &H80000000%@NL@% AsLong& = AsLong& AND &H7FFFFFFF%@NL@% %@AB@% ' Split the real value into four separate bytes%@AE@%%@NL@% %@AB@% ' --the AND removes unwanted bits; dividing by 256 shifts%@AE@%%@NL@% %@AB@% ' the value right 8 bit positions.%@AE@%%@NL@% FOR I = 0 TO 3%@NL@% Bytes(I) = AsLong& AND &HFF&%@NL@% AsLong& = AsLong& \ 256&%@NL@% NEXT I%@NL@% %@AB@% ' Display how the value appears in memory.%@AE@%%@NL@% PRINT%@NL@% PRINT "Bytes in Memory"%@NL@% PRINT " High Low"%@NL@% FOR I = 1 TO 7 STEP 2%@NL@% PRINT " "; MID$(Strout$, I, 2);%@NL@% NEXT I%@NL@% PRINT : PRINT%@NL@% %@NL@% %@AB@% ' Set the value displayed for the sign bit.%@AE@%%@NL@% Sign = ABS(SignBit& <> 0)%@NL@% %@NL@% %@AB@% ' The exponent is the right seven bits of byte 3 and the%@AE@%%@NL@% %@AB@% ' leftmost bit of byte 2. Multiplying by 2 shifts left and%@AE@%%@NL@% %@AB@% ' makes room for the additional bit from byte 2.%@AE@%%@NL@% Exponent = Bytes(3) * 2 + Bytes(2) \ 128%@NL@% %@NL@% %@AB@% ' The first part of the mantissa is the right seven bits%@AE@%%@NL@% %@AB@% ' of byte 2. The OR operation makes sure the implied bit%@AE@%%@NL@% %@AB@% ' is displayed by setting the leftmost bit.%@AE@%%@NL@% Mant1 = (Bytes(2) OR &H80)%@NL@% PRINT " Bit 31 Bits 30-23 Implied Bit & Bits 22-0"%@NL@% PRINT "Sign Bit Exponent Bits Mantissa Bits"%@NL@% PRINT TAB(4); Sign; TAB(17); MHex$(Exponent);%@NL@% PRINT TAB(33); MHex$(Mant1); MHex$(Bytes(1)); MHex$(Bytes(0))%@NL@% PRINT%@NL@% %@NL@% LOOP%@NL@% %@NL@% %@AB@%' MHex$ makes sure we always get two hex digits.%@AE@%%@NL@% FUNCTION MHex$ (X AS INTEGER) STATIC%@NL@% D$ = HEX$(X)%@NL@% IF LEN(D$) < 2 THEN D$ = "0" + D$%@NL@% MHex$ = D$%@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%FONTASM.ASM%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\FONTASM.ASM%@AE@%%@NL@% %@NL@% .MODEL MEDIUM%@NL@% %@AB@%;************************************************************%@AE@%%@NL@% %@AB@%; FONTASM.ASM - assembly lang routines for Font Toolbox%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; Copyright (C) 1989 Microsoft Corporation, All Rights Reserved%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; fl_SetBltDir - Sets bltchar direction increments%@AE@%%@NL@% %@AB@%; fl_SetBltColor - Sets color parameter for bltchar%@AE@%%@NL@% %@AB@%; fl_SetBltParams - Sets font related parameters for bltchar%@AE@%%@NL@% %@AB@%; fl_BltChar - Character output routine%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; fl_MovMem - Moves memory%@AE@%%@NL@% %@AB@%; fl_ansi - Maps IBM chars to Windows ANSI;%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%;************************************************************%@AE@%%@NL@% %@NL@% %@AB@%; BltChar data block%@AE@%%@NL@% .DATA%@NL@% %@NL@% %@AB@%; These are set by fl_SetBltParams%@AE@%%@NL@% HdrLen dw 0 %@AB@%;length of windows font file header%@AE@%%@NL@% CharHeight dw 0 %@AB@%;character height%@AE@%%@NL@% FirstChar dw 0 %@AB@%;first character defined in font%@AE@%%@NL@% LastChar dw 0 %@AB@%;last character defined in font%@AE@%%@NL@% DefaultChar dw 0 %@AB@%;default character to use%@AE@%%@NL@% %@NL@% %@AB@%; This is set by fl_SetBltColor%@AE@%%@NL@% CharColor dw 0 %@AB@%;current character color%@AE@%%@NL@% %@NL@% %@AB@%; These are set by fl_SetBltDir%@AE@%%@NL@% XPixInc dw 1 %@AB@%;x inc for each pixel in character bitmap%@AE@%%@NL@% YPixInc dw 0 %@AB@%;y inc for each pixel in character bitmap%@AE@%%@NL@% XRowInc dw 0 %@AB@%;x inc for each row in character bitmap%@AE@%%@NL@% YRowInc dw 1 %@AB@%;y inc for each row in character bitmap%@AE@%%@NL@% XColInc dw 8 %@AB@%;x inc for each column (8 bits) in char bitmap%@AE@%%@NL@% YColInc dw 0 %@AB@%;y inc for each column (8 bits) in char bitmap%@AE@%%@NL@% %@NL@% .CODE%@NL@% %@AB@%;********************************************************************%@AE@%%@NL@% %@AB@%; fl_SetBltDir - Sets pixel, row, and column step values for bltchar%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; BASIC CALL:%@AE@%%@NL@% %@AB@%; fl.SetBltDir XPixInc%, YPixInc%, XRowInc%, YRowInc%%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; Comments:%@AE@%%@NL@% %@AB@%; When bltchar is blt-ing a bitmap to allow the different%@AE@%%@NL@% %@AB@%; directions to be output it uses preset counter increments%@AE@%%@NL@% %@AB@%; for moving a pixel, to the next row, and to the next column%@AE@%%@NL@% %@AB@%; of the bitmap. The pixel and row increments are input to this%@AE@%%@NL@% %@AB@%; routine. The column increments are calculates as 8 times the%@AE@%%@NL@% %@AB@%; pixel increment.%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%;********************************************************************%@AE@%%@NL@% %@NL@% %@AB@%; Parameters%@AE@%%@NL@% pXPixInc equ WORD PTR [bp+12]%@NL@% pYPixInc equ WORD PTR [bp+10]%@NL@% pXRowInc equ WORD PTR [bp+8]%@NL@% pYRowInc equ WORD PTR [bp+6]%@NL@% %@NL@% PUBLIC fl_SetBltDir%@NL@% fl_SetBltDir PROC%@NL@% %@NL@% push bp %@AB@%;Entry%@AE@%%@NL@% mov bp,sp%@NL@% %@NL@% mov ax,pXRowInc %@AB@%;Save input parameters%@AE@%%@NL@% mov XRowInc,ax%@NL@% mov ax,pYRowInc%@NL@% mov YRowInc,ax%@NL@% %@NL@% mov ax,pXPixInc%@NL@% mov XPixInc,ax%@NL@% mov cl,3%@NL@% shl ax,cl%@NL@% mov XColInc,ax %@AB@%;Column increment = Pix Inc * 8%@AE@%%@NL@% %@NL@% mov ax,pYPixInc%@NL@% mov YPixInc,ax%@NL@% mov cl,3%@NL@% shl ax,cl%@NL@% mov YColInc,ax %@AB@%;Column increment = Pix Inc * 8%@AE@%%@NL@% %@NL@% pop bp %@AB@%;Exit%@AE@%%@NL@% ret 8%@NL@% fl_SetBltDir ENDP%@NL@% %@NL@% %@AB@%;********************************************************************%@AE@%%@NL@% %@AB@%; fl_SetBltColor - Sets the color of blt-ed characters%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; BASIC CALL:%@AE@%%@NL@% %@AB@%; fl.SetBltColor color%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%;********************************************************************%@AE@%%@NL@% %@NL@% %@AB@%; Parameters%@AE@%%@NL@% pColor EQU WORD PTR [bp+6]%@NL@% %@NL@% PUBLIC fl_SetBltColor%@NL@% fl_SetBltColor PROC%@NL@% %@NL@% push bp %@AB@%;Entry%@AE@%%@NL@% mov bp,sp%@NL@% %@NL@% mov ax,pColor %@AB@%;Save color in data block%@AE@%%@NL@% mov CharColor,ax%@NL@% %@NL@% pop bp %@AB@%;Exit%@AE@%%@NL@% ret 2%@NL@% %@NL@% fl_SetBltColor ENDP%@NL@% %@NL@% %@AB@%;********************************************************************%@AE@%%@NL@% %@AB@%; fl_SetBltParams - Sets font-related params for bltchar%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; BASIC CALL:%@AE@%%@NL@% %@AB@%; fl.SetBltParams HdrLen%, CharHgt%, FirstChar%, LastChar%, DefChar%%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%;********************************************************************%@AE@%%@NL@% %@NL@% %@AB@%; Parameters%@AE@%%@NL@% pHdrLen equ WORD PTR [bp+14]%@NL@% pCharHgt equ WORD PTR [bp+12]%@NL@% pFirstChar equ WORD PTR [bp+10]%@NL@% pLastChar equ WORD PTR [bp+8]%@NL@% pDefChar equ WORD PTR [bp+6]%@NL@% %@NL@% PUBLIC fl_SetBltParams%@NL@% fl_SetBltParams PROC%@NL@% %@NL@% push bp %@AB@%;Entry%@AE@%%@NL@% mov bp,sp%@NL@% %@NL@% mov ax,pHdrLen%@NL@% mov HdrLen,ax%@NL@% %@NL@% mov ax,pCharHgt%@NL@% mov CharHeight,ax%@NL@% %@NL@% mov ax,pFirstChar%@NL@% mov FirstChar,ax%@NL@% %@NL@% mov ax,pLastChar%@NL@% mov LastChar,ax%@NL@% %@NL@% mov ax,pDefChar%@NL@% mov DefaultChar,ax%@NL@% %@NL@% pop bp %@AB@%;Exit%@AE@%%@NL@% ret 10%@NL@% %@NL@% fl_SetBltParams ENDP%@NL@% %@NL@% %@AB@%;********************************************************************%@AE@%%@NL@% %@AB@%; fl_BltChar - Outputs a character's bitmap to the screen%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; BASIC CALL:%@AE@%%@NL@% %@AB@%; fl.BltChar FontAddr(far), Char%, X%, Y%%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%;********************************************************************%@AE@%%@NL@% %@NL@% %@AB@%; BASIC Procedures%@AE@%%@NL@% EXTRN B$N1I2:far, B$PSTC:far%@NL@% %@NL@% %@AB@%; Parameters%@AE@%%@NL@% pFASeg equ WORD PTR [bp+14]%@NL@% pFAOffset equ WORD PTR [bp+12]%@NL@% pChar equ WORD PTR [bp+10]%@NL@% pX equ WORD PTR [bp+8]%@NL@% pY equ WORD PTR [bp+6]%@NL@% %@NL@% %@AB@%; Local Variables%@AE@%%@NL@% .RowX equ WORD PTR [bp-2]%@NL@% .RowY equ WORD PTR [bp-4]%@NL@% .CharWid equ WORD PTR [bp-6]%@NL@% .ColWid equ WORD PTR [bp-8]%@NL@% %@NL@% PUBLIC fl_BltChar%@NL@% fl_BltChar PROC%@NL@% %@NL@% push bp %@AB@%;Entry%@AE@%%@NL@% mov bp,sp%@NL@% sub sp,8 %@AB@%;Make room for local variables%@AE@%%@NL@% push di%@NL@% push si%@NL@% %@NL@% %@AB@%;Normalize font address (make offset as small as possible)%@AE@%%@NL@% mov ax,pFAOffset%@NL@% mov bx,pFASeg%@NL@% push ax%@NL@% mov cl,4%@NL@% shr ax,cl %@AB@%;offset = offset div 16%@AE@%%@NL@% add bx,ax %@AB@%;seg = seg + offset%@AE@%%@NL@% pop ax%@NL@% and ax,0Fh %@AB@%;offset = original offset mod 16%@AE@%%@NL@% mov si,ax%@NL@% mov es,bx%@NL@% %@NL@% %@AB@%;Calculate character number%@AE@%%@NL@% mov bx,pChar%@NL@% cmp bx,LastChar%@NL@% ja usedefchar %@AB@%;Char is > last char, use default%@AE@%%@NL@% sub bx,FirstChar%@NL@% jnc getsize %@AB@%;Char is > first char, is OK%@AE@%%@NL@% usedefchar: mov bx,DefaultChar%@NL@% %@NL@% %@AB@%;Get character width from character table in font%@AE@%%@NL@% getsize: shl bx,1%@NL@% shl bx,1 %@AB@%;char = char * 4%@AE@%%@NL@% add bx,si %@AB@%;offset into char table%@AE@%%@NL@% mov cx,es:[bx] %@AB@%;cx = character width%@AE@%%@NL@% mov .CharWid,cx%@NL@% %@NL@% %@AB@%;Calculate character bitmap address%@AE@%%@NL@% inc bx %@AB@%;move to next two bytes in char table%@AE@%%@NL@% inc bx%@NL@% mov cx,es:[bx]%@NL@% add si,cx %@AB@%;add bitmap offset into font index%@AE@%%@NL@% sub si,HdrLen %@AB@%;subtract length of header%@AE@%%@NL@% dec si %@AB@%;decrement for use in output algorithm%@AE@%%@NL@% %@NL@% %@AB@%;Blt character%@AE@%%@NL@% mov cx,pX %@AB@%;cx = x coord%@AE@%%@NL@% mov dx,pY %@AB@%;dx = y coord%@AE@%%@NL@% %@NL@% mov bx,.CharWid%@NL@% %@NL@% colloop: mov .RowX,cx %@AB@%;save coordinates of this row%@AE@%%@NL@% mov .RowY,dx%@NL@% push bx %@AB@%;save remaining bits in character%@AE@%%@NL@% cmp bx,8 %@AB@%;limit to 8 for this column%@AE@%%@NL@% jle colloop2%@NL@% mov bx,8%@NL@% %@NL@% colloop2: mov .ColWid,bx %@AB@%;save width of this column for other rows%@AE@%%@NL@% mov ax,CharHeight %@AB@%;counter for number of rows%@AE@%%@NL@% %@NL@% rowloop: push ax%@NL@% inc si %@AB@%;increment bitmap pointer%@AE@%%@NL@% mov al,es:[si] %@AB@%;get byte from bitmap%@AE@%%@NL@% %@NL@% pixloop: shl al,1 %@AB@%;check next bit (from left to right)%@AE@%%@NL@% jnc nextpixel %@AB@%;skip this pixel%@AE@%%@NL@% %@NL@% push ax %@AB@%;save registers%@AE@%%@NL@% push bx%@NL@% push cx%@NL@% push dx%@NL@% push es%@NL@% push si%@NL@% %@NL@% mov ax,CharColor %@AB@%;set up params for pset call%@AE@%%@NL@% push ax %@AB@%;color%@AE@%%@NL@% push cx %@AB@%;x-coordinate%@AE@%%@NL@% push dx %@AB@%;y-coordinate%@AE@%%@NL@% call B$N1I2 %@AB@%;set graphics cursor location%@AE@%%@NL@% call B$PSTC %@AB@%;call PSET%@AE@%%@NL@% %@NL@% pop si %@AB@%;restore registers%@AE@%%@NL@% pop es%@NL@% pop dx%@NL@% pop cx%@NL@% pop bx%@NL@% pop ax%@NL@% %@NL@% nextpixel: jz nextrow %@AB@%;skip remaining zero bits%@AE@%%@NL@% add cx,XPixInc %@AB@%;increment x and y coordinates%@AE@%%@NL@% add dx,YPixInc%@NL@% dec bx %@AB@%;check for end of byte%@AE@%%@NL@% jnz pixloop %@AB@%;go for another pixel%@AE@%%@NL@% %@NL@% nextrow: mov cx,.RowX %@AB@%;retrieve the start coord of this row%@AE@%%@NL@% mov dx,.RowY%@NL@% add cx,XRowInc %@AB@%;increment counters for next row%@AE@%%@NL@% add dx,YRowInc%@NL@% mov .RowX,cx %@AB@%;save 'em back again%@AE@%%@NL@% mov .RowY,dx%@NL@% mov bx,.ColWid %@AB@%;reset the column width%@AE@%%@NL@% pop ax %@AB@%;check for the end of this column%@AE@%%@NL@% dec ax%@NL@% jnz rowloop %@AB@%;repeat for another row%@AE@%%@NL@% %@NL@% nextcol: mov cx,pX %@AB@%;retrieve the start coord of this column%@AE@%%@NL@% mov dx,pY%@NL@% add cx,XColInc %@AB@%;increment coordinates for next column%@AE@%%@NL@% add dx,YColInc%@NL@% mov pX,cx %@AB@%;save coordinates to use after next column%@AE@%%@NL@% mov pY,dx%@NL@% pop bx %@AB@%;check for end of the bitmap%@AE@%%@NL@% sub bx,8%@NL@% ja colloop %@AB@%;repeat for another column%@AE@%%@NL@% %@NL@% %@AB@%;Done%@AE@%%@NL@% mov ax,.CharWid %@AB@%;return value%@AE@%%@NL@% %@NL@% pop si %@AB@%;Exit%@AE@%%@NL@% pop di%@NL@% mov sp,bp%@NL@% pop bp%@NL@% ret 10%@NL@% fl_BltChar ENDP%@NL@% %@NL@% %@AB@%;********************************************************************%@AE@%%@NL@% %@AB@%; fl_MovMem - Moves memory bytes%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; BASIC CALL:%@AE@%%@NL@% %@AB@%; fl.MovMem source, dest, nbytes%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%;********************************************************************%@AE@%%@NL@% PUBLIC fl_MovMem%@NL@% fl_MovMem PROC%@NL@% push bp%@NL@% mov bp,sp%@NL@% push si%@NL@% push ds%@NL@% push di%@NL@% %@NL@% les di,[bp+12]%@NL@% lds si,[bp+8]%@NL@% mov cx,[bp+6]%@NL@% rep movsb%@NL@% %@NL@% pop di%@NL@% pop ds%@NL@% pop si%@NL@% pop bp%@NL@% ret 10%@NL@% fl_MovMem ENDP%@NL@% %@NL@% %@AB@%;********************************************************************%@AE@%%@NL@% %@AB@%; fl_ansi - Converts IBM char to Windows ANSI mapping%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; BASIC CALL:%@AE@%%@NL@% %@AB@%; ansi_byte = fl_ansi (ibm_char%)%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%;********************************************************************%@AE@%%@NL@% .CODE%@NL@% PUBLIC fl_ansi%@NL@% fl_ansi PROC%@NL@% push bp%@NL@% mov bp,sp%@NL@% %@NL@% xor ax,ax %@AB@%; zero ax%@AE@%%@NL@% mov al,[bp+6] %@AB@%; move input byte to ax%@AE@%%@NL@% mov bx,ax %@AB@%; copy byte to bx%@AE@%%@NL@% and al,7FH %@AB@%; mask off high bit%@AE@%%@NL@% test bl,80H %@AB@%; test bx to see it high bit set%@AE@%%@NL@% jz fl_a_2 %@AB@%; if so then byte < 128, no translation%@AE@%%@NL@% %@NL@% mov bx,OFFSET _OemToAnsiTable%@NL@% xlat%@NL@% %@NL@% fl_a_2: pop bp%@NL@% ret 2%@NL@% fl_ansi ENDP%@NL@% %@NL@% %@NL@% %@AB@%;***************************************************************************%@AE@%%@NL@% %@AB@%; USA OEM/ANSI translation tables. *%@AE@%%@NL@% %@AB@%;***************************************************************************%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@NL@% %@AB@%; This translation table is used by U.S.A. and some European countries.%@AE@%%@NL@% %@AB@%; The original IBM extended character set is now addressed as Code Page 437.%@AE@%%@NL@% %@AB@%; With DOS 3.3 or later, IBM introduced Code Page 850 as the preeminent%@AE@%%@NL@% %@AB@%; multilingual character set.%@AE@%%@NL@% %@NL@% %@AB@%; this translates Oem codes >= 128 to ANSI.%@AE@%%@NL@% %@AB@%; there are 128 entries.%@AE@%%@NL@% %@NL@% .DATA%@NL@% _OemToAnsiTable label byte%@NL@% %@NL@% db 0C7H %@AB@%; 80h C cedilla%@AE@%%@NL@% db 0FCh %@AB@%; 81h u umlaut%@AE@%%@NL@% db 0E9h %@AB@%; 82h e acute%@AE@%%@NL@% db 0E2h %@AB@%; 83h a circumflex%@AE@%%@NL@% db 0E4h %@AB@%; 84h a umlaut%@AE@%%@NL@% db 0E0h %@AB@%; 85h a grave%@AE@%%@NL@% db 0E5h %@AB@%; 86h a ring%@AE@%%@NL@% db 0E7h %@AB@%; 87h c cedilla%@AE@%%@NL@% db 0EAh %@AB@%; 88h e circumflex%@AE@%%@NL@% db 0EBh %@AB@%; 89h e umlaut%@AE@%%@NL@% db 0E8h %@AB@%; 8Ah e grave%@AE@%%@NL@% db 0EFh %@AB@%; 8Bh i umlaut%@AE@%%@NL@% db 0EEh %@AB@%; 8Ch i circumflex%@AE@%%@NL@% db 0ECh %@AB@%; 8Dh i grave%@AE@%%@NL@% db 0C4h %@AB@%; 8Eh A umlaut%@AE@%%@NL@% db 0C5h %@AB@%; 8Fh A ring%@AE@%%@NL@% %@NL@% db 0C9h %@AB@%; 90h E acute%@AE@%%@NL@% db 0E6h %@AB@%; 91h ae%@AE@%%@NL@% db 0C6h %@AB@%; 92h AE%@AE@%%@NL@% db 0F4h %@AB@%; 93h o circumflex%@AE@%%@NL@% db 0F6h %@AB@%; 94h o umlaut%@AE@%%@NL@% db 0F2h %@AB@%; 95h o grave%@AE@%%@NL@% db 0FBh %@AB@%; 96h u circumflex%@AE@%%@NL@% db 0F9h %@AB@%; 97h u grave%@AE@%%@NL@% db 0FFh %@AB@%; 98h y umlaut%@AE@%%@NL@% db 0D6h %@AB@%; 99h O umlaut%@AE@%%@NL@% db 0DCh %@AB@%; 9Ah U umlaut%@AE@%%@NL@% db 0A2h %@AB@%; 9Bh cent%@AE@%%@NL@% db 0A3h %@AB@%; 9Ch british pound%@AE@%%@NL@% db 0A5h %@AB@%; 9Dh yen%@AE@%%@NL@% db 070h %@AB@%; 9Eh Pesetas%@AE@%%@NL@% db 066h %@AB@%; 9Fh florin (dutch)%@AE@%%@NL@% %@NL@% db 0E1h %@AB@%; A0h a acute%@AE@%%@NL@% db 0EDh %@AB@%; A1h i acute%@AE@%%@NL@% db 0F3h %@AB@%; A2h o acute%@AE@%%@NL@% db 0FAh %@AB@%; A3h u acute%@AE@%%@NL@% db 0F1h %@AB@%; A4h n tilde%@AE@%%@NL@% db 0D1h %@AB@%; A5h N tilde%@AE@%%@NL@% db 0AAh %@AB@%; A6h a underlined superscript%@AE@%%@NL@% db 0BAh %@AB@%; A7h o underlined superscript%@AE@%%@NL@% db 0BFh %@AB@%; A8h inverted question mark%@AE@%%@NL@% db 05Fh %@AB@%; A9h left top corner%@AE@%%@NL@% db 0ACh %@AB@%; AAh right top corner%@AE@%%@NL@% db 0BDh %@AB@%; ABh 1/2%@AE@%%@NL@% db 0BCh %@AB@%; ACh 1/4%@AE@%%@NL@% db 0A1h %@AB@%; ADh inverted point%@AE@%%@NL@% db 0ABh %@AB@%; AEh <<%@AE@%%@NL@% db 0BBh %@AB@%; AFh >>%@AE@%%@NL@% %@NL@% db 05Fh %@AB@%; B0h here begins semigraphic characters%@AE@%%@NL@% db 05Fh %@AB@%; B1h%@AE@%%@NL@% db 05Fh %@AB@%; B2h%@AE@%%@NL@% db 0A6h %@AB@%; B3h Vertical bar%@AE@%%@NL@% db 05Fh %@AB@%; B4h%@AE@%%@NL@% db 05Fh %@AB@%; B5h%@AE@%%@NL@% db 05Fh %@AB@%; B6h%@AE@%%@NL@% db 05Fh %@AB@%; B7h%@AE@%%@NL@% db 05Fh %@AB@%; B8h%@AE@%%@NL@% db 05Fh %@AB@%; B9h%@AE@%%@NL@% db 05Fh %@AB@%; BAh%@AE@%%@NL@% db 05Fh %@AB@%; BBh%@AE@%%@NL@% db 05Fh %@AB@%; BCh%@AE@%%@NL@% db 05Fh %@AB@%; BDh%@AE@%%@NL@% db 05Fh %@AB@%; BEh%@AE@%%@NL@% db 05Fh %@AB@%; BFh%@AE@%%@NL@% %@NL@% db 05Fh %@AB@%; C0h%@AE@%%@NL@% db 05Fh %@AB@%; C1h%@AE@%%@NL@% db 05Fh %@AB@%; C2h%@AE@%%@NL@% db 05Fh %@AB@%; C3h%@AE@%%@NL@% db 05Fh %@AB@%; C4h%@AE@%%@NL@% db 05Fh %@AB@%; C5h%@AE@%%@NL@% db 05Fh %@AB@%; C6h%@AE@%%@NL@% db 05Fh %@AB@%; C7h%@AE@%%@NL@% db 05Fh %@AB@%; C8h%@AE@%%@NL@% db 05Fh %@AB@%; C9h%@AE@%%@NL@% db 05Fh %@AB@%; CAh%@AE@%%@NL@% db 05Fh %@AB@%; CBh%@AE@%%@NL@% db 05Fh %@AB@%; CCh%@AE@%%@NL@% db 05Fh %@AB@%; CDh%@AE@%%@NL@% db 05Fh %@AB@%; CEh%@AE@%%@NL@% db 05Fh %@AB@%; CFh%@AE@%%@NL@% %@NL@% db 05Fh %@AB@%; D0h%@AE@%%@NL@% db 05Fh %@AB@%; D1h%@AE@%%@NL@% db 05Fh %@AB@%; D2h%@AE@%%@NL@% db 05Fh %@AB@%; D3h%@AE@%%@NL@% db 05Fh %@AB@%; D4h%@AE@%%@NL@% db 05Fh %@AB@%; D5h%@AE@%%@NL@% db 05Fh %@AB@%; D6h%@AE@%%@NL@% db 05Fh %@AB@%; D7h%@AE@%%@NL@% db 05Fh %@AB@%; D8h%@AE@%%@NL@% db 05Fh %@AB@%; D9h%@AE@%%@NL@% db 05Fh %@AB@%; DAh%@AE@%%@NL@% db 05Fh %@AB@%; DBh%@AE@%%@NL@% db 05Fh %@AB@%; DCh%@AE@%%@NL@% db 05Fh %@AB@%; DDh%@AE@%%@NL@% db 05Fh %@AB@%; DEh%@AE@%%@NL@% db 05Fh %@AB@%; DFh end of semigraphic characters%@AE@%%@NL@% %@NL@% db 05Fh %@AB@%; E0h alpha%@AE@%%@NL@% db 0DFh %@AB@%; E1h german sharp S or greek beta%@AE@%%@NL@% db 05Fh %@AB@%; E2h lambda%@AE@%%@NL@% db 0B6h %@AB@%; E3h pi%@AE@%%@NL@% db 05Fh %@AB@%; E4h sigma uc%@AE@%%@NL@% db 05Fh %@AB@%; E5h sigma lc%@AE@%%@NL@% db 0B5h %@AB@%; E6h mu%@AE@%%@NL@% db 05Fh %@AB@%; E7h tau%@AE@%%@NL@% db 05Fh %@AB@%; E8h phi uc%@AE@%%@NL@% db 05Fh %@AB@%; E9h theta%@AE@%%@NL@% db 05Fh %@AB@%; EAh omega%@AE@%%@NL@% db 05Fh %@AB@%; EBh delta%@AE@%%@NL@% db 05Fh %@AB@%; ECh infinite%@AE@%%@NL@% db 0D8h %@AB@%; EDh math empty set or phi lc%@AE@%%@NL@% db 05Fh %@AB@%; EEh math own sign%@AE@%%@NL@% db 05Fh %@AB@%; EFh math include sign%@AE@%%@NL@% %@NL@% db 05Fh %@AB@%; F0h math equivalence sign%@AE@%%@NL@% db 0B1h %@AB@%; F1h + underlined%@AE@%%@NL@% db 05Fh %@AB@%; F2h greater equal%@AE@%%@NL@% db 05Fh %@AB@%; F3h less equal%@AE@%%@NL@% db 05Fh %@AB@%; F4h math integral upper part%@AE@%%@NL@% db 05Fh %@AB@%; F5h math integral lower part%@AE@%%@NL@% db 05Fh %@AB@%; F6h math divide%@AE@%%@NL@% db 05Fh %@AB@%; F7h math approximately (~)%@AE@%%@NL@% db 0B0h %@AB@%; F8h degree%@AE@%%@NL@% db 0B7h %@AB@%; F9h period accent (bold)%@AE@%%@NL@% db 0B7h %@AB@%; FAh period accent%@AE@%%@NL@% db 05Fh %@AB@%; FBh math root%@AE@%%@NL@% db 06Eh %@AB@%; FCh n superscript%@AE@%%@NL@% db 0B2h %@AB@%; FDh 2 superscript%@AE@%%@NL@% db 05Fh %@AB@%; FEh%@AE@%%@NL@% db 05Fh %@AB@%; FFh blank%@AE@%%@NL@% %@NL@% END%@NL@% %@NL@% %@NL@% %@2@%%@AH@%FONTB.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\FONTB.BAS%@AE@%%@NL@% %@NL@% %@AB@%'*** FONTB.BAS - Font Routines for the Presentation Graphics Toolbox in%@AE@%%@NL@% %@AB@%' Microsoft BASIC 7.0, Professional Development System%@AE@%%@NL@% %@AB@%' Copyright (C) 1987-1989, Microsoft Corporation%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' NOTE: This sample source code toolbox is intended to demonstrate some%@AE@%%@NL@% %@AB@%' of the extended capabilities of Microsoft BASIC 7.0 Professional Development%@AE@%%@NL@% %@AB@%' system that can help to leverage the professional developer's time more%@AE@%%@NL@% %@AB@%' effectively. While you are free to use, modify, or distribute the routines%@AE@%%@NL@% %@AB@%' in this module in any way you find useful, it should be noted that these are%@AE@%%@NL@% %@AB@%' examples only and should not be relied upon as a fully-tested "add-on"%@AE@%%@NL@% %@AB@%' library.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' PURPOSE: These are the toolbox routines to handle graphics text using%@AE@%%@NL@% %@AB@%' Windows format raster font files:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' To create a library and QuickLib containing the font routines found%@AE@%%@NL@% %@AB@%' in this file, follow these steps:%@AE@%%@NL@% %@AB@%' BC /X/FS fontb.bas%@AE@%%@NL@% %@AB@%' LIB fontb.lib + fontb + fontasm + qbx.lib;%@AE@%%@NL@% %@AB@%' LINK /Q fontb.lib, fontb.qlb,,qbxqlb.lib;%@AE@%%@NL@% %@AB@%' If you are going to use this FONTB.QLB QuickLib in conjunction with%@AE@%%@NL@% %@AB@%' the charting source code (CHRTB.BAS) or the UI toobox source code%@AE@%%@NL@% %@AB@%' (GENERAL.BAS, WINDOW.BAS, MENU.BAS and MOUSE.BAS), you need to%@AE@%%@NL@% %@AB@%' include the assembly code routines referenced in these files. For the%@AE@%%@NL@% %@AB@%' charting routines, create FONTB.LIB as follows before you create the%@AE@%%@NL@% %@AB@%' QuickLib:%@AE@%%@NL@% %@AB@%' LIB fontb.lib + fontb + fontasm + chrtasm + qbx.lib;%@AE@%%@NL@% %@AB@%' For the UI toolbox routines, create the library as follows:%@AE@%%@NL@% %@AB@%' LIB fontb.lib + fontb + fontasm + uiasm + qbx.lib;%@AE@%%@NL@% %@AB@%'**************************************************************************%@AE@%%@NL@% %@NL@% %@AB@%' $INCLUDE: 'QBX.BI'%@AE@%%@NL@% %@AB@%' $INCLUDE: 'FONTB.BI'%@AE@%%@NL@% %@NL@% CONST cFALSE = 0 ' Logical False%@NL@% CONST cTRUE = NOT cFALSE ' Logical True%@NL@% %@NL@% CONST cDefaultColor = 15 ' Default character color (white in all modes)%@NL@% CONST cDefaultDir = 0 ' Default character direction%@NL@% CONST cDefaultFont = 1 ' Default font selected in LoadFont%@NL@% %@NL@% CONST cMaxFaceName = 32 ' Maximum length of a font name%@NL@% CONST cMaxFileName = 66 ' Maximum length of a font file name%@NL@% CONST cFontResource = &H8008 ' Identifies a font resource%@NL@% CONST cBitMapType = 0 ' Bitmap font type%@NL@% %@NL@% CONST cFileFont = 0 ' Font comes from file%@NL@% CONST cMemFont = 1 ' Font comes from memory%@NL@% %@NL@% CONST cSizeFontHeader = 118 ' Size of Windows font header%@NL@% %@NL@% %@AB@%' *********************************************************************%@AE@%%@NL@% %@AB@%' Data Types:%@AE@%%@NL@% %@NL@% %@AB@%' Some global variables used:%@AE@%%@NL@% TYPE GlobalParams%@NL@% MaxRegistered AS INTEGER ' Max number of registered fonts allowed%@NL@% MaxLoaded AS INTEGER ' Max number of loaded fonts allowed%@NL@% TotalRegistered AS INTEGER ' Number of fonts actually registered%@NL@% TotalLoaded AS INTEGER ' Number of fonts actually loaded%@NL@% %@NL@% NextDataBlock AS INTEGER ' Next available block in font buffer%@NL@% %@NL@% CurrentFont AS INTEGER ' Current font number in loaded fonts%@NL@% CHeight AS INTEGER ' Character height of current font%@NL@% FChar AS INTEGER ' First char in font%@NL@% LChar AS INTEGER ' Last char in font%@NL@% DChar AS INTEGER ' Default char for font%@NL@% DSeg AS INTEGER ' Segment of current font%@NL@% DOffset AS INTEGER ' Offset of current font%@NL@% FontSource AS INTEGER ' Source of current font (File or Mem)%@NL@% %@NL@% CharColorInit AS INTEGER ' cFALSE (0) means color not initialized%@NL@% CharColor AS INTEGER ' Character color%@NL@% CharDirInit AS INTEGER ' cFALSE (0) means dir not initialized%@NL@% CharDir AS INTEGER ' Character direction%@NL@% CharSet AS INTEGER ' Character mappings to use%@NL@% %@NL@% XPixInc AS INTEGER ' X increment direction (0, 1, -1)%@NL@% YPixInc AS INTEGER ' Y increment direction (0, 1, -1)%@NL@% %@NL@% WindowSet AS INTEGER ' cTRUE if GTextWindow has been called%@NL@% WX1 AS SINGLE ' Minimum WINDOW X%@NL@% WY1 AS SINGLE ' Minimum WINDOW Y%@NL@% WX2 AS SINGLE ' Maximum WINDOW X%@NL@% WY2 AS SINGLE ' Maximum WINDOW Y%@NL@% WScrn AS INTEGER ' cTRUE means Y increases top to bottom%@NL@% %@NL@% END TYPE%@NL@% %@NL@% %@AB@%' The following 3 types are needed to read .FON files. They are documented%@AE@%%@NL@% %@AB@%' in chapter 7 of the MS Windows Programmer's Reference:%@AE@%%@NL@% %@NL@% %@AB@%' Windows font file header:%@AE@%%@NL@% TYPE WFHeader%@NL@% dfVersion AS INTEGER%@NL@% dfSize AS LONG%@NL@% dfCopyright AS STRING * 60%@NL@% dfType AS INTEGER%@NL@% dfPoints AS INTEGER%@NL@% dfVertRes AS INTEGER%@NL@% dfHorizRes AS INTEGER%@NL@% dfAscent AS INTEGER%@NL@% dfInternalLeading AS INTEGER%@NL@% dfExternalLeading AS INTEGER%@NL@% dfItalic AS STRING * 1%@NL@% dfUnderline AS STRING * 1%@NL@% dfStrikeOut AS STRING * 1%@NL@% dfWeight AS INTEGER%@NL@% dfCharSet AS STRING * 1%@NL@% dfPixWidth AS INTEGER%@NL@% dfPixHeight AS INTEGER%@NL@% dfPitchAndFamily AS STRING * 1%@NL@% dfAvgWidth AS INTEGER%@NL@% dfMaxWidth AS INTEGER%@NL@% dfFirstChar AS STRING * 1%@NL@% dfLastChar AS STRING * 1%@NL@% dfDefaultChar AS STRING * 1%@NL@% dfBreakChar AS STRING * 1%@NL@% dfWidthBytes AS INTEGER%@NL@% dfDevice AS LONG%@NL@% dfFace AS LONG%@NL@% dfBitsPointer AS LONG%@NL@% dfBitsOffset AS LONG%@NL@% pad AS STRING * 1 ' To ensure word boundry%@NL@% END TYPE%@NL@% %@NL@% %@AB@%' Structure for reading resource type and number from a resource%@AE@%%@NL@% %@AB@%' table:%@AE@%%@NL@% TYPE ResType%@NL@% TypeID AS INTEGER%@NL@% NumResource AS INTEGER%@NL@% Reserved AS LONG%@NL@% END TYPE%@NL@% %@NL@% %@AB@%' Structure for reading an actual resource entry:%@AE@%%@NL@% TYPE ResEntry%@NL@% AddrOffset AS INTEGER%@NL@% Length AS INTEGER%@NL@% ResourceKeywd AS INTEGER%@NL@% ResID AS INTEGER%@NL@% Reserved1 AS LONG%@NL@% END TYPE%@NL@% %@NL@% %@AB@%' Internal font header data type:%@AE@%%@NL@% TYPE IFontInfo%@NL@% Status AS INTEGER ' Processing status. 0=unproc. else <>0%@NL@% FontHeader AS WFHeader ' The Windows font header%@NL@% FaceName AS STRING * cMaxFaceName ' Font name%@NL@% FileName AS STRING * cMaxFileName ' File name%@NL@% FontSource AS INTEGER ' 0=file, 1=memory%@NL@% FileLoc AS LONG ' Location in resource file of font file%@NL@% DataSeg AS INTEGER ' FontData index or Segment address of font%@NL@% DataOffset AS INTEGER ' Offset address of font if in memory%@NL@% BitsOffset AS INTEGER ' Offset from beginning of data to bitmaps%@NL@% END TYPE%@NL@% %@NL@% %@AB@%' Type for selecting registered fonts via LoadFont:%@AE@%%@NL@% TYPE FontSpec%@NL@% FaceName AS STRING * cMaxFaceName%@NL@% Pitch AS STRING * 1%@NL@% PointSize AS INTEGER ' Fonts point size%@NL@% HorizRes AS INTEGER ' Horizontal resolution of font%@NL@% VertRes AS INTEGER ' Vertical resolution of font%@NL@% ScrnMode AS INTEGER ' Screen mode%@NL@% Height AS INTEGER ' Pixel height of font%@NL@% %@NL@% Best AS INTEGER ' "Best" flag (true/false)%@NL@% %@NL@% RegNum AS INTEGER ' Number of font in registered list%@NL@% %@NL@% InMemory AS INTEGER ' Whether font is in memory (true/false)%@NL@% HdrSeg AS INTEGER ' Segment of font in memory%@NL@% HdrOff AS INTEGER ' Offset of font in segment%@NL@% DataSeg AS INTEGER ' Segment of data in memory%@NL@% DataOff AS INTEGER ' Offset of data in segment%@NL@% END TYPE%@NL@% %@NL@% %@AB@%' *********************************************************************%@AE@%%@NL@% %@AB@%' Routine Declarations:%@AE@%%@NL@% %@NL@% DECLARE SUB flSetFontErr (ErrNum AS INTEGER)%@NL@% DECLARE SUB flClearFontErr ()%@NL@% DECLARE SUB flRegisterFont (FileName$, FileNum%)%@NL@% DECLARE SUB flReadFont (I%)%@NL@% DECLARE SUB flSizeFontBuffer (NFonts%)%@NL@% DECLARE SUB flInitSpec (Spec AS ANY)%@NL@% DECLARE SUB flClearFontStatus ()%@NL@% DECLARE SUB flGetCurrentScrnSize (XPixels%, YPixels%)%@NL@% DECLARE SUB flGetBASICScrnSize (ScrnMode%, XPixels%, YPixels%)%@NL@% DECLARE SUB flInitMask ()%@NL@% DECLARE SUB flPSET (X%, Y%, Colr%)%@NL@% DECLARE SUB flChkMax ()%@NL@% %@NL@% DECLARE FUNCTION flGetFonts! (NFonts%)%@NL@% DECLARE FUNCTION flMatchFont! (FSpec AS ANY)%@NL@% DECLARE FUNCTION flGetNum! (Txt$, ChPos%, Default!, ErrV!)%@NL@% DECLARE FUNCTION flGetNextSpec! (SpecTxt$, ChPos%, Spec AS ANY)%@NL@% DECLARE FUNCTION flDoNextResource! (Align%, FileName$, FileNum%)%@NL@% DECLARE FUNCTION flOutGChar% (X%, Y%, ChVal%)%@NL@% %@NL@% %@AB@%' -- Assembly language routines%@AE@%%@NL@% DECLARE SUB flMovMem ALIAS "fl_MovMem" (SEG dest AS ANY, BYVAL SrcSeg AS INTEGER, BYVAL SrcOffset AS INTEGER, BYVAL Count AS INTEGER)%@NL@% DECLARE FUNCTION flANSI% ALIAS "fl_ansi" (BYVAL I%)%@NL@% %@NL@% DECLARE SUB flSetBltDir ALIAS "fl_SetBltDir" (BYVAL XPixInc%, BYVAL YPixInc%, BYVAL XRowInc%, BYVAL YRowInc%)%@NL@% DECLARE SUB flSetBltColor ALIAS "fl_SetBltColor" (BYVAL CharColor%)%@NL@% DECLARE SUB flSetBltParams ALIAS "fl_SetBltParams" (BYVAL HdrLen%, BYVAL CharHgt%, BYVAL FirstChar%, BYVAL LastChar%, BYVAL DefaultChar%)%@NL@% DECLARE FUNCTION flbltchar% ALIAS "fl_BltChar" (BYVAL FASeg%, BYVAL FAOffset%, BYVAL Char%, BYVAL X%, BYVAL Y%)%@NL@% %@NL@% %@AB@%' *********************************************************************%@AE@%%@NL@% %@AB@%' Variable Definitions:%@AE@%%@NL@% %@NL@% %@AB@%' The following arrays hold font headers and font data as fonts are%@AE@%%@NL@% %@AB@%' registered and loaded. They are dynamically allocated so they can be%@AE@%%@NL@% %@AB@%' changed in size to accomodate the number of fonts a program will be%@AE@%%@NL@% %@AB@%' using:%@AE@%%@NL@% %@NL@% %@AB@%' $DYNAMIC%@AE@%%@NL@% %@NL@% %@AB@%' Array to hold header information for registered fonts:%@AE@%%@NL@% DIM SHARED FontHdrReg(1 TO 10) AS IFontInfo%@NL@% %@NL@% %@AB@%' Arrays to hold header information and registered font numbers%@AE@%%@NL@% %@AB@%' for loaded fonts:%@AE@%%@NL@% DIM SHARED FontHdrLoaded(1 TO 10) AS IFontInfo%@NL@% DIM SHARED FontLoadList(1 TO 10) AS INTEGER%@NL@% %@NL@% %@AB@%' Array to hold font data information:%@AE@%%@NL@% DIM SHARED FontData(1 TO 1) AS FontDataBlock%@NL@% %@NL@% %@AB@%' $STATIC%@AE@%%@NL@% %@NL@% %@AB@%' Structure holding global parameters:%@AE@%%@NL@% DIM SHARED FGP AS GlobalParams%@NL@% %@NL@% %@AB@%' Error handler for flChkMax so these arrays will be dimensioned%@AE@%%@NL@% %@AB@%' to 10 by default:%@AE@%%@NL@% SetMax:%@NL@% REDIM FontHdrLoaded(1 TO 10) AS IFontInfo%@NL@% REDIM FontHdrReg(1 TO 10) AS IFontInfo%@NL@% REDIM FontLoadList(1 TO 10) AS INTEGER%@NL@% RESUME%@NL@% %@NL@% %@AB@%' Error handler for out of memory error:%@AE@%%@NL@% MemErr:%@NL@% flSetFontErr cNoFontMem%@NL@% RESUME NEXT%@NL@% %@NL@% %@AB@%' Error handler for unexpected errors:%@AE@%%@NL@% UnexpectedErr:%@NL@% flSetFontErr cFLUnexpectedErr + ERR%@NL@% RESUME NEXT%@NL@% %@NL@% %@AB@%' File not found error: RegisterFonts%@AE@%%@NL@% NoFileErr:%@NL@% flSetFontErr cFileNotFound%@NL@% RESUME NEXT%@NL@% %@NL@% %@AB@%'=== flChkMax - Makes sure that max font settings are correct and%@AE@%%@NL@% %@AB@%' enforces default of 10 for max loaded and registered%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB flChkMax STATIC%@NL@% SHARED FontHdrLoaded() AS IFontInfo%@NL@% SHARED FontHdrReg() AS IFontInfo%@NL@% SHARED FGP AS GlobalParams%@NL@% %@NL@% %@AB@%' Make sure that GP.MaxLoaded and GP.MaxRegistered match array dimensions%@AE@%%@NL@% %@AB@%' this will only happen if user hasn't used SetMaxFonts and allows Fontlib%@AE@%%@NL@% %@AB@%' to set a default of 10 since that is what the arrays are first DIM'd%@AE@%%@NL@% %@AB@%' to:%@AE@%%@NL@% %@NL@% ON ERROR GOTO SetMax%@NL@% FGP.MaxLoaded = UBOUND(FontHdrLoaded)%@NL@% FGP.MaxRegistered = UBOUND(FontHdrReg)%@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== flClearFontErr - Sets the FontErr variable to 0%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB flClearFontErr STATIC%@NL@% %@NL@% FontErr = 0%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== flClearFontStatus - Clears the status field in the registered font list%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' none%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB flClearFontStatus STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% SHARED FontHdrReg() AS IFontInfo%@NL@% %@NL@% FOR I% = 1 TO FGP.TotalRegistered%@NL@% FontHdrReg(I%).Status = 0%@NL@% NEXT I%%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== flDoNextResource - Processes resource from resource table:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Align% - Alignment shift count for finding resource data%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' FileName$ - Name of font file (passed to routine that actually%@AE@%%@NL@% %@AB@%' registers resource entry)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' FileNum% - File number for reading%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Value:%@AE@%%@NL@% %@AB@%' The number of fonts actually registered%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION flDoNextResource (Align%, FileName$, FileNum%) STATIC%@NL@% DIM ResID AS ResType, Entry AS ResEntry%@NL@% %@NL@% %@AB@%' Get the first few bytes identifying the resource type and the number%@AE@%%@NL@% %@AB@%' of this type:%@AE@%%@NL@% GET FileNum%, , ResID%@NL@% %@NL@% %@AB@%' If this is not the last resource then process it:%@AE@%%@NL@% IF ResID.TypeID <> 0 THEN%@NL@% %@NL@% %@AB@% ' Loop through the entries of this resource and if an entry happens to be%@AE@%%@NL@% %@AB@% ' a font resource then register it. The file location must be saved%@AE@%%@NL@% %@AB@% ' for each entry in the resource table since the flRegisterFont%@AE@%%@NL@% %@AB@% ' routine may go to some other part of the file to read the resource:%@AE@%%@NL@% FOR ResourceEntry = 1 TO ResID.NumResource%@NL@% %@NL@% GET FileNum%, , Entry%@NL@% NextResLoc# = SEEK(FileNum%)%@NL@% IF ResID.TypeID = cFontResource THEN%@NL@% %@NL@% %@AB@% ' Seek to font information, register it, then seek back to%@AE@%%@NL@% %@AB@% ' the next resource table entry:%@AE@%%@NL@% SEEK FileNum%, Entry.AddrOffset * 2 ^ Align% + 1%@NL@% flRegisterFont FileName$, FileNum%%@NL@% SEEK FileNum%, NextResLoc#%@NL@% IF FontErr <> 0 THEN EXIT FUNCTION%@NL@% %@NL@% END IF%@NL@% %@NL@% NEXT ResourceEntry%@NL@% END IF%@NL@% %@NL@% %@AB@%' Return the current resource type so that RegisterFonts knows when the%@AE@%%@NL@% %@AB@%' last resource has been read:%@AE@%%@NL@% flDoNextResource = ResID.TypeID%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== flGetBASICScrnSize - Returns screen size for specified BASIC screen mode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ScrnMode% - BASIC screen mode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' XPixels% - Number of pixels in horizontal direction%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' YPixels% - Number of pixels in vertical direction%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB flGetBASICScrnSize (ScrnMode%, XPixels%, YPixels%) STATIC%@NL@% SELECT CASE ScrnMode%%@NL@% CASE 1: XPixels% = 320: YPixels% = 200%@NL@% CASE 2: XPixels% = 640: YPixels% = 200%@NL@% CASE 3: XPixels% = 720: YPixels% = 348%@NL@% CASE 4: XPixels% = 640: YPixels% = 400%@NL@% CASE 7: XPixels% = 320: YPixels% = 200%@NL@% CASE 8: XPixels% = 640: YPixels% = 200%@NL@% CASE 9: XPixels% = 640: YPixels% = 350%@NL@% CASE 10: XPixels% = 640: YPixels% = 350%@NL@% CASE 11: XPixels% = 640: YPixels% = 480%@NL@% CASE 12: XPixels% = 640: YPixels% = 480%@NL@% CASE 13: XPixels% = 320: YPixels% = 200%@NL@% CASE ELSE: XPixels% = 0: YPixels% = 0%@NL@% END SELECT%@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== flGetCurrentScrnSize - Returns screen size for current screen mode%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' XPixels% - Number of pixels in horizontal direction%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' YPixels% - Number of pixels in vertical direction%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB flGetCurrentScrnSize (XPixels%, YPixels%) STATIC%@NL@% DIM Regs AS RegType%@NL@% %@NL@% %@AB@%' Use DOS interrupt to get current video display mode:%@AE@%%@NL@% Regs.ax = &HF00%@NL@% CALL INTERRUPT(&H10, Regs, Regs)%@NL@% %@NL@% %@AB@%' Set screen size based on mode:%@AE@%%@NL@% SELECT CASE Regs.ax MOD 256%@NL@% CASE &H4: XPixels% = 320: YPixels% = 200%@NL@% CASE &H5: XPixels% = 320: YPixels% = 200%@NL@% CASE &H6: XPixels% = 640: YPixels% = 200%@NL@% CASE &H7: XPixels% = 720: YPixels% = 350%@NL@% CASE &H8: XPixels% = 720: YPixels% = 348 ' Hercules%@NL@% CASE &HD: XPixels% = 320: YPixels% = 200%@NL@% CASE &HE: XPixels% = 640: YPixels% = 200%@NL@% CASE &HF: XPixels% = 640: YPixels% = 350%@NL@% CASE &H10: XPixels% = 640: YPixels% = 350%@NL@% CASE &H11: XPixels% = 640: YPixels% = 480%@NL@% CASE &H12: XPixels% = 640: YPixels% = 480%@NL@% CASE &H13: XPixels% = 320: YPixels% = 200%@NL@% CASE &H40: XPixels% = 640: YPixels% = 400 ' Olivetti%@NL@% CASE ELSE: XPixels% = 0: YPixels = 0%@NL@% END SELECT%@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== flGetFonts - Gets fonts specified in FontLoadList%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' NFonts% - Number of fonts to load%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Number of fonts successfully loaded%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION flGetFonts (NFonts%) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% SHARED FontHdrReg() AS IFontInfo%@NL@% SHARED FontHdrLoaded() AS IFontInfo%@NL@% SHARED FontLoadList() AS INTEGER%@NL@% %@NL@% %@AB@%' Re-dimension font data buffer to fit all the fonts:%@AE@%%@NL@% flSizeFontBuffer (NFonts%)%@NL@% IF FontErr = cNoFontMem THEN EXIT FUNCTION%@NL@% %@NL@% %@AB@%' Clear the font status variables then load the fonts (the status variable%@AE@%%@NL@% %@AB@%' is used to record which ones have already been loaded so they aren't%@AE@%%@NL@% %@AB@%' loaded more than once):%@AE@%%@NL@% flClearFontStatus%@NL@% FOR Font% = 1 TO NFonts%%@NL@% FontNum% = FontLoadList(Font%)%@NL@% %@NL@% %@AB@% ' If font already loaded then just copy the already-filled-out header%@AE@%%@NL@% %@AB@% ' to the new slot:%@AE@%%@NL@% IF FontHdrReg(FontNum%).Status <> 0 THEN%@NL@% FontHdrLoaded(Font%) = FontHdrLoaded(FontHdrReg(FontNum%).Status)%@NL@% %@NL@% %@AB@% ' Otherwise, read the font and update status in registered version%@AE@%%@NL@% %@AB@% ' to point to the first slot it was loaded into (so we can go get%@AE@%%@NL@% %@AB@% ' an already-filled-out header from there):%@AE@%%@NL@% ELSE%@NL@% FontHdrLoaded(Font%) = FontHdrReg(FontNum%)%@NL@% %@NL@% %@AB@% ' Hold any existing errors:%@AE@%%@NL@% HoldErr% = FontErr%@NL@% flClearFontErr%@NL@% %@NL@% flReadFont Font%%@NL@% %@NL@% %@AB@% ' If there was an error in reading font, exit. Otherwise,%@AE@%%@NL@% %@AB@% ' reset the error to what it was before and continue:%@AE@%%@NL@% IF FontErr <> 0 THEN%@NL@% flGetFonts = FontNum% - 1%@NL@% EXIT FUNCTION%@NL@% ELSE%@NL@% flSetFontErr HoldErr%%@NL@% END IF%@NL@% %@NL@% FontHdrReg(FontNum%).Status = Font%%@NL@% END IF%@NL@% NEXT Font%%@NL@% %@NL@% flGetFonts = NFonts%%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== flGetNextSpec - Parses the next spec from the spec string%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' SpecTxt$ - String containing font specifications%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ChPos% - Current position in string (updated in this routine)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Spec - Structure to contain parsed values%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' 0 - Spec was found%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' 1 - No spec found%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' 2 - Invalid spec found%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION flGetNextSpec (SpecTxt$, ChPos%, Spec AS FontSpec) STATIC%@NL@% %@NL@% %@AB@%' Initialize some things:%@AE@%%@NL@% SpecErr = cFALSE%@NL@% SpecLen% = LEN(SpecTxt$)%@NL@% %@NL@% %@AB@%' If character pos starts past end of spec then we're done:%@AE@%%@NL@% IF ChPos% > SpecLen% THEN%@NL@% flGetNextSpec = 1%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% DO UNTIL ChPos% > SpecLen%%@NL@% %@NL@% Param$ = UCASE$(MID$(SpecTxt$, ChPos%, 1))%@NL@% ChPos% = ChPos% + 1%@NL@% %@NL@% SELECT CASE Param$%@NL@% %@NL@% %@AB@% ' Skip blanks:%@AE@%%@NL@% CASE " ":%@NL@% %@NL@% %@AB@% ' Font title:%@AE@%%@NL@% CASE "T":%@NL@% %@NL@% %@AB@% ' Scan for font title until blank or end of string:%@AE@%%@NL@% StartPos% = ChPos%%@NL@% DO UNTIL ChPos% > SpecLen%%@NL@% Char$ = MID$(SpecTxt$, ChPos%, 1)%@NL@% ChPos% = ChPos% + 1%@NL@% LOOP%@NL@% %@NL@% %@AB@% ' Extract the title:%@AE@%%@NL@% TitleLen% = ChPos% - StartPos%%@NL@% IF TitleLen% <= 0 THEN%@NL@% SpecErr = cTRUE%@NL@% ELSE%@NL@% Spec.FaceName = MID$(SpecTxt$, StartPos%, TitleLen%)%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Fixed or Proportional font:%@AE@%%@NL@% CASE "F", "P":%@NL@% Spec.Pitch = Param$%@NL@% %@NL@% %@AB@% ' Font Size (default to 12 points):%@AE@%%@NL@% CASE "S":%@NL@% Spec.PointSize = flGetNum(SpecTxt$, ChPos%, 12, SpecErr)%@NL@% %@NL@% %@AB@% ' Screen Mode:%@AE@%%@NL@% CASE "M":%@NL@% Spec.ScrnMode = flGetNum(SpecTxt$, ChPos%, -1, SpecErr)%@NL@% %@NL@% %@AB@% ' Pixel Height:%@AE@%%@NL@% CASE "H":%@NL@% Spec.Height = flGetNum(SpecTxt$, ChPos%, 0, SpecErr)%@NL@% %@NL@% %@AB@% ' Best fit:%@AE@%%@NL@% CASE "B":%@NL@% Spec.Best = cTRUE%@NL@% %@NL@% %@AB@% ' Registered font number:%@AE@%%@NL@% CASE "N":%@NL@% Spec.RegNum = flGetNum(SpecTxt$, ChPos%, 0, SpecErr)%@NL@% %@NL@% %@AB@% ' Font in memory:%@AE@%%@NL@% CASE "R":%@NL@% Spec.InMemory = cTRUE%@NL@% %@NL@% %@AB@% ' Spec separator:%@AE@%%@NL@% CASE "/":%@NL@% EXIT DO%@NL@% %@NL@% %@AB@% ' Anything else is an error:%@AE@%%@NL@% CASE ELSE:%@NL@% SpecErr = cTRUE%@NL@% ChPos% = ChPos% + 1%@NL@% END SELECT%@NL@% LOOP%@NL@% %@NL@% %@AB@%' Spec is parsed, make sure a valid screen mode has been specified and%@AE@%%@NL@% %@AB@%' adjust point sizes for 320x200 screens if necessary:%@AE@%%@NL@% IF Spec.PointSize <> 0 THEN%@NL@% %@NL@% %@AB@% ' Get screen size for specified mode (with "M" param) or current%@AE@%%@NL@% %@AB@% ' screen mode:%@AE@%%@NL@% IF Spec.ScrnMode < 0 THEN%@NL@% flGetCurrentScrnSize XPixels%, YPixels%%@NL@% ELSE%@NL@% flGetBASICScrnSize Spec.ScrnMode, XPixels%, YPixels%%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If this isn't a graphics mode then set an error and skip the rest:%@AE@%%@NL@% IF XPixels% = 0 THEN%@NL@% SpecErr = cTRUE%@NL@% Spec.PointSize = 0%@NL@% %@NL@% %@AB@% ' If this is a 320x200 screen mode adjust point sizes to the%@AE@%%@NL@% %@AB@% ' equivalent EGA font point sizes. Also set the horizontal%@AE@%%@NL@% %@AB@% ' a vertical resolutions to search for in fonts (horizontal is%@AE@%%@NL@% %@AB@% ' 96 for all modes, vertical varies):%@AE@%%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' Use a horizontal resolution of 96 for all screens:%@AE@%%@NL@% Spec.HorizRes = 96%@NL@% %@NL@% IF XPixels% = 320 THEN%@NL@% Spec.VertRes = 72%@NL@% %@NL@% %@AB@% ' In a 320x200 mode scale point sizes to their equivalent%@AE@%%@NL@% %@AB@% ' EGA fonts (special case 14 and 24 point fonts to map them%@AE@%%@NL@% %@AB@% ' to the closest EGA font otherwise multiply point size by%@AE@%%@NL@% %@AB@% ' 2/3:%@AE@%%@NL@% SELECT CASE Spec.PointSize%@NL@% CASE 14: Spec.PointSize = 10%@NL@% CASE 24: Spec.PointSize = 18%@NL@% CASE ELSE: Spec.PointSize = Spec.PointSize * 2 / 3%@NL@% END SELECT%@NL@% %@NL@% ELSE%@NL@% %@NL@% %@AB@% ' Other screen modes vary only in vertical resolution:%@AE@%%@NL@% SELECT CASE YPixels%%@NL@% CASE 200: Spec.VertRes = 48%@NL@% CASE 350: Spec.VertRes = 72%@NL@% CASE 480: Spec.VertRes = 96%@NL@% END SELECT%@NL@% END IF%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@%' If an error was found somewhere then pass it on and set-up to load%@AE@%%@NL@% %@AB@%' first font:%@AE@%%@NL@% IF SpecErr THEN%@NL@% flGetNextSpec = 2%@NL@% Spec.RegNum = 1%@NL@% ELSE%@NL@% flGetNextSpec = 0%@NL@% END IF%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== flGetNum - Parses number from string%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Txt$ - String from which to parse number%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ChPos% - Character position on which to start%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Default - Default value if number not found%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ErrV - Returns error as cTrue or cFalse%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Returns value found or default%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Notes:%@AE@%%@NL@% %@AB@%' Simple state machine:%@AE@%%@NL@% %@AB@%' state 0: Looking for first char%@AE@%%@NL@% %@AB@%' state 1: Found start (+, -, or digit)%@AE@%%@NL@% %@AB@%' state 2: Done%@AE@%%@NL@% %@AB@%' state 3: Error%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION flGetNum (Txt$, ChPos%, Default, ErrV) STATIC%@NL@% %@NL@% %@AB@%' Start in state 0%@AE@%%@NL@% State = 0%@NL@% %@NL@% %@AB@%' Loop until done%@AE@%%@NL@% DO%@NL@% Char$ = MID$(Txt$, ChPos%, 1)%@NL@% SELECT CASE Char$%@NL@% %@NL@% %@AB@% ' Plus and minus are only OK at the beginning:%@AE@%%@NL@% CASE "+", "-":%@NL@% SELECT CASE State%@NL@% CASE 0: Start% = ChPos%: State = 1%@NL@% CASE ELSE: State = 3%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Digits are OK at the beginning of after plus and minus:%@AE@%%@NL@% CASE "0" TO "9":%@NL@% SELECT CASE State%@NL@% CASE 0: Start% = ChPos%: State = 1%@NL@% CASE ELSE:%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Spaces are skipped:%@AE@%%@NL@% CASE " ":%@NL@% %@NL@% %@AB@% ' Anything else is an error at the beginning or marks the end:%@AE@%%@NL@% CASE ELSE:%@NL@% SELECT CASE State%@NL@% CASE 0: State = 3%@NL@% CASE 1: State = 2%@NL@% END SELECT%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Go to next character:%@AE@%%@NL@% ChPos% = ChPos% + 1%@NL@% LOOP UNTIL State = 2 OR State = 3%@NL@% %@NL@% %@AB@%' Scanning is complete; adjust ChPos% to mark last character processed:%@AE@%%@NL@% ChPos% = ChPos% - 1%@NL@% %@NL@% %@AB@%' If error then set default number:%@AE@%%@NL@% IF State = 3 THEN%@NL@% flGetNum = Default%@NL@% ErrV = cTRUE%@NL@% %@NL@% %@AB@%' Otherwise, extract number and get its value:%@AE@%%@NL@% ELSE%@NL@% EndPos% = ChPos% - 1%@NL@% flGetNum = VAL(MID$(Txt$, Start%, EndPos%))%@NL@% ErrV = cFALSE%@NL@% END IF%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== flInitSpec - Initializes font specification structure%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Spec - FontSpec variable to initialize%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB flInitSpec (Spec AS FontSpec) STATIC%@NL@% %@NL@% Spec.FaceName = ""%@NL@% Spec.Pitch = ""%@NL@% Spec.PointSize = 0%@NL@% Spec.ScrnMode = -1%@NL@% Spec.Height = 0%@NL@% Spec.Best = cFALSE%@NL@% Spec.RegNum = 0%@NL@% Spec.InMemory = cFALSE%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== flMatchFont - Finds first registered font that matches FontSpec%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' FSpec - FontSpec variable containing specification to match%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Number of registered font matched, -1 if no match.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION flMatchFont (FSpec AS FontSpec) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% SHARED FontHdrReg() AS IFontInfo%@NL@% %@NL@% %@AB@%' Match a specific registered font:%@AE@%%@NL@% IF FSpec.RegNum > 0 AND FSpec.RegNum <= FGP.TotalRegistered THEN%@NL@% flMatchFont = FSpec.RegNum%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% %@AB@%' If this is an invalid spec. then no fonts matched:%@AE@%%@NL@% IF FontErr <> 0 THEN%@NL@% flMatchFont = -1%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% %@AB@%' Scan font for first one that matches the rest of the specs:%@AE@%%@NL@% SelectedFont% = -1%@NL@% BestSizeDiff = 3.402823E+38%@NL@% BestFontNum% = -1%@NL@% FOR FontNum% = 1 TO FGP.TotalRegistered%@NL@% %@NL@% %@AB@% ' Match a font from memory:%@AE@%%@NL@% MemOK% = cTRUE%@NL@% IF FSpec.InMemory AND FontHdrReg(FontNum%).FontSource <> cMemFont THEN%@NL@% MemOK% = cFALSE%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Match name:%@AE@%%@NL@% IF FSpec.FaceName = FontHdrReg(FontNum%).FaceName OR LTRIM$(FSpec.FaceName) = "" THEN%@NL@% NameOK% = cTRUE%@NL@% ELSE%@NL@% NameOK% = cFALSE%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Match pitch (fixed or proportional):%@AE@%%@NL@% Pitch$ = "F"%@NL@% IF FontHdrReg(FontNum%).FontHeader.dfPixWidth = 0 THEN Pitch$ = "P"%@NL@% IF FSpec.Pitch = Pitch$ OR FSpec.Pitch = " " THEN%@NL@% PitchOK% = cTRUE%@NL@% ELSE%@NL@% PitchOK% = cFALSE%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Match font size (if neither point or pixel size specified then%@AE@%%@NL@% %@AB@% ' this font is OK):%@AE@%%@NL@% IF FSpec.PointSize = 0 AND FSpec.Height = 0 THEN%@NL@% SizeOK% = cTRUE%@NL@% %@NL@% %@AB@% ' Otherwise, if point size specified (note that point size overrides%@AE@%%@NL@% %@AB@% ' the pixel height if they were both specified)...%@AE@%%@NL@% ELSEIF FSpec.PointSize <> 0 THEN%@NL@% %@NL@% %@AB@% ' Make sure the font resolution matches the screen resolution%@AE@%%@NL@% %@AB@% ' (pass over this font if not):%@AE@%%@NL@% IF FSpec.HorizRes <> FontHdrReg(FontNum%).FontHeader.dfHorizRes THEN%@NL@% SizeOK% = cFALSE%@NL@% ELSEIF FSpec.VertRes <> FontHdrReg(FontNum%).FontHeader.dfVertRes THEN%@NL@% SizeOK% = cFALSE%@NL@% %@NL@% %@AB@% ' Font has made it past the resolution check, now try to match size:%@AE@%%@NL@% ELSE%@NL@% SizeDiff = ABS(FSpec.PointSize - FontHdrReg(FontNum%).FontHeader.dfPoints)%@NL@% IF SizeDiff = 0 THEN%@NL@% SizeOK% = cTRUE%@NL@% ELSE%@NL@% SizeOK% = cFALSE%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@NL@% %@AB@% ' Now, the case where height was specified and not point size:%@AE@%%@NL@% ELSEIF FSpec.Height <> 0 THEN%@NL@% SizeDiff = ABS(FSpec.Height - FontHdrReg(FontNum%).FontHeader.dfPixHeight)%@NL@% IF SizeDiff = 0 THEN%@NL@% SizeOK% = cTRUE%@NL@% ELSE%@NL@% SizeOK% = cFALSE%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Do record keeping if best-fit was specified:%@AE@%%@NL@% IF NOT SizeOK% AND PitchOK% AND FSpec.Best AND SizeDiff < BestSizeDiff THEN%@NL@% BestSizeDiff = SizeDiff%@NL@% BestFontNum% = FontNum%%@NL@% END IF%@NL@% %@NL@% %@AB@% ' See if this font is OK:%@AE@%%@NL@% IF MemOK% AND NameOK% AND PitchOK% AND SizeOK% THEN%@NL@% SelectedFont% = FontNum%%@NL@% EXIT FOR%@NL@% END IF%@NL@% NEXT FontNum%%@NL@% %@NL@% %@AB@%' If no font was matched and best-fit was specified then select the%@AE@%%@NL@% %@AB@%' best font:%@AE@%%@NL@% IF SelectedFont% < 0 AND FSpec.Best THEN SelectedFont% = BestFontNum%%@NL@% %@NL@% %@AB@%' Return the font matched:%@AE@%%@NL@% flMatchFont = SelectedFont%%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== flReadFont - Reads font data and sets up font header%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' I% - Slot in loaded fonts to process%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB flReadFont (I%) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% SHARED FontHdrLoaded() AS IFontInfo%@NL@% SHARED FontData() AS FontDataBlock%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' If memory font then it's already in memory:%@AE@%%@NL@% IF FontHdrLoaded(I%).FontSource = cMemFont THEN%@NL@% EXIT SUB%@NL@% %@NL@% %@AB@%' For a font from a file, read it in:%@AE@%%@NL@% ELSE%@NL@% DataSize# = FontHdrLoaded(I%).FontHeader.dfSize - cSizeFontHeader%@NL@% NumBlocks% = -INT(-DataSize# / cFontBlockSize)%@NL@% FontHdrLoaded(I%).DataSeg = FGP.NextDataBlock%@NL@% %@NL@% %@AB@% ' Get next available file number and open file:%@AE@%%@NL@% FileNum% = FREEFILE%@NL@% OPEN FontHdrLoaded(I%).FileName FOR BINARY AS FileNum%%@NL@% %@NL@% %@AB@% ' Read blocks from the font file:%@AE@%%@NL@% DataLoc# = FontHdrLoaded(I%).FileLoc + cSizeFontHeader%@NL@% SEEK FileNum%, DataLoc#%@NL@% FOR BlockNum% = 0 TO NumBlocks% - 1%@NL@% GET FileNum%, , FontData(FGP.NextDataBlock + BlockNum%)%@NL@% NEXT BlockNum%%@NL@% %@NL@% %@AB@% ' Close the file:%@AE@%%@NL@% CLOSE FileNum%%@NL@% %@NL@% %@AB@% ' Update the next data block pointer:%@AE@%%@NL@% FGP.NextDataBlock = FGP.NextDataBlock + NumBlocks%%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== flRegisterFont - Actually registers a font resource:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' FileName$ - Name of font file (passed to routine that actually%@AE@%%@NL@% %@AB@%' registers resource entry)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' FileNum% - File number for reading%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB flRegisterFont (FileName$, FileNum%) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% SHARED FontHdrReg() AS IFontInfo%@NL@% %@NL@% DIM Byte AS STRING * 1, FontHeader AS WFHeader%@NL@% %@NL@% %@AB@%' Read the font header:%@AE@%%@NL@% FontLoc# = SEEK(FileNum%)%@NL@% GET FileNum%, , FontHeader%@NL@% %@NL@% %@AB@%' Only register vector fonts:%@AE@%%@NL@% IF FontHeader.dfType AND &H1 <> cBitMapType THEN EXIT SUB%@NL@% %@NL@% %@AB@%' See that we're still within MaxRegistered limits:%@AE@%%@NL@% IF FGP.TotalRegistered >= FGP.MaxRegistered THEN%@NL@% flSetFontErr cTooManyFonts%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@%' Go to next "registered" font slot:%@AE@%%@NL@% FGP.TotalRegistered = FGP.TotalRegistered + 1%@NL@% %@NL@% %@AB@%' Set font source and save the header and file location:%@AE@%%@NL@% FontHdrReg(FGP.TotalRegistered).FontSource = cFileFont%@NL@% FontHdrReg(FGP.TotalRegistered).FontHeader = FontHeader%@NL@% FontHdrReg(FGP.TotalRegistered).FileLoc = FontLoc#%@NL@% %@NL@% %@AB@%' Get the face name (scan characters until zero byte):%@AE@%%@NL@% SEEK FileNum%, FontLoc# + FontHeader.dfFace%@NL@% FaceName$ = ""%@NL@% FOR Char% = 0 TO cMaxFaceName - 1%@NL@% GET FileNum%, , Byte%@NL@% IF ASC(Byte) = 0 THEN EXIT FOR%@NL@% FaceName$ = FaceName$ + Byte%@NL@% NEXT Char%%@NL@% FontHdrReg(FGP.TotalRegistered).FaceName = FaceName$%@NL@% %@NL@% %@AB@%' Finally, save the file name:%@AE@%%@NL@% FontHdrReg(FGP.TotalRegistered).FileName = FileName$%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== flSetFontErr - Sets the FontErr variable to an error value:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' ErrNum - The error number to set FontErr variable to%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB flSetFontErr (ErrNum AS INTEGER) STATIC%@NL@% %@NL@% FontErr = ErrNum%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== flSizeFontBuffer - Calculate the FontBuffer size required for all fonts%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' NFonts% - Number of font to be loaded%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Notes:%@AE@%%@NL@% %@AB@%' The use of -INT(-N) in the following code rounds N to the next%@AE@%%@NL@% %@AB@%' larger integer%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB flSizeFontBuffer (NFonts%) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% SHARED FontHdrReg() AS IFontInfo%@NL@% SHARED FontLoadList() AS INTEGER%@NL@% SHARED FontData() AS FontDataBlock%@NL@% %@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% IF NFonts% = 0 THEN EXIT SUB%@NL@% %@NL@% %@AB@%' Clear font status variables so we know what has been processed:%@AE@%%@NL@% flClearFontStatus%@NL@% %@NL@% %@AB@%' Add sizes of all unique fonts together to get total size (each font%@AE@%%@NL@% %@AB@%' begins on a new font block so the size of each font is calculated in%@AE@%%@NL@% %@AB@%' terms of the number of font blocks it will take up):%@AE@%%@NL@% Size = 0%@NL@% FOR I% = 1 TO NFonts%%@NL@% FontNum% = FontLoadList(I%)%@NL@% IF FontHdrReg(FontNum%).Status = 0 THEN%@NL@% FontSize = FontHdrReg(FontNum%).FontHeader.dfSize - cSizeFontHeader%@NL@% Size = Size - INT(-FontSize / cFontBlockSize)%@NL@% FontHdrReg(FontNum%).Status = 1%@NL@% END IF%@NL@% NEXT I%%@NL@% %@NL@% %@AB@%' Dimension the FontData array to hold everything:%@AE@%%@NL@% ON ERROR GOTO MemErr%@NL@% REDIM FontData(1 TO Size) AS FontDataBlock%@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Set the next font block to the start for when flReadFont begins%@AE@%%@NL@% %@AB@%' putting data in the font buffer:%@AE@%%@NL@% FGP.NextDataBlock = 1%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== GetFontInfo - Returns useful information about current font%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' FI - FontInfo type variable to receive info%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB GetFontInfo (FI AS FontInfo) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% SHARED FontHdrLoaded() AS IFontInfo%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding font errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% %@AB@%' Check that some fonts are loaded:%@AE@%%@NL@% IF FGP.TotalLoaded <= 0 THEN%@NL@% flSetFontErr cNoFonts%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@%' All OK, assign values from internal font header:%@AE@%%@NL@% FI.FontNum = FGP.CurrentFont%@NL@% FI.Ascent = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfAscent%@NL@% FI.Points = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfPoints%@NL@% FI.PixWidth = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfPixWidth%@NL@% FI.PixHeight = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfPixHeight%@NL@% FI.Leading = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfInternalLeading%@NL@% FI.MaxWidth = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfMaxWidth%@NL@% FI.AvgWidth = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfAvgWidth%@NL@% FI.FileName = FontHdrLoaded(FGP.CurrentFont).FileName%@NL@% FI.FaceName = FontHdrLoaded(FGP.CurrentFont).FaceName%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== GetGTextLen - Returns bit length of string%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Text$ - String for which to return length%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' -1 - Error (No fonts loaded, probably)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' >=0 - Length of string%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION GetGTextLen% (Text$) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% SHARED FontHdrLoaded() AS IFontInfo%@NL@% SHARED FontData() AS FontDataBlock%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding font errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% %@AB@%' Make sure some fonts are loaded:%@AE@%%@NL@% IF FGP.TotalLoaded <= 0 THEN%@NL@% flSetFontErr cNoFonts%@NL@% GetGTextLen = -1%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% %@AB@%' Assume this is a memory font (may override this later):%@AE@%%@NL@% CharTblPtr% = FontHdrLoaded(FGP.CurrentFont).DataOffset%@NL@% CharTblSeg% = FontHdrLoaded(FGP.CurrentFont).DataSeg%@NL@% %@NL@% %@AB@%' Index into font data array:%@AE@%%@NL@% CharTable% = FontHdrLoaded(FGP.CurrentFont).DataSeg%@NL@% %@NL@% %@AB@%' Add together the character lengths from the character table:%@AE@%%@NL@% TextLen% = 0%@NL@% FOR I% = 1 TO LEN(Text$)%@NL@% %@NL@% %@AB@% ' Get character code and translate to Ansi if IBM char set is specified:%@AE@%%@NL@% ChVal% = ASC(MID$(Text$, I%, 1))%@NL@% IF FGP.CharSet = cIBMChars THEN ChVal% = flANSI(ChVal%)%@NL@% %@NL@% %@AB@% ' Convert to default char if out of range:%@AE@%%@NL@% IF ChVal% < FGP.FChar OR ChVal% > FGP.LChar THEN ChVal% = FGP.DChar%%@NL@% %@NL@% %@AB@% ' Offset into character table for length word:%@AE@%%@NL@% CharOffset% = (ChVal% - FGP.FChar) * 4%@NL@% %@NL@% %@AB@% ' Peek the data and add it to the text length:%@AE@%%@NL@% IF FontHdrLoaded(FGP.CurrentFont).FontSource = cFileFont THEN%@NL@% CharTblPtr% = VARPTR(FontData(CharTable%))%@NL@% CharTblSeg% = VARSEG(FontData(CharTable%))%@NL@% END IF%@NL@% DEF SEG = CharTblSeg%%@NL@% CharLen% = PEEK(CharTblPtr% + CharOffset%) + PEEK(CharTblPtr% + CharOffset% + 1) * 256%@NL@% TextLen% = TextLen% + CharLen%%@NL@% NEXT I%%@NL@% %@NL@% GetGTextLen = TextLen%%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== GetMaxFonts - Gets the maximum number of fonts that can be registered%@AE@%%@NL@% %@AB@%' and loaded by the font library:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Registered - The maximum number of fonts that can be registered%@AE@%%@NL@% %@AB@%' by the font library%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Loaded - The maximum number of fonts that can be loaded by%@AE@%%@NL@% %@AB@%' by the font library%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB GetMaxFonts (Registered AS INTEGER, Loaded AS INTEGER)%@NL@% SHARED FGP AS GlobalParams%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding font errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% %@AB@%' If SetMaxFonts hasn't been called then make sure the default is%@AE@%%@NL@% %@AB@%' correct:%@AE@%%@NL@% flChkMax%@NL@% %@NL@% %@AB@%' Simply return the values of the internal variables for maximum%@AE@%%@NL@% %@AB@%' fonts registered and loaded:%@AE@%%@NL@% Registered = FGP.MaxRegistered%@NL@% Loaded = FGP.MaxLoaded%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== GetFontInfo - Returns useful information about current font%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Font - Font number (in list of registered fonts) on which to get%@AE@%%@NL@% %@AB@%' information%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' FI - FontInfo type variable to receive info%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB GetRFontInfo (Font AS INTEGER, FI AS FontInfo) STATIC%@NL@% SHARED FontHdrReg() AS IFontInfo%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding font errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% %@AB@%' See that they've specified a valid font:%@AE@%%@NL@% IF Font < 0 OR Font > FGP.TotalRegistered THEN%@NL@% flSetFontErr cBadFontNumber%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@%' All OK, assign values from internal font header:%@AE@%%@NL@% FI.FontNum = Font%@NL@% FI.Ascent = FontHdrReg(Font).FontHeader.dfAscent%@NL@% FI.Points = FontHdrReg(Font).FontHeader.dfPoints%@NL@% FI.PixWidth = FontHdrReg(Font).FontHeader.dfPixWidth%@NL@% FI.PixHeight = FontHdrReg(Font).FontHeader.dfPixHeight%@NL@% FI.Leading = FontHdrReg(Font).FontHeader.dfInternalLeading%@NL@% FI.MaxWidth = FontHdrReg(Font).FontHeader.dfMaxWidth%@NL@% FI.AvgWidth = FontHdrReg(Font).FontHeader.dfAvgWidth%@NL@% FI.FileName = FontHdrReg(Font).FileName%@NL@% FI.FaceName = FontHdrReg(Font).FaceName%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== GetTotalFonts - Gets the total number of fonts that currently registered%@AE@%%@NL@% %@AB@%' and loaded by the font library:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Registered - The total number of fonts registered by the font%@AE@%%@NL@% %@AB@%' library%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Loaded - The total number of fonts loaded by the font library%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB GetTotalFonts (Registered AS INTEGER, Loaded AS INTEGER)%@NL@% SHARED FGP AS GlobalParams%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding font errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% %@AB@%' Simply return the values of internal variables:%@AE@%%@NL@% Registered = FGP.TotalRegistered%@NL@% Loaded = FGP.TotalLoaded%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== GTextWindow - Communicates the current WINDOW to fontlib%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' X1 - Minimum X value%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Y1 - Minimum Y value%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' X2 - Maximum X value%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Y2 - Maximum Y value%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Scrn% - cTRUE means that window Y values increase top to bottom%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Remarks:%@AE@%%@NL@% %@AB@%' Calling this with X1=X2 or Y1=Y2 will clear the current%@AE@%%@NL@% %@AB@%' window.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB GTextWindow (X1 AS SINGLE, Y1 AS SINGLE, X2 AS SINGLE, Y2 AS SINGLE, Scrn%)%@NL@% SHARED FGP AS GlobalParams%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding font errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% %@AB@%' Save the window values in global variable:%@AE@%%@NL@% FGP.WX1 = X1%@NL@% FGP.WY1 = Y1%@NL@% FGP.WX2 = X2%@NL@% FGP.WY2 = Y2%@NL@% FGP.WScrn = Scrn%%@NL@% %@NL@% %@AB@%' If window is valid then flag it as set:%@AE@%%@NL@% FGP.WindowSet = ((X2 - X1) <> 0) AND ((Y2 - Y1) <> 0)%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== LoadFont - Loads one or more fonts according to specification string%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' SpecTxt$ - String containing parameters specifying one or more%@AE@%%@NL@% %@AB@%' fonts to load (see notes below)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' The number of fonts loaded%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Notes:%@AE@%%@NL@% %@AB@%' A spec. can contain the following parameters in any order.%@AE@%%@NL@% %@AB@%' Parameters are each one character immediately followed by a value%@AE@%%@NL@% %@AB@%' if called for. Multiple specifications may be entered separated%@AE@%%@NL@% %@AB@%' by slash (/) characters. Loadfont will search for the FIRST font in%@AE@%%@NL@% %@AB@%' the list of registered fonts that matches each spec. and load it. If%@AE@%%@NL@% %@AB@%' no font matches a specification registered font number one will be%@AE@%%@NL@% %@AB@%' used. If a given font is selected by more than one spec in the list%@AE@%%@NL@% %@AB@%' it will only be loaded once. When this routine is called all%@AE@%%@NL@% %@AB@%' previous fonts will be discarded:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' T - followed by a blank-terminated name loads font by%@AE@%%@NL@% %@AB@%' specified name%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' F - No value. Selects only fixed pitch fonts%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' P - No value. Selects only proportional fonts%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' S - Followed by number specifies desired point size%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' M - Followed by number specifies the screen mode font will be%@AE@%%@NL@% %@AB@%' used on. This is used in conjunction with the "S" parameter%@AE@%%@NL@% %@AB@%' above to select appropriately sized font.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' H - Followed by number specifies the pixel height of%@AE@%%@NL@% %@AB@%' font to select. "S" overrides this.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' N - Followed by number selects specific font number%@AE@%%@NL@% %@AB@%' from the list of currently registered fonts.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' R - Selects font stored in RAM memory%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION LoadFont% (SpecTxt$) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% DIM FSpec AS FontSpec%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding errors and check for valid max limits:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% flChkMax%@NL@% %@NL@% %@AB@%' Make sure there's room to load a font:%@AE@%%@NL@% IF FGP.TotalLoaded >= FGP.MaxLoaded THEN%@NL@% flSetFontErr cTooManyFonts%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% %@AB@%' Make sure there are some registered fonts to look through:%@AE@%%@NL@% IF FGP.TotalRegistered <= 0 THEN%@NL@% flSetFontErr cNoFonts%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% %@AB@%' Process each spec in the spec string:%@AE@%%@NL@% Slot% = 1%@NL@% ChPos% = 1%@NL@% DO UNTIL Slot% > FGP.MaxLoaded%@NL@% %@NL@% %@AB@% ' Initialize the spec structure:%@AE@%%@NL@% flInitSpec FSpec%@NL@% %@NL@% %@AB@% ' Get next spec from string (Found will be false if no spec found):%@AE@%%@NL@% SpecStatus% = flGetNextSpec(SpecTxt$, ChPos%, FSpec)%@NL@% SELECT CASE SpecStatus%%@NL@% CASE 0:%@NL@% CASE 1: EXIT DO%@NL@% CASE 2: flSetFontErr cBadFontSpec%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Try to match font. Set font to one if none match:%@AE@%%@NL@% FontNum% = flMatchFont(FSpec)%@NL@% IF FontNum% < 1 THEN%@NL@% flSetFontErr cFontNotFound%@NL@% FontNum% = 1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Record font in font load list:%@AE@%%@NL@% FontLoadList(Slot%) = FontNum%%@NL@% Slot% = Slot% + 1%@NL@% LOOP%@NL@% %@NL@% %@AB@%' Now actually get the fonts in the load list:%@AE@%%@NL@% FGP.TotalLoaded = flGetFonts(Slot% - 1)%@NL@% FGP.CurrentFont = 1%@NL@% %@NL@% %@AB@%' Select the first font by default (pass outstanding font errors around%@AE@%%@NL@% %@AB@%' it):%@AE@%%@NL@% HoldErr% = FontErr%@NL@% SelectFont cDefaultFont%@NL@% IF HoldErr% <> 0 THEN flSetFontErr HoldErr%%@NL@% %@NL@% LoadFont = FGP.TotalLoaded%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== OutGText - Outputs graphics text to the screen%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' X - X location of upper left of char box%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Y - Y location of upper left of char box%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Text$ - Text string to output%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Length of text output, Values of X and Y are updated%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION OutGText% (X AS SINGLE, Y AS SINGLE, Text$) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% SHARED FontHdrLoaded() AS IFontInfo%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding font errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% %@AB@%' Make sure fonts are loaded:%@AE@%%@NL@% IF FGP.TotalLoaded <= 0 THEN%@NL@% flSetFontErr cNoFonts%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% IF NOT FGP.CharColorInit THEN SetGTextColor cDefaultColor%@NL@% IF NOT FGP.CharDirInit THEN SetGTextDir cDefaultDir%@NL@% %@NL@% %@AB@%' Make sure a graphic mode is set:%@AE@%%@NL@% flGetCurrentScrnSize XP%, YP%%@NL@% IF XP% = 0 THEN EXIT FUNCTION%@NL@% %@NL@% %@AB@%' Save input location to working variables and erase any window setting:%@AE@%%@NL@% IX% = PMAP(X, 0)%@NL@% IY% = PMAP(Y, 1)%@NL@% WINDOW%@NL@% %@NL@% %@AB@%' Map chars to valid ones and output them adding their lengths:%@AE@%%@NL@% TextLen% = 0%@NL@% FOR Char% = 1 TO LEN(Text$)%@NL@% ChVal% = ASC(MID$(Text$, Char%, 1))%@NL@% IF FGP.CharSet = cIBMChars THEN ChVal% = flANSI(ChVal%)%@NL@% %@NL@% IF FGP.FontSource = cFileFont THEN%@NL@% BitMapPtr% = VARPTR(FontData(FGP.DSeg))%@NL@% BitMapSeg% = VARSEG(FontData(FGP.DSeg))%@NL@% ELSE%@NL@% BitMapPtr% = FGP.DOffset%@NL@% BitMapSeg% = FGP.DSeg%@NL@% END IF%@NL@% %@NL@% CharLen% = flbltchar%(BitMapSeg%, BitMapPtr%, ChVal%, IX%, IY%)%@NL@% %@NL@% IX% = IX% + FGP.XPixInc * CharLen%%@NL@% IY% = IY% + FGP.YPixInc * CharLen%%@NL@% %@NL@% TextLen% = TextLen% + CharLen%%@NL@% NEXT Char%%@NL@% %@NL@% %@AB@%' Reset window:%@AE@%%@NL@% IF FGP.WindowSet THEN%@NL@% IF FGP.WScrn% THEN%@NL@% WINDOW SCREEN (FGP.WX1, FGP.WY1)-(FGP.WX2, FGP.WY2)%@NL@% ELSE%@NL@% WINDOW (FGP.WX1, FGP.WY1)-(FGP.WX2, FGP.WY2)%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@%' Update locations%@AE@%%@NL@% X = PMAP(IX%, 2)%@NL@% Y = PMAP(IY%, 3)%@NL@% %@NL@% %@AB@%' Return total character length:%@AE@%%@NL@% OutGText = TextLen%%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== RegisterFonts - Loads header information from font resources:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' FileName$ - Path name for font file to register%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Value:%@AE@%%@NL@% %@AB@%' The number of fonts actually registered%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Notes:%@AE@%%@NL@% %@AB@%' Offsets documented in Windows document assume the file's first%@AE@%%@NL@% %@AB@%' byte is byte 0 (zero) and GET assumes the first byte is byte 1 so%@AE@%%@NL@% %@AB@%' many GET locations are expressed in the following code as%@AE@%%@NL@% %@AB@%' a documented offset + 1.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION RegisterFonts% (FileName$) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% DIM Byte AS STRING * 1%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear errors and make sure things are initialized:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% flChkMax%@NL@% %@NL@% %@AB@%' Get next available file number:%@AE@%%@NL@% FileNum% = FREEFILE%@NL@% %@NL@% %@AB@%' Try to open the file for input first to make sure the file exists. This%@AE@%%@NL@% %@AB@%' is done to avoid creating a zero length file if the file doesn't exist.%@AE@%%@NL@% ON ERROR GOTO NoFileErr%@NL@% OPEN FileName$ FOR INPUT AS FileNum%%@NL@% ON ERROR GOTO UnexpectedErr%@NL@% IF FontErr <> 0 THEN%@NL@% RegisterFonts = 0%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% CLOSE FileNum%%@NL@% %@NL@% %@AB@%' File seems to exist, so open it in binary mode:%@AE@%%@NL@% OPEN FileName$ FOR BINARY ACCESS READ AS FileNum%%@NL@% %@NL@% %@AB@%' Get the byte that indicates whether this file has a new-style%@AE@%%@NL@% %@AB@%' header on it. If not, then error:%@AE@%%@NL@% GET FileNum%, &H18 + 1, Byte%@NL@% IF ASC(Byte) <> &H40 THEN%@NL@% flSetFontErr cBadFontFile%@NL@% CLOSE FileNum%%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% %@AB@%' Save the number of fonts currently registered for use later in%@AE@%%@NL@% %@AB@%' calculating the number of fonts registered by this call:%@AE@%%@NL@% OldTotal = FGP.TotalRegistered%@NL@% %@NL@% %@AB@%' Get the pointer to the new-style header:%@AE@%%@NL@% GET FileNum%, &H3C + 1, Word%%@NL@% NewHdr% = Word%%@NL@% %@NL@% %@AB@%' Get pointer to resource table:%@AE@%%@NL@% GET FileNum%, Word% + &H22 + 1, Word%%@NL@% ResourceEntry# = NewHdr% + Word% + 1%@NL@% %@NL@% %@AB@%' Get the alignment shift count from beginning of table:%@AE@%%@NL@% GET FileNum%, ResourceEntry#, Align%%@NL@% %@NL@% %@AB@%' Loop, registering font resources until they have run out:%@AE@%%@NL@% DO%@NL@% ResType% = flDoNextResource(Align%, FileName$, FileNum%)%@NL@% IF FontErr <> 0 THEN EXIT DO%@NL@% LOOP UNTIL ResType% = 0%@NL@% %@NL@% CLOSE FileNum%%@NL@% %@NL@% %@AB@%' Finally, return number of fonts actually registered:%@AE@%%@NL@% RegisterFonts = FGP.TotalRegistered - OldTotal%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== RegisterMemFont - Loads header information from a memory-resident font%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' FontSeg% - Segment address of font to register%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' FontOffset% - Offset address of font to register%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Value:%@AE@%%@NL@% %@AB@%' The number of fonts actually registered (0 or 1)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Notes:%@AE@%%@NL@% %@AB@%' Memory resident fonts cannot be stored in BASIC relocatable data%@AE@%%@NL@% %@AB@%' structures (like arrays or non-fixed strings).%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% FUNCTION RegisterMemFont% (FontSeg AS INTEGER, FontOffset AS INTEGER) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% SHARED FontHdrReg() AS IFontInfo%@NL@% DIM FontHeader AS WFHeader%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear error and check max limits:%@AE@%%@NL@% flClearFontErr%@NL@% flChkMax%@NL@% %@NL@% %@AB@%' Get the font header:%@AE@%%@NL@% flMovMem FontHeader, FontSeg, FontOffset, cSizeFontHeader%@NL@% %@NL@% %@AB@%' Only register vector fonts:%@AE@%%@NL@% IF FontHeader.dfType AND &H1 <> cBitMapType THEN%@NL@% flSetFontErr cBadFontType%@NL@% RegisterMemFont = 0%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% %@AB@%' See that we're still within MaxRegistered limits:%@AE@%%@NL@% IF FGP.TotalRegistered >= FGP.MaxRegistered THEN%@NL@% flSetFontErr cTooManyFonts%@NL@% RegisterMemFont = 0%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% %@AB@%' Go to next "registered" font slot:%@AE@%%@NL@% FGP.TotalRegistered = FGP.TotalRegistered + 1%@NL@% %@NL@% %@AB@%' Set font source and save the header:%@AE@%%@NL@% FontHdrReg(FGP.TotalRegistered).FontSource = cMemFont%@NL@% FontHdrReg(FGP.TotalRegistered).FontHeader = FontHeader%@NL@% %@NL@% %@AB@%' Set font location in memory:%@AE@%%@NL@% FontHdrReg(FGP.TotalRegistered).DataSeg = FontSeg%@NL@% FontHdrReg(FGP.TotalRegistered).DataOffset = FontOffset + cSizeFontHeader%@NL@% %@NL@% %@AB@%' Get the face name (scan characters until zero byte):%@AE@%%@NL@% FaceLoc% = FontOffset + FontHeader.dfFace%@NL@% FaceName$ = ""%@NL@% DEF SEG = FontSeg%@NL@% FOR Char% = 0 TO cMaxFaceName - 1%@NL@% Byte% = PEEK(FaceLoc% + Char%)%@NL@% IF Byte% = 0 THEN EXIT FOR%@NL@% FaceName$ = FaceName$ + CHR$(Byte%)%@NL@% NEXT Char%%@NL@% FontHdrReg(FGP.TotalRegistered).FaceName = FaceName$%@NL@% %@NL@% %@AB@%' Finally, return number of fonts actually registered:%@AE@%%@NL@% RegisterMemFont = 1%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=== SelectFont - Selects current font from among loaded fonts%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' FontNum% - Font number to select%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB SelectFont (FontNum AS INTEGER) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding font errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% %@AB@%' If no fonts are loaded then error:%@AE@%%@NL@% IF FGP.TotalLoaded <= 0 THEN%@NL@% flSetFontErr cNoFonts%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@%' Now, map the font number to an acceptable one and select it:%@AE@%%@NL@% IF FontNum <= 0 THEN%@NL@% FGP.CurrentFont = 1%@NL@% ELSE%@NL@% FGP.CurrentFont = (ABS(FontNum - 1) MOD (FGP.TotalLoaded)) + 1%@NL@% END IF%@NL@% %@NL@% %@AB@%' Get First, Last and Default character params from header:%@AE@%%@NL@% FGP.FChar = ASC(FontHdrLoaded(FGP.CurrentFont).FontHeader.dfFirstChar)%@NL@% FGP.LChar = ASC(FontHdrLoaded(FGP.CurrentFont).FontHeader.dfLastChar)%@NL@% FGP.DChar = ASC(FontHdrLoaded(FGP.CurrentFont).FontHeader.dfDefaultChar)%@NL@% FGP.CHeight = FontHdrLoaded(FGP.CurrentFont).FontHeader.dfPixHeight%@NL@% flSetBltParams cSizeFontHeader, FGP.CHeight, FGP.FChar, FGP.LChar, FGP.DChar%@NL@% %@NL@% %@AB@%' Set some other commonly used elements of font info:%@AE@%%@NL@% FGP.DSeg = FontHdrLoaded(FGP.CurrentFont).DataSeg%@NL@% FGP.DOffset = FontHdrLoaded(FGP.CurrentFont).DataOffset%@NL@% FGP.FontSource = FontHdrLoaded(FGP.CurrentFont).FontSource%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== SetGCharset - Specifies IBM or Windows char set%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Charset% - cIBMChars for IBM character mappings%@AE@%%@NL@% %@AB@%' cWindowsChars for Windows character mappings%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB SetGCharset (CharSet AS INTEGER) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding font errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% IF CharSet = cWindowsChars THEN%@NL@% FGP.CharSet = cWindowsChars%@NL@% ELSE%@NL@% FGP.CharSet = cIBMChars%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== SetGTextColor - Sets color for drawing characters%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' FColor - Color number%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB SetGTextColor (FColor AS INTEGER) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding font errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% FGP.CharColor = ABS(FColor)%@NL@% flSetBltColor FGP.CharColor%@NL@% FGP.CharColorInit = cTRUE%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== SetGTextDir - Sets character direction for OutGText%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Dir - Character direction:%@AE@%%@NL@% %@AB@%' 0 = Horizontal-Right%@AE@%%@NL@% %@AB@%' 1 = Vertical-Up%@AE@%%@NL@% %@AB@%' 2 = Horizontal-Left%@AE@%%@NL@% %@AB@%' 3 = Vertical-Down%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB SetGTextDir (Dir AS INTEGER) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding font errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% SELECT CASE Dir%@NL@% %@NL@% %@AB@% ' Vertical - up%@AE@%%@NL@% CASE 1: FGP.XPixInc% = 0%@NL@% FGP.YPixInc% = -1%@NL@% XRowInc% = 1%@NL@% YRowInc% = 0%@NL@% FGP.CharDir = 1%@NL@% %@NL@% %@AB@% ' Horizontal -left%@AE@%%@NL@% CASE 2: FGP.XPixInc% = -1%@NL@% FGP.YPixInc% = 0%@NL@% XRowInc% = 0%@NL@% YRowInc% = -1%@NL@% FGP.CharDir = 2%@NL@% %@NL@% %@AB@% ' Vertical - down%@AE@%%@NL@% CASE 3: FGP.XPixInc% = 0%@NL@% FGP.YPixInc% = 1%@NL@% XRowInc% = -1%@NL@% YRowInc% = 0%@NL@% FGP.CharDir = 3%@NL@% %@NL@% %@AB@% ' Horizontal - right%@AE@%%@NL@% CASE ELSE: FGP.XPixInc% = 1%@NL@% FGP.YPixInc% = 0%@NL@% XRowInc% = 0%@NL@% YRowInc% = 1%@NL@% FGP.CharDir = 0%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Call routine to set these increments in the char output routine%@AE@%%@NL@% flSetBltDir FGP.XPixInc%, FGP.YPixInc%, XRowInc%, YRowInc%%@NL@% FGP.CharDirInit = cTRUE%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== SetMaxFonts - Sets the maximum number of fonts that can be registered%@AE@%%@NL@% %@AB@%' and loaded by the font library:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' Registered - The maximum number of fonts that can be registered%@AE@%%@NL@% %@AB@%' by the font library%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Loaded - The maximum number of fonts that can be loaded by%@AE@%%@NL@% %@AB@%' by the font library%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return Values:%@AE@%%@NL@% %@AB@%' Sets error if values are not positive. Adjusts MaxReg and MaxLoad%@AE@%%@NL@% %@AB@%' internal values and resets the length of FontHdrReg and FontHdrLoad%@AE@%%@NL@% %@AB@%' arrays if the new value is different from previous one%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB SetMaxFonts (Registered AS INTEGER, Loaded AS INTEGER) STATIC%@NL@% SHARED FGP AS GlobalParams%@NL@% SHARED FontHdrReg() AS IFontInfo%@NL@% SHARED FontHdrLoaded() AS IFontInfo%@NL@% SHARED FontLoadList() AS INTEGER%@NL@% SHARED FontData() AS FontDataBlock%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% %@AB@%' Check to see that values are within range:%@AE@%%@NL@% IF Registered <= 0 OR Loaded <= 0 THEN%@NL@% flSetFontErr cBadFontLimit%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@%' Values are ostensibly OK. Reset values and redimension arrays:%@AE@%%@NL@% %@AB@%' Reset values for registered fonts:%@AE@%%@NL@% FGP.TotalRegistered = 0%@NL@% FGP.MaxRegistered = Registered%@NL@% %@NL@% ON ERROR GOTO MemErr%@NL@% REDIM FontHdrReg(1 TO FGP.MaxRegistered) AS IFontInfo%@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Reset values for loaded fonts:%@AE@%%@NL@% FGP.TotalLoaded = 0%@NL@% FGP.MaxLoaded = Loaded%@NL@% %@NL@% ON ERROR GOTO MemErr%@NL@% REDIM FontLoadList(1 TO FGP.MaxLoaded) AS INTEGER%@NL@% REDIM FontHdrLoaded(1 TO FGP.MaxLoaded) AS IFontInfo%@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear font data array:%@AE@%%@NL@% ERASE FontData%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'=== UnRegisterFonts - Erases registered font header array and resets%@AE@%%@NL@% %@AB@%' total registered fonts to 0:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Arguments:%@AE@%%@NL@% %@AB@%' ErrNum - The error number to set FontErr variable to%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'=================================================================%@AE@%%@NL@% SUB UnRegisterFonts STATIC%@NL@% SHARED FontHdrReg() AS IFontInfo, FGP AS GlobalParams%@NL@% %@NL@% ON ERROR GOTO UnexpectedErr%@NL@% %@NL@% %@AB@%' Clear outstanding font errors:%@AE@%%@NL@% flClearFontErr%@NL@% %@NL@% REDIM FontHdrReg(1 TO 1) AS IFontInfo%@NL@% FGP.MaxRegistered = UBOUND(FontHdrReg, 1)%@NL@% FGP.TotalRegistered = 0%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%FONTDEMO.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\FONTDEMO.BAS%@AE@%%@NL@% %@NL@% %@AB@%' FONTDEMO.BAS - FONTB demonstration program.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Copyright (C) 1989 Microsoft Corporation, All Rights Reserved%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' This program demonstrates some of the capabilities of the fonts%@AE@%%@NL@% %@AB@%' toolbox. It loads font files found in the current directory and%@AE@%%@NL@% %@AB@%' and allows you to select a font for display.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' The following font files are provided with BASIC 7.0:%@AE@%%@NL@% %@AB@%' - Raster fonts designed for screen resolution of 640x200%@AE@%%@NL@% %@AB@%' COURA.FON%@AE@%%@NL@% %@AB@%' HELVA.FON%@AE@%%@NL@% %@AB@%' TMSRA.FON%@AE@%%@NL@% %@AB@%' - Raster fonts designed for screen resolution of 640x350%@AE@%%@NL@% %@AB@%' COURB.FON%@AE@%%@NL@% %@AB@%' HELVB.FON%@AE@%%@NL@% %@AB@%' TMSRB.FON%@AE@%%@NL@% %@AB@%' - Raster fonts designed for screen resolution of 640x480%@AE@%%@NL@% %@AB@%' COURE.FON%@AE@%%@NL@% %@AB@%' HELVE.FON%@AE@%%@NL@% %@AB@%' TMSRE.FON%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' $INCLUDE: 'FONTB.BI'%@AE@%%@NL@% CONST TRUE = -1%@NL@% CONST FALSE = 0%@NL@% DECLARE SUB DriveScreen ()%@NL@% DECLARE SUB GetFiles ()%@NL@% DECLARE SUB GetModes ()%@NL@% DECLARE SUB ShowScreen ()%@NL@% %@NL@% DIM SHARED FI AS FontInfo%@NL@% DIM SHARED totalmodes AS INTEGER%@NL@% DIM SHARED modes(1 TO 13) AS INTEGER%@NL@% DIM SHARED fontfiles(1 TO 18) AS STRING%@NL@% DIM SHARED totalfonts AS INTEGER%@NL@% DIM SHARED currentfont AS INTEGER%@NL@% DIM SHARED currentmode AS INTEGER%@NL@% GetModes%@NL@% GetFiles%@NL@% currentfont = 1%@NL@% DO%@NL@% DriveScreen%@NL@% ShowScreen%@NL@% LOOP%@NL@% END%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'DriveScreen displays the lists of available fonts and screen modes and%@AE@%%@NL@% %@AB@%'scrolls through them with arrow keys.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB DriveScreen STATIC%@NL@% IF init% = 0 THEN%@NL@% set$ = "f"%@NL@% max% = totalfonts%@NL@% posit% = currentfont%@NL@% modedim$ = "320x200640x200720x348640x400 320x200"%@NL@% modedim$ = modedim$ + "640x200640x350640x350640x480640x480320x200"%@NL@% %@NL@% %@AB@% 'Check if monitor supports color or mono.%@AE@%%@NL@% %@NL@% SELECT CASE modes(1)%@NL@% CASE 13, 9, 8, 7%@NL@% mode$ = "color"%@NL@% CASE 3, 4, 10%@NL@% mode$ = "mono"%@NL@% CASE 2%@NL@% IF modes(2) = 1 THEN%@NL@% mode$ = "color"%@NL@% ELSE%@NL@% mode$ = "mono"%@NL@% END IF%@NL@% END SELECT%@NL@% FOR i% = 1 TO totalmodes%@NL@% IF modes(i%) = 4 THEN mode$ = "mono"%@NL@% NEXT i%%@NL@% %@NL@% %@AB@% 'Set colors based on type of monitor.%@AE@%%@NL@% %@NL@% SELECT CASE mode$%@NL@% CASE "color"%@NL@% listfore% = 7%@NL@% listback% = 0%@NL@% titleon% = 15%@NL@% titleoff% = 7%@NL@% titleback% = 1%@NL@% back% = 1%@NL@% high% = 15%@NL@% CASE "mono"%@NL@% listfore% = 7%@NL@% listback% = 0%@NL@% titleon% = 0%@NL@% titleoff% = 2%@NL@% titleback% = 7%@NL@% back% = 0%@NL@% high% = 7%@NL@% END SELECT%@NL@% init% = 1%@NL@% END IF%@NL@% %@NL@% %@AB@%'Display the screen with the current selections.%@AE@%%@NL@% %@NL@% SCREEN 0%@NL@% WIDTH 80, 25%@NL@% LOCATE , , 0: COLOR 0, back%%@NL@% PRINT SPACE$(1920)%@NL@% LOCATE 2, 1: COLOR high%, back%%@NL@% PRINT " Font Toolbox Demo"%@NL@% COLOR titleoff%, back%%@NL@% PRINT " Copyright (C) 1989 Microsoft Corporation"%@NL@% LOCATE 22, 1: COLOR titleoff%, back%%@NL@% PRINT SPC(55); "<CR> to view fontfile"%@NL@% PRINT SPC(55); "ESC to exit"%@NL@% %@NL@% GOSUB swaptitles%@NL@% GOSUB swaptitles%@NL@% FOR i% = 1 TO totalfonts%@NL@% LOCATE 5 + i%, 20%@NL@% COLOR listfore%, listback%%@NL@% PRINT LEFT$(fontfiles(i%) + " ", 12)%@NL@% NEXT i%%@NL@% LOCATE 5 + currentfont, 20%@NL@% COLOR listback%, listfore%%@NL@% PRINT LEFT$(fontfiles(currentfont) + " ", 12)%@NL@% %@NL@% FOR i% = 1 TO totalmodes%@NL@% LOCATE 5 + i%, 50%@NL@% COLOR listfore%, listback%%@NL@% PRINT LEFT$(STR$(modes(i%)) + " ", 4) + MID$(modedim$, 7 * modes(i%) - 6, 7)%@NL@% NEXT i%%@NL@% LOCATE 5 + currentmode, 50%@NL@% COLOR listback%, listfore%%@NL@% PRINT LEFT$(STR$(modes(currentmode)) + " ", 4) + MID$(modedim$, 7 * modes(currentmode) - 6, 7)%@NL@% %@NL@% %@AB@%'Scroll through choices%@AE@%%@NL@% %@NL@% DO%@NL@% SELECT CASE INKEY$%@NL@% CASE CHR$(0) + CHR$(72)%@NL@% GOSUB upone%@NL@% CASE CHR$(0) + CHR$(80)%@NL@% GOSUB downone%@NL@% CASE CHR$(9), CHR$(0) + CHR$(15), CHR$(0) + CHR$(75), CHR$(0) + CHR$(77)%@NL@% GOSUB swaptitles%@NL@% CASE CHR$(13), CHR$(32): EXIT DO%@NL@% CASE CHR$(27)%@NL@% COLOR 15, 0%@NL@% CLS%@NL@% END%@NL@% END SELECT%@NL@% LOOP%@NL@% EXIT SUB%@NL@% %@NL@% swaptitles:%@NL@% IF set$ = "f" THEN%@NL@% set$ = "m"%@NL@% max% = totalmodes%@NL@% posit% = currentmode%@NL@% LOCATE 5, 20: COLOR titleoff%, back%%@NL@% PRINT "Font files:"%@NL@% LOCATE 5, 50: COLOR titleon%, titleback%%@NL@% PRINT "Screen Modes:"%@NL@% ELSEIF set$ = "m" THEN%@NL@% set$ = "f"%@NL@% max% = totalfonts%@NL@% posit% = currentfont%@NL@% LOCATE 5, 20: COLOR titleon%, titleback%%@NL@% PRINT "Font files:"%@NL@% LOCATE 5, 50: COLOR titleoff%, back%%@NL@% PRINT "Screen Modes:"%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% upone:%@NL@% oldpos% = posit%%@NL@% posit% = (posit% + max% - 2) MOD max% + 1%@NL@% GOSUB redraw%@NL@% RETURN%@NL@% %@NL@% downone:%@NL@% oldpos% = posit%%@NL@% posit% = posit% MOD max% + 1%@NL@% GOSUB redraw%@NL@% RETURN%@NL@% %@NL@% redraw:%@NL@% IF set$ = "f" THEN%@NL@% LOCATE 5 + oldpos%, 20%@NL@% COLOR listfore%, listback%%@NL@% PRINT LEFT$(fontfiles(oldpos%) + " ", 12)%@NL@% LOCATE 5 + posit%, 20%@NL@% COLOR listback%, listfore%%@NL@% PRINT LEFT$(fontfiles(posit%) + " ", 12)%@NL@% currentfont = posit%%@NL@% ELSE%@NL@% LOCATE 5 + oldpos%, 50%@NL@% COLOR listfore%, listback%%@NL@% PRINT LEFT$(STR$(modes(oldpos%)) + " ", 4) + MID$(modedim$, 7 * modes(oldpos%) - 6, 7)%@NL@% LOCATE 5 + posit%, 50%@NL@% COLOR listback%, listfore%%@NL@% PRINT LEFT$(STR$(modes(posit%)) + " ", 4) + MID$(modedim$, 7 * modes(posit%) - 6, 7)%@NL@% currentmode = posit%%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'GetFiles finds all *.fon files in the current working directory and checks%@AE@%%@NL@% %@AB@%'if they are legitimate. If the files are ok, they are added to files list.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB GetFiles%@NL@% SCREEN 0%@NL@% WIDTH 80, 25%@NL@% tryagain:%@NL@% CLS%@NL@% PRINT "Checking fontfiles..."%@NL@% totalfonts = 0%@NL@% X$ = DIR$("*.fon")%@NL@% IF X$ = "" THEN%@NL@% PRINT "No font files found in current directory."%@NL@% PRINT "Push a shell to change directories? [yn]"%@NL@% try$ = "a"%@NL@% DO UNTIL INSTR(1, "NYny", try$)%@NL@% try$ = INPUT$(1)%@NL@% LOOP%@NL@% SELECT CASE UCASE$(try$)%@NL@% CASE "Y"%@NL@% PRINT "Type 'EXIT' to return to demo."%@NL@% SHELL%@NL@% GOTO tryagain%@NL@% CASE "N"%@NL@% END%@NL@% END SELECT%@NL@% ELSE%@NL@% DO WHILE X$ <> ""%@NL@% PRINT " "; UCASE$(X$); "--";%@NL@% SetMaxFonts 10, 10%@NL@% Reg% = RegisterFonts(X$)%@NL@% IF Reg% = 0 THEN%@NL@% PRINT "bad font file"%@NL@% ELSE%@NL@% totalfonts = totalfonts + 1%@NL@% fontfiles(totalfonts) = UCASE$(X$)%@NL@% PRINT "OK"%@NL@% IF totalfonts = 18 THEN EXIT DO%@NL@% END IF%@NL@% X$ = DIR$%@NL@% LOOP%@NL@% END IF%@NL@% SLEEP 1%@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'GetModes tries all screen modes from 1-13 to see if they are supported.%@AE@%%@NL@% %@AB@%'If a mode is supported, it is added to the list of available modes.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB GetModes%@NL@% ON LOCAL ERROR GOTO badmode%@NL@% nextactive% = 1%@NL@% totalmodes = 0%@NL@% FOR i% = 13 TO 1 STEP -1%@NL@% good% = TRUE%@NL@% SCREEN i%%@NL@% IF good% THEN%@NL@% modes(nextactive%) = i%%@NL@% nextactive% = nextactive% + 1%@NL@% totalmodes = totalmodes + 1%@NL@% END IF%@NL@% NEXT i%%@NL@% IF totalmodes = 0 THEN%@NL@% PRINT "No graphics modes available"%@NL@% END%@NL@% END IF%@NL@% %@NL@% IF modes(1) = 13 THEN%@NL@% currentmode = 2%@NL@% ELSE%@NL@% currentmode = 1%@NL@% END IF%@NL@% EXIT SUB%@NL@% badmode:%@NL@% good% = FALSE%@NL@% RESUME NEXT%@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'ShowScreen displays all the fonts in the current font file and current%@AE@%%@NL@% %@AB@%'graphics mode.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB ShowScreen%@NL@% SetMaxFonts 10, 10%@NL@% TotalReg% = RegisterFonts(fontfiles(currentfont))%@NL@% SCREEN modes(currentmode)%@NL@% PRINT "Please wait..."%@NL@% %@NL@% IF FontErr THEN%@NL@% CLS%@NL@% PRINT "Unable to continue, FontErr ="; FontErr%@NL@% C$ = INPUT$(1)%@NL@% EXIT SUB%@NL@% END IF%@NL@% IF TotalReg% > 10 THEN TotalReg% = 10%@NL@% %@NL@% StrLen% = TotalReg% * 3 - 1%@NL@% IF TotalReg% > 9 THEN StrLen% = StrLen% + TotalReg% - 9%@NL@% LoadStr$ = LEFT$("N1/N2/N3/N4/N5/N6/N7/N8/N9/N10", StrLen%)%@NL@% TotalLoad% = LoadFont(LoadStr$)%@NL@% %@NL@% SELECT CASE modes(currentmode)%@NL@% CASE 1: XS% = 160: YS% = 100%@NL@% CASE 2: XS% = 320: YS% = 100%@NL@% CASE 3: XS% = 360: YS% = 174%@NL@% CASE 4: XS% = 320: YS% = 200%@NL@% CASE 7: XS% = 160: YS% = 100%@NL@% CASE 8: XS% = 320: YS% = 100%@NL@% CASE 9: XS% = 320: YS% = 175%@NL@% CASE 10: XS% = 320: YS% = 175%@NL@% CASE 11: XS% = 320: YS% = 240%@NL@% CASE 12: XS% = 320: YS% = 240%@NL@% CASE 13: XS% = 160: YS% = 100%@NL@% END SELECT%@NL@% %@NL@% prompt$ = "Press any key."%@NL@% FOR i% = 1 TO TotalLoad%%@NL@% CLS%@NL@% SelectFont INT(i%)%@NL@% GetFontInfo FI%@NL@% SetGTextDir 0%@NL@% SetGTextColor 14%@NL@% Length% = OutGText(1, 1, RTRIM$(FI.FaceName))%@NL@% Length% = OutGText(1, 1 + FI.PixHeight, LTRIM$(STR$(FI.Points) + " Point"))%@NL@% FOR Dir% = 0 TO 3%@NL@% SetGTextDir Dir%%@NL@% SetGTextColor 15 - Dir%%@NL@% SELECT CASE Dir%%@NL@% CASE 0: X% = XS%: Y% = YS% - FI.PixHeight%@NL@% CASE 1: X% = XS% - FI.PixHeight: Y% = YS%%@NL@% CASE 2: X% = XS%: Y% = YS% + FI.PixHeight%@NL@% CASE 3: X% = XS% + FI.PixHeight: Y% = YS%%@NL@% END SELECT%@NL@% Length% = OutGText(CSNG(X%), CSNG(Y%), "Microsoft")%@NL@% NEXT Dir%%@NL@% SelectFont 2%@NL@% GetFontInfo FI%@NL@% SetGTextColor 14%@NL@% SetGTextDir 0%@NL@% IF i% = TotalLoad% THEN prompt$ = "Press ESC to go on."%@NL@% Length% = GetGTextLen(prompt$)%@NL@% Length% = OutGText(2 * XS% - Length% - 10, 2 * YS% - FI.PixHeight - 1, prompt$)%@NL@% IF i% = TotalLoad% THEN%@NL@% DO UNTIL INKEY$ = CHR$(27): LOOP%@NL@% ELSE%@NL@% a$ = INPUT$(1)%@NL@% END IF%@NL@% NEXT i%%@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%GENERAL.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\GENERAL.BAS%@AE@%%@NL@% %@NL@% %@AB@%'============================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' GENERAL.BAS - General Routines for the User Interface Toolbox in%@AE@%%@NL@% %@AB@%' Microsoft BASIC 7.0, Professional Development System%@AE@%%@NL@% %@AB@%' Copyright (C) 1987-1989, Microsoft Corporation%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' NOTE: This sample source code toolbox is intended to demonstrate some%@AE@%%@NL@% %@AB@%' of the extended capabilities of Microsoft BASIC 7.0 Professional%@AE@%%@NL@% %@AB@%' Development system that can help to leverage the professional%@AE@%%@NL@% %@AB@%' developer's time more effectively. While you are free to use,%@AE@%%@NL@% %@AB@%' modify, or distribute the routines in this module in any way you%@AE@%%@NL@% %@AB@%' find useful, it should be noted that these are examples only and%@AE@%%@NL@% %@AB@%' should not be relied upon as a fully-tested "add-on" library.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' PURPOSE: These are the general purpose routines needed by the other%@AE@%%@NL@% %@AB@%' modules in the user interface toolbox.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' To create a library and QuickLib containing the routines found%@AE@%%@NL@% %@AB@%' in this file, follow these steps:%@AE@%%@NL@% %@AB@%' BC /X/FS general.bas%@AE@%%@NL@% %@AB@%' LIB general.lib + general + uiasm + qbx.lib;%@AE@%%@NL@% %@AB@%' LINK /Q general.lib, general.qlb,,qbxqlb.lib;%@AE@%%@NL@% %@AB@%' Creating a library and QuickLib for any of the other UI toolbox files%@AE@%%@NL@% %@AB@%' (WINDOW.BAS, MENU.BAS and MOUSE.BAS) is done this way also.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' To create a library and QuickLib containing all routines from%@AE@%%@NL@% %@AB@%' the User Interface toolbox follow these steps:%@AE@%%@NL@% %@AB@%' BC /X/FS general.bas%@AE@%%@NL@% %@AB@%' BC /X/FS window.bas%@AE@%%@NL@% %@AB@%' BC /X/FS mouse.bas%@AE@%%@NL@% %@AB@%' BC /X/FS menu.bas%@AE@%%@NL@% %@AB@%' LIB uitb.lib + general + window + mouse + menu + uiasm + qbx.lib;%@AE@%%@NL@% %@AB@%' LINK /Q uitb.lib, uitb.qlb,,qbxqlb.lib;%@AE@%%@NL@% %@AB@%' If you are going to use this QuickLib in conjunction with the font source%@AE@%%@NL@% %@AB@%' code (FONTB.BAS) or the charting source code (CHRTB.BAS), you need to%@AE@%%@NL@% %@AB@%' include the assembly code routines referenced in these files. For the font%@AE@%%@NL@% %@AB@%' routines, perform the following LIB command after creating the library but%@AE@%%@NL@% %@AB@%' before creating the QuickLib as described above:%@AE@%%@NL@% %@AB@%' LIB uitb.lib + fontasm;%@AE@%%@NL@% %@AB@%' For the charting routines, perform the following LIB command after creating%@AE@%%@NL@% %@AB@%' the library but before creating the QuickLib as described above:%@AE@%%@NL@% %@AB@%' LIB uitb.lib + chrtasm;%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'============================================================================%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@NL@% %@AB@%'$INCLUDE: 'general.bi'%@AE@%%@NL@% %@AB@%'$INCLUDE: 'mouse.bi'%@AE@%%@NL@% %@NL@% FUNCTION AltToASCII$ (kbd$)%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Converts Alt+A to A,Alt+B to B, etc. You send it a string. The right%@AE@%%@NL@% %@AB@% ' most character is compared to the string below, and is converted to%@AE@%%@NL@% %@AB@% ' the proper character.%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% index = INSTR("xyz{|}~Çü !" + CHR$(34) + "#$%&,-./012éâ", RIGHT$(kbd$, 1))%@NL@% %@NL@% IF index = 0 THEN%@NL@% AltToASCII = ""%@NL@% ELSE%@NL@% AltToASCII = MID$("1234567890QWERTYUIOPASDFGHJKLZXCVBNM-=", index, 1)%@NL@% END IF%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% SUB Box (row1, col1, row2, col2, fore, back, border$, fillFlag) STATIC%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' Use default border if an illegal border$ is passed%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% IF LEN(border$) < 9 THEN%@NL@% t$ = "┌─┐│ │└─┘"%@NL@% ELSE%@NL@% t$ = border$%@NL@% END IF%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Check coordinates for validity, then draw box%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% IF col1 <= (col2 - 2) AND row1 <= (row2 - 2) AND col1 >= MINCOL AND row1 >= MINROW AND col2 <= MAXCOL AND row2 <= MAXROW THEN%@NL@% MouseHide%@NL@% BoxWidth = col2 - col1 + 1%@NL@% BoxHeight = row2 - row1 + 1%@NL@% LOCATE row1, col1%@NL@% COLOR fore, back%@NL@% PRINT LEFT$(t$, 1); STRING$(BoxWidth - 2, MID$(t$, 2, 1)); MID$(t$, 3, 1)%@NL@% LOCATE row2, col1%@NL@% PRINT MID$(t$, 7, 1); STRING$(BoxWidth - 2, MID$(t$, 8, 1)); MID$(t$, 9, 1);%@NL@% %@NL@% FOR a = row1 + 1 TO row1 + BoxHeight - 2%@NL@% LOCATE a, col1%@NL@% PRINT MID$(t$, 4, 1);%@NL@% %@NL@% IF fillFlag THEN%@NL@% PRINT STRING$(BoxWidth - 2, MID$(t$, 5, 1));%@NL@% ELSE%@NL@% LOCATE a, col1 + BoxWidth - 1%@NL@% END IF%@NL@% %@NL@% PRINT MID$(t$, 6, 1);%@NL@% NEXT a%@NL@% LOCATE row1 + 1, col1 + 1%@NL@% MouseShow%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB GetBackground (row1, col1, row2, col2, buffer$) STATIC%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Create enough space in buffer$ to hold the screen info behind the box%@AE@%%@NL@% %@AB@% ' Then, call GetCopyBox to store the background in buffer$%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% IF row1 >= 1 AND row2 <= MAXROW AND col1 >= 1 AND col2 <= MAXCOL THEN%@NL@% Wid = col2 - col1 + 1%@NL@% Hei = row2 - row1 + 1%@NL@% size = 4 + (2 * Wid * Hei)%@NL@% buffer$ = SPACE$(size)%@NL@% %@NL@% CALL GetCopyBox(row1, col1, row2, col2, buffer$)%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% FUNCTION GetShiftState (bit)%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Returns the shift state after calling interrupt 22%@AE@%%@NL@% %@AB@% ' bit 0 : right shift%@AE@%%@NL@% %@AB@% ' 1 : left shift%@AE@%%@NL@% %@AB@% ' 2 : ctrl key%@AE@%%@NL@% %@AB@% ' 3 : alt key%@AE@%%@NL@% %@AB@% ' 4 : scroll lock%@AE@%%@NL@% %@AB@% ' 5 : num lock%@AE@%%@NL@% %@AB@% ' 6 : caps lock%@AE@%%@NL@% %@AB@% ' 7 : insert state%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% IF bit >= 0 AND bit <= 7 THEN%@NL@% DIM regs AS RegType%@NL@% regs.ax = 2 * 256%@NL@% INTERRUPT 22, regs, regs%@NL@% %@NL@% IF regs.ax AND 2 ^ bit THEN%@NL@% GetShiftState = TRUE%@NL@% ELSE%@NL@% GetShiftState = FALSE%@NL@% END IF%@NL@% ELSE%@NL@% GetShiftState = FALSE%@NL@% END IF%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% SUB PutBackground (row, col, buffer$)%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' This sub checks the boundries before executing the put command%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% IF row >= 1 AND row <= MAXROW AND col >= 1 AND col <= MAXCOL THEN%@NL@% CALL PutCopyBox(row, col, buffer$)%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB scroll (row1, col1, row2, col2, lines, attr)%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Make sure coordinates are in proper order%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% IF row1 > row2 THEN%@NL@% SWAP row1, row2%@NL@% END IF%@NL@% %@NL@% IF col1 > col2 THEN%@NL@% SWAP col1, col2%@NL@% END IF%@NL@% %@NL@% %@AB@% ' ======================================================================%@AE@%%@NL@% %@AB@% ' If coordinates are valid, prepare registers, and call interrupt%@AE@%%@NL@% %@AB@% ' ======================================================================%@AE@%%@NL@% %@NL@% IF row1 >= MINROW AND row2 <= MAXROW AND col1 >= MINCOL AND col2 <= MAXCOL THEN%@NL@% DIM regs AS RegType%@NL@% %@NL@% IF lines < 0 THEN%@NL@% regs.ax = 256 * 7 + (-lines)%@NL@% regs.bx = 256 * attr%@NL@% regs.cx = 256 * (row1 - 1) + (col1 - 1)%@NL@% regs.dx = 256 * (row2 - 1) + (col2 - 1)%@NL@% ELSE%@NL@% regs.ax = 256 * 6 + lines%@NL@% regs.bx = 256 * (attr MOD 8) * 16%@NL@% regs.cx = 256 * (row1 - 1) + (col1 - 1)%@NL@% regs.dx = 256 * (row2 - 1) + (col2 - 1)%@NL@% END IF%@NL@% %@NL@% INTERRUPT 16, regs, regs%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%INDEX.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\INDEX.BAS%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@NL@% %@AB@%' Define the symbolic constants used globally in the program:%@AE@%%@NL@% CONST FALSE = 0, TRUE = NOT FALSE%@NL@% %@NL@% %@AB@%' Define a record structure for random-file records:%@AE@%%@NL@% TYPE StockItem%@NL@% PartNumber AS STRING * 6%@NL@% Description AS STRING * 20%@NL@% UnitPrice AS SINGLE%@NL@% Quantity AS INTEGER%@NL@% END TYPE%@NL@% %@NL@% %@AB@%' Define a record structure for each element of the index:%@AE@%%@NL@% TYPE IndexType%@NL@% RecordNumber AS INTEGER%@NL@% PartNumber AS STRING * 6%@NL@% END TYPE%@NL@% %@NL@% %@AB@%' Declare procedures that will be called:%@AE@%%@NL@% DECLARE FUNCTION Filter$ (Prompt$)%@NL@% DECLARE FUNCTION FindRecord% (PartNumber$, RecordVar AS StockItem)%@NL@% %@NL@% DECLARE SUB AddRecord (RecordVar AS StockItem)%@NL@% DECLARE SUB InputRecord (RecordVar AS StockItem)%@NL@% DECLARE SUB PrintRecord (RecordVar AS StockItem)%@NL@% DECLARE SUB SortIndex ()%@NL@% DECLARE SUB ShowPartNumbers ()%@NL@% %@AB@%' Define a buffer (using the StockItem type)%@AE@%%@NL@% %@AB@%' and define and dimension the index array:%@AE@%%@NL@% DIM StockRecord AS StockItem, index(1 TO 100) AS IndexType%@NL@% %@NL@% %@AB@%' Open the random-access file:%@AE@%%@NL@% OPEN "STOCK.DAT" FOR RANDOM AS #1 LEN = LEN(StockRecord)%@NL@% %@NL@% %@AB@%' Calculate number of records in the file:%@AE@%%@NL@% NumberOfRecords = LOF(1) \ LEN(StockRecord)%@NL@% %@NL@% %@AB@%' If there are records, read them and build the index:%@AE@%%@NL@% IF NumberOfRecords <> 0 THEN%@NL@% FOR RecordNumber = 1 TO NumberOfRecords%@NL@% %@NL@% %@AB@% ' Read the data from a new record in the file:%@AE@%%@NL@% GET #1, RecordNumber, StockRecord%@NL@% %@NL@% %@AB@% ' Place part number and record number in index:%@AE@%%@NL@% index(RecordNumber).RecordNumber = RecordNumber%@NL@% index(RecordNumber).PartNumber = StockRecord.PartNumber%@NL@% NEXT%@NL@% %@NL@% SortIndex ' Sort index in part-number order.%@NL@% END IF%@NL@% %@NL@% DO ' Main-menu loop.%@NL@% CLS%@NL@% PRINT "(A)dd records."%@NL@% PRINT "(L)ook up records."%@NL@% PRINT "(Q)uit program."%@NL@% PRINT%@NL@% LOCATE , , 1%@NL@% PRINT "Type your choice (A, L, or Q) here: ";%@NL@% %@NL@% %@AB@% ' Loop until user presses, A, L, or Q:%@AE@%%@NL@% DO%@NL@% Choice$ = UCASE$(INPUT$(1))%@NL@% LOOP WHILE INSTR("ALQ", Choice$) = 0%@NL@% %@NL@% %@AB@% ' Branch according to choice:%@AE@%%@NL@% SELECT CASE Choice$%@NL@% CASE "A"%@NL@% AddRecord StockRecord%@NL@% CASE "L"%@NL@% IF NumberOfRecords = 0 THEN%@NL@% PRINT : PRINT "No records in file yet. ";%@NL@% PRINT "Press any key to continue.";%@NL@% Pause$ = INPUT$(1)%@NL@% ELSE%@NL@% InputRecord StockRecord%@NL@% END IF%@NL@% CASE "Q" ' End program.%@NL@% END SELECT%@NL@% LOOP UNTIL Choice$ = "Q"%@NL@% %@NL@% CLOSE #1 ' All done, close file and end.%@NL@% END%@NL@% %@AB@%' ======================== ADDRECORD ======================%@AE@%%@NL@% %@AB@%' Adds records to the file from input typed at the keyboard%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@AB@%' ========================= FILTER ========================%@AE@%%@NL@% %@AB@%' Filters all non-numeric characters from a string%@AE@%%@NL@% %@AB@%' and returns the filtered string%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@AB@%' ======================= FINDRECORD ===================%@AE@%%@NL@% %@AB@%' Uses a binary search to locate a record in the index%@AE@%%@NL@% %@AB@%' ======================================================%@AE@%%@NL@% %@AB@%' ======================= PRINTRECORD =====================%@AE@%%@NL@% %@AB@%' Prints a record on the screen%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@AB@%' ===================== SHOWPARTNUMBERS ===================%@AE@%%@NL@% %@AB@%' Prints an index of all the part numbers in the upper part%@AE@%%@NL@% %@AB@%' of the screen%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@AB@%' ========================= SORTINDEX =====================%@AE@%%@NL@% %@AB@%' Sorts the index by part number%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% %@NL@% SUB AddRecord (RecordVar AS StockItem) STATIC%@NL@% SHARED index() AS IndexType, NumberOfRecords%@NL@% DO%@NL@% CLS%@NL@% INPUT "Part Number: ", RecordVar.PartNumber%@NL@% INPUT "Description: ", RecordVar.Description%@NL@% %@NL@% %@AB@% ' Call the Filter$ FUNCTION to input price & quantity:%@AE@%%@NL@% RecordVar.UnitPrice = VAL(Filter$("Unit Price : "))%@NL@% RecordVar.Quantity = VAL(Filter$("Quantity : "))%@NL@% %@NL@% NumberOfRecords = NumberOfRecords + 1%@NL@% %@NL@% PUT #1, NumberOfRecords, RecordVar%@NL@% %@NL@% index(NumberOfRecords).RecordNumber = NumberOfRecords%@NL@% index(NumberOfRecords).PartNumber = RecordVar.PartNumber%@NL@% PRINT : PRINT "Add another? ";%@NL@% OK$ = UCASE$(INPUT$(1))%@NL@% LOOP WHILE OK$ = "Y"%@NL@% %@NL@% SortIndex ' Sort index file again.%@NL@% END SUB%@NL@% %@NL@% FUNCTION Filter$ (Prompt$) STATIC%@NL@% ValTemp2$ = ""%@NL@% PRINT Prompt$; ' Print the prompt passed.%@NL@% INPUT "", ValTemp1$ ' Input a number as%@NL@% %@AB@% ' a string.%@AE@%%@NL@% StringLength = LEN(ValTemp1$) ' Get the string's length.%@NL@% FOR I% = 1 TO StringLength ' Go through the string,%@NL@% Char$ = MID$(ValTemp1$, I%, 1) ' one character at a time.%@NL@% %@NL@% %@AB@% ' Is the character a valid part of a number (i.e.,%@AE@%%@NL@% %@AB@% ' a digit or a decimal point)? If yes, add it to%@AE@%%@NL@% %@AB@% ' the end of a new string:%@AE@%%@NL@% IF INSTR(".0123456789", Char$) > 0 THEN%@NL@% ValTemp2$ = ValTemp2$ + Char$%@NL@% %@NL@% %@AB@% ' Otherwise, check to see if it's a lowercase "l",%@AE@%%@NL@% %@AB@% ' since typewriter users may enter a one that way:%@AE@%%@NL@% ELSEIF Char$ = "l" THEN%@NL@% ValTemp2$ = ValTemp2$ + "1" ' Change the "l" to a "1".%@NL@% END IF%@NL@% NEXT I%%@NL@% %@NL@% Filter$ = ValTemp2$ ' Return filtered string.%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% FUNCTION FindRecord% (Part$, RecordVar AS StockItem) STATIC%@NL@% SHARED index() AS IndexType, NumberOfRecords%@NL@% %@NL@% %@AB@% ' Set top and bottom bounds of search:%@AE@%%@NL@% TopRecord = NumberOfRecords%@NL@% BottomRecord = 1%@NL@% %@NL@% %@AB@% ' Search until top of range is less than bottom:%@AE@%%@NL@% DO UNTIL (TopRecord < BottomRecord)%@NL@% %@NL@% %@AB@% ' Choose midpoint:%@AE@%%@NL@% Midpoint = (TopRecord + BottomRecord) \ 2%@NL@% %@NL@% %@AB@% ' Test to see if it's the one wanted (RTRIM$()%@AE@%%@NL@% %@AB@% ' trims trailing blanks from a fixed string):%@AE@%%@NL@% Test$ = RTRIM$(index(Midpoint).PartNumber)%@NL@% %@NL@% %@AB@% ' If it is, exit loop:%@AE@%%@NL@% IF Test$ = Part$ THEN%@NL@% EXIT DO%@NL@% %@NL@% %@AB@% ' Otherwise, if what we're looking for is greater,%@AE@%%@NL@% %@AB@% ' move bottom up:%@AE@%%@NL@% ELSEIF Part$ > Test$ THEN%@NL@% BottomRecord = Midpoint + 1%@NL@% %@NL@% %@AB@% ' Otherwise, move the top down:%@AE@%%@NL@% ELSE%@NL@% TopRecord = Midpoint - 1%@NL@% END IF%@NL@% LOOP%@NL@% %@NL@% %@AB@% ' If part was found, input record from file using%@AE@%%@NL@% %@AB@% ' pointer in index and set FindRecord% to TRUE:%@AE@%%@NL@% IF Test$ = Part$ THEN%@NL@% GET #1, index(Midpoint).RecordNumber, RecordVar%@NL@% FindRecord% = TRUE%@NL@% %@NL@% %@AB@% ' Otherwise, if part was not found, set FindRecord%%@AE@%%@NL@% %@AB@% ' to FALSE:%@AE@%%@NL@% ELSE%@NL@% FindRecord% = FALSE%@NL@% END IF%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%' ======================= INPUTRECORD =====================%@AE@%%@NL@% %@AB@%' First, INPUTRECORD calls SHOWPARTNUMBERS, which prints%@AE@%%@NL@% %@AB@%' a menu of part numbers on the top of the screen. Next,%@AE@%%@NL@% %@AB@%' INPUTRECORD prompts the user to enter a part number.%@AE@%%@NL@% %@AB@%' Finally, it calls the FINDRECORD and PRINTRECORD%@AE@%%@NL@% %@AB@%' procedures to find and print the given record.%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% SUB InputRecord (RecordVar AS StockItem) STATIC%@NL@% CLS%@NL@% ShowPartNumbers ' Call the ShowPartNumbers SUB.%@NL@% %@NL@% %@AB@% ' Print data from specified records%@AE@%%@NL@% %@AB@% ' on the bottom part of the screen:%@AE@%%@NL@% DO%@NL@% PRINT "Type a part number listed above ";%@NL@% INPUT "(or Q to quit) and press <ENTER>: ", Part$%@NL@% IF UCASE$(Part$) <> "Q" THEN%@NL@% IF FindRecord(Part$, RecordVar) THEN%@NL@% PrintRecord RecordVar%@NL@% ELSE%@NL@% PRINT "Part not found."%@NL@% END IF%@NL@% END IF%@NL@% PRINT STRING$(40, "_")%@NL@% LOOP WHILE UCASE$(Part$) <> "Q"%@NL@% %@NL@% VIEW PRINT ' Restore the text viewport to entire screen.%@NL@% END SUB%@NL@% %@NL@% SUB PrintRecord (RecordVar AS StockItem) STATIC%@NL@% PRINT "Part Number: "; RecordVar.PartNumber%@NL@% PRINT "Description: "; RecordVar.Description%@NL@% PRINT USING "Unit Price :$$###.##"; RecordVar.UnitPrice%@NL@% PRINT "Quantity :"; RecordVar.Quantity%@NL@% END SUB%@NL@% %@NL@% SUB ShowPartNumbers STATIC%@NL@% SHARED index() AS IndexType, NumberOfRecords%@NL@% %@NL@% CONST NUMCOLS = 8, COLWIDTH = 80 \ NUMCOLS%@NL@% %@NL@% %@AB@% ' At the top of the screen, print a menu indexing all%@AE@%%@NL@% %@AB@% ' the part numbers for records in the file. This menu is%@AE@%%@NL@% %@AB@% ' printed in columns of equal length (except possibly the%@AE@%%@NL@% %@AB@% ' last column, which may be shorter than the others):%@AE@%%@NL@% ColumnLength = NumberOfRecords%@NL@% DO WHILE ColumnLength MOD NUMCOLS%@NL@% ColumnLength = ColumnLength + 1%@NL@% LOOP%@NL@% ColumnLength = ColumnLength \ NUMCOLS%@NL@% Column = 1%@NL@% RecordNumber = 1%@NL@% DO UNTIL RecordNumber > NumberOfRecords%@NL@% FOR Row = 1 TO ColumnLength%@NL@% LOCATE Row, Column%@NL@% PRINT index(RecordNumber).PartNumber%@NL@% RecordNumber = RecordNumber + 1%@NL@% IF RecordNumber > NumberOfRecords THEN EXIT FOR%@NL@% NEXT Row%@NL@% Column = Column + COLWIDTH%@NL@% LOOP%@NL@% %@NL@% LOCATE ColumnLength + 1, 1%@NL@% PRINT STRING$(80, "_") ' Print separator line.%@NL@% %@NL@% %@AB@% ' Scroll information about records below the part-number%@AE@%%@NL@% %@AB@% ' menu (this way, the part numbers are not erased):%@AE@%%@NL@% VIEW PRINT ColumnLength + 2 TO 24%@NL@% END SUB%@NL@% %@NL@% SUB SortIndex STATIC%@NL@% SHARED index() AS IndexType, NumberOfRecords%@NL@% %@NL@% %@AB@% ' Set comparison offset to half the number of records%@AE@%%@NL@% %@AB@% ' in index:%@AE@%%@NL@% Offset = NumberOfRecords \ 2%@NL@% %@NL@% %@AB@% ' Loop until offset gets to zero:%@AE@%%@NL@% DO WHILE Offset > 0%@NL@% Limit = NumberOfRecords - Offset%@NL@% DO%@NL@% %@NL@% %@AB@% ' Assume no switches at this offset:%@AE@%%@NL@% Switch = FALSE%@NL@% %@NL@% %@AB@% ' Compare elements and switch ones out of order:%@AE@%%@NL@% FOR I = 1 TO Limit%@NL@% IF index(I).PartNumber > index(I + Offset).PartNumber THEN%@NL@% SWAP index(I), index(I + Offset)%@NL@% Switch = I%@NL@% END IF%@NL@% NEXT I%@NL@% %@NL@% %@AB@% ' Sort on next pass only to where%@AE@%%@NL@% %@AB@% ' last switch was made:%@AE@%%@NL@% Limit = Switch%@NL@% LOOP WHILE Switch%@NL@% %@NL@% %@AB@% ' No switches at last offset, try one half as big:%@AE@%%@NL@% Offset = Offset \ 2%@NL@% LOOP%@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%MANDEL.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MANDEL.BAS%@AE@%%@NL@% %@NL@% DEFINT A-Z ' Default variable type is integer.%@NL@% %@NL@% DECLARE SUB ShiftPalette ()%@NL@% DECLARE SUB WindowVals (WL%, WR%, WT%, WB%)%@NL@% DECLARE SUB ScreenTest (EM%, CR%, VL%, VR%, VT%, VB%)%@NL@% %@NL@% CONST FALSE = 0, TRUE = NOT FALSE ' Boolean constants%@NL@% %@NL@% %@AB@%' Set maximum number of iterations per point:%@AE@%%@NL@% CONST MAXLOOP = 30, MAXSIZE = 1000000%@NL@% %@NL@% DIM PaletteArray(15)%@NL@% FOR I = 0 TO 15: PaletteArray(I) = I: NEXT I%@NL@% %@NL@% %@AB@%' Call WindowVals to get coordinates of window corners:%@AE@%%@NL@% WindowVals WLeft, WRight, WTop, WBottom%@NL@% %@NL@% %@AB@%' Call ScreenTest to find out if this is an EGA machine%@AE@%%@NL@% %@AB@%' and get coordinates of viewport corners:%@AE@%%@NL@% ScreenTest EgaMode, ColorRange, VLeft, VRight, VTop, VBottom%@NL@% %@NL@% %@AB@%' Define viewport and corresponding window:%@AE@%%@NL@% VIEW (VLeft, VTop)-(VRight, VBottom), 0, ColorRange%@NL@% WINDOW (WLeft, WTop)-(WRight, WBottom)%@NL@% %@NL@% LOCATE 24, 10 : PRINT "Press any key to quit.";%@NL@% %@NL@% XLength = VRight - VLeft%@NL@% YLength = VBottom - VTop%@NL@% ColorWidth = MAXLOOP \ ColorRange%@NL@% %@NL@% %@AB@%' Loop through each pixel in viewport and calculate%@AE@%%@NL@% %@AB@%' whether or not it is in the Mandelbrot Set:%@AE@%%@NL@% FOR Y = 0 TO YLength ' Loop through every line%@NL@% %@AB@% ' in the viewport.%@AE@%%@NL@% LogicY = PMAP(Y, 3) ' Get the pixel's view%@NL@% %@AB@% ' y-coordinate.%@AE@%%@NL@% PSET (WLeft, LogicY) ' Plot leftmost pixel in the line.%@NL@% OldColor = 0 ' Start with background color.%@NL@% %@NL@% FOR X = 0 TO XLength ' Loop through every pixel%@NL@% %@AB@% ' in the line.%@AE@%%@NL@% LogicX = PMAP(X, 2) ' Get the pixel's view%@NL@% %@AB@% ' x-coordinate.%@AE@%%@NL@% MandelX& = LogicX%@NL@% MandelY& = LogicY%@NL@% %@AB@% ' Do the calculations to see if this point%@AE@%%@NL@% %@AB@% ' is in the Mandelbrot Set:%@AE@%%@NL@% FOR I = 1 TO MAXLOOP%@NL@% RealNum& = MandelX& * MandelX&%@NL@% ImagNum& = MandelY& * MandelY&%@NL@% IF (RealNum& + ImagNum&) >= MAXSIZE THEN EXIT FOR%@NL@% MandelY& = (MandelX& * MandelY&) \ 250 + LogicY%@NL@% MandelX& = (RealNum& - ImagNum&) \ 500 + LogicX%@NL@% NEXT I%@NL@% %@NL@% %@AB@% ' Assign a color to the point:%@AE@%%@NL@% PColor = I \ ColorWidth%@NL@% %@NL@% %@AB@% ' If color has changed, draw a line from%@AE@%%@NL@% %@AB@% ' the last point referenced to the new point,%@AE@%%@NL@% %@AB@% ' using the old color:%@AE@%%@NL@% IF PColor <> OldColor THEN%@NL@% LINE -(LogicX, LogicY), (ColorRange - OldColor)%@NL@% OldColor = PColor%@NL@% END IF%@NL@% %@NL@% IF INKEY$ <> "" THEN END%@NL@% NEXT X%@NL@% %@NL@% %@AB@% ' Draw the last line segment to the right edge%@AE@%%@NL@% %@AB@% ' of the viewport:%@AE@%%@NL@% LINE -(LogicX, LogicY), (ColorRange - OldColor)%@NL@% %@NL@% %@AB@% ' If this is an EGA machine, shift the palette after%@AE@%%@NL@% %@AB@% ' drawing each line:%@AE@%%@NL@% IF EgaMode THEN ShiftPalette%@NL@% NEXT Y%@NL@% %@NL@% DO%@NL@% %@AB@% ' Continue shifting the palette%@AE@%%@NL@% %@AB@% ' until the user presses a key:%@AE@%%@NL@% IF EgaMode THEN ShiftPalette%@NL@% LOOP WHILE INKEY$ = ""%@NL@% %@NL@% SCREEN 0, 0 ' Restore the screen to text mode,%@NL@% WIDTH 80 ' 80 columns.%@NL@% END%@NL@% %@NL@% BadScreen: ' Error handler that is invoked if%@NL@% EgaMode = FALSE ' there is no EGA graphics card%@NL@% RESUME NEXT%@NL@% %@AB@%' ====================== ShiftPalette =====================%@AE@%%@NL@% %@AB@%' Rotates the palette by one each time it is called%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% SUB ShiftPalette STATIC%@NL@% SHARED PaletteArray(), ColorRange%@NL@% %@NL@% FOR I = 1 TO ColorRange%@NL@% PaletteArray(I) = (PaletteArray(I) MOD ColorRange) + 1%@NL@% NEXT I%@NL@% PALETTE USING PaletteArray(0)%@NL@% %@NL@% END SUB%@NL@% %@AB@%' ======================= ScreenTest ======================%@AE@%%@NL@% %@AB@%' Uses a SCREEN 8 statement as a test to see if user has%@AE@%%@NL@% %@AB@%' EGA hardware. If this causes an error, the EM flag is%@AE@%%@NL@% %@AB@%' set to FALSE, and the screen is set with SCREEN 1.%@AE@%%@NL@% %@NL@% %@AB@%' Also sets values for corners of viewport (VL = left,%@AE@%%@NL@% %@AB@%' VR = right, VT = top, VB = bottom), scaled with the%@AE@%%@NL@% %@AB@%' correct aspect ratio so viewport is a perfect square.%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% SUB ScreenTest (EM, CR, VL, VR, VT, VB) STATIC%@NL@% EM = TRUE%@NL@% ON ERROR GOTO BadScreen%@NL@% SCREEN 8, 1%@NL@% ON ERROR GOTO 0%@NL@% %@NL@% IF EM THEN ' No error, SCREEN 8 is OK.%@NL@% VL = 110: VR = 529%@NL@% VT = 5: VB = 179%@NL@% CR = 15 ' 16 colors (0 - 15)%@NL@% %@NL@% ELSE ' Error, so use SCREEN 1.%@NL@% SCREEN 1, 1%@NL@% VL = 55: VR = 264%@NL@% VT = 5: VB = 179%@NL@% CR = 3 ' 4 colors (0 - 3)%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@AB@%' ======================= WindowVals ======================%@AE@%%@NL@% %@AB@%' Gets window corners as input from the user, or sets%@AE@%%@NL@% %@AB@%' values for the corners if there is no input%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% SUB WindowVals (WL, WR, WT, WB) STATIC%@NL@% CLS%@NL@% PRINT "This program prints the graphic representation of"%@NL@% PRINT "the complete Mandelbrot Set. The default window"%@NL@% PRINT "is from (-1000,625) to (250,-625). To zoom in on"%@NL@% PRINT "part of the figure, input coordinates inside"%@NL@% PRINT "this window."%@NL@% PRINT "Press <ENTER> to see the default window or"%@NL@% PRINT "any other key to input window coordinates: ";%@NL@% LOCATE , , 1%@NL@% Resp$ = INPUT$(1)%@NL@% %@NL@% %@AB@% ' User didn't press ENTER, so input window corners:%@AE@%%@NL@% IF Resp$ <> CHR$(13) THEN%@NL@% PRINT%@NL@% INPUT "x-coordinate of upper-left corner: ", WL%@NL@% DO%@NL@% INPUT "x-coordinate of lower-right corner: ", WR%@NL@% IF WR <= WL THEN%@NL@% PRINT "Right corner must be greater than left corner."%@NL@% END IF%@NL@% LOOP WHILE WR <= WL%@NL@% INPUT "y-coordinate of upper-left corner: ", WT%@NL@% DO%@NL@% INPUT "y-coordinate of lower-right corner: ", WB%@NL@% IF WB >= WT THEN%@NL@% PRINT "Bottom corner must be less than top corner."%@NL@% END IF%@NL@% LOOP WHILE WB >= WT%@NL@% %@NL@% %@AB@% ' User pressed ENTER, so set default values:%@AE@%%@NL@% ELSE%@NL@% WL = -1000%@NL@% WR = 250%@NL@% WT = 625%@NL@% WB = -625%@NL@% END IF%@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%MATB.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MATB.BAS%@AE@%%@NL@% %@NL@% %@AB@%'*** MATB.BAS - Matrix Math Routines for the Matrix Math Toolbox in%@AE@%%@NL@% %@AB@%' Microsoft BASIC 7.0, Professional Development System%@AE@%%@NL@% %@AB@%' Copyright (C) 1987-1989, Microsoft Corporation%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' NOTE: This sample source code toolbox is intended to demonstrate some%@AE@%%@NL@% %@AB@%' of the extended capabilities of Microsoft BASIC 7.0 Professional Development%@AE@%%@NL@% %@AB@%' system that can help to leverage the professional developer's time more%@AE@%%@NL@% %@AB@%' effectively. While you are free to use, modify, or distribute the routines%@AE@%%@NL@% %@AB@%' in this module in any way you find useful, it should be noted that these are%@AE@%%@NL@% %@AB@%' examples only and should not be relied upon as a fully-tested "add-on"%@AE@%%@NL@% %@AB@%' library.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Purpose:%@AE@%%@NL@% %@AB@%'This toolbox contains routines which perform elementary operations on systems%@AE@%%@NL@% %@AB@%'of linear equations represented as matrices. The functions return integer%@AE@%%@NL@% %@AB@%'error codes in the name and results in the parameter list. The functions%@AE@%%@NL@% %@AB@%'matbs?% and matlu?% found in this module are intended for internal use only.%@AE@%%@NL@% %@AB@%'Error codes returned:%@AE@%%@NL@% %@AB@%' 0 no error -1 matrix not invertible%@AE@%%@NL@% %@AB@%' -2 matrix not square -3 inner dimensions different%@AE@%%@NL@% %@AB@%' -4 matrix dimensions different -5 result matrix dimensioned incorrectly%@AE@%%@NL@% %@AB@%' any other codes returned are standard BASIC errors%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'-------------------------------------------------------------------%@AE@%%@NL@% %@AB@%'MatDet, MatSEqn, and MatInv all use LU-decomposition to implement Gaussian%@AE@%%@NL@% %@AB@%'elimination. A brief explanation of what is meant by an LU matrix is given%@AE@%%@NL@% %@AB@%'below, followed by simplified versions of the two internal routines used to%@AE@%%@NL@% %@AB@%'do all elimination.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'What is meant by an LU matrix:%@AE@%%@NL@% %@AB@%'An upper triangle matrix (one with all nonzero entries on or above the main%@AE@%%@NL@% %@AB@%'diagonal) can be solved immediately. The goal of Gaussian elimination is to%@AE@%%@NL@% %@AB@%'transform a non upper triangle system into an equivalent triangular one.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Given a system of equations represented in matrix form by Ax=b, we need a%@AE@%%@NL@% %@AB@%'linear transformation L such that LA=U where U is and upper triangular matrix.%@AE@%%@NL@% %@AB@%'Then Ux=LAx=Lb and Ux=Lb is an upper triangular system.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'This library explicitly calculates U, but L is never saved in its own array.%@AE@%%@NL@% %@AB@%'When we do a row operation to create a zero below the main diagonal, we no%@AE@%%@NL@% %@AB@%'longer need to save that value because we know it is zero. This leaves the%@AE@%%@NL@% %@AB@%'space available to save the multiplier used in the row operation. When%@AE@%%@NL@% %@AB@%'elimination is completed (ie, when the matrix is upper triangular), these%@AE@%%@NL@% %@AB@%'multipliers give us a complete record of what we did to A to make it upper%@AE@%%@NL@% %@AB@%'triangular. This is equivalent to saying the multipliers represent L. We now%@AE@%%@NL@% %@AB@%'have a U and an L stored in the same matrix! This type of matrix will be%@AE@%%@NL@% %@AB@%'referred to as an LU matrix, or just LU.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'The following code fragments get LU and backsolve Ux=Lb. The actual routines%@AE@%%@NL@% %@AB@%'used in the toolbox are much more involved because they implement total%@AE@%%@NL@% %@AB@%'pivoting and implicit row scaling to reduce round off errors. However, all the%@AE@%%@NL@% %@AB@%'extras (pivoting, scaling, error checking) are extraneous to the main routines,%@AE@%%@NL@% %@AB@%'which total only 20 lines. If you are unfamilar with this type of matrix math,%@AE@%%@NL@% %@AB@%'gaining an understanding of these 20 lines is a very good introduction. Try%@AE@%%@NL@% %@AB@%'working through a 2x2 or 3x3 example by hand to see what is happening. The%@AE@%%@NL@% %@AB@%'numerical techniques used to reduce round off error will not be discussed.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'-------------------------------------------------------------------%@AE@%%@NL@% %@AB@%'Given the coefficient matrix A(1 TO N, 1 TO N) and the vector b(1 TO N),%@AE@%%@NL@% %@AB@%'the following fragments will find x(1 TO N) satisfying Ax=b using Gaussian%@AE@%%@NL@% %@AB@%'elimination.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'matlu:%@AE@%%@NL@% %@AB@%'Perform row operations to get all zeroes below the main diagonal.%@AE@%%@NL@% %@AB@%'Define Rj(1 TO N) to be the vector corresponding to the jth row of A.%@AE@%%@NL@% %@AB@%'Let Rrow = Rrow + m*Rpvt where m = -Rrow(pvt)/Rpvt(pvt).%@AE@%%@NL@% %@AB@%'Then A(row, pvt)=0.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'** FOR pvt = 1 TO (N - 1)%@AE@%%@NL@% %@AB@%'** FOR row = (pvt + 1) TO N%@AE@%%@NL@% %@AB@%'** 'Save m for later use in the space just made 0.%@AE@%%@NL@% %@AB@%'** A(row, pvt) = -A(row, pvt) / A(pvt, pvt)%@AE@%%@NL@% %@AB@%'** 'Do the row operation.%@AE@%%@NL@% %@AB@%'** FOR col = (pvt + 1) TO N%@AE@%%@NL@% %@AB@%'** A(row, col) = A(row, col) + A(row, pvt) * A(pvt, col)%@AE@%%@NL@% %@AB@%'** NEXT col%@AE@%%@NL@% %@AB@%'** NEXT row%@AE@%%@NL@% %@AB@%'** NEXT pvt%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'matbs:%@AE@%%@NL@% %@AB@%'Do the same row operations on b using the multipliers saved in A.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'** FOR pvt = 1 TO (N - 1)%@AE@%%@NL@% %@AB@%'** FOR row = (pvt + 1) TO N%@AE@%%@NL@% %@AB@%'** b(row) = b(row) + A(row, pvt) * b(pvt)%@AE@%%@NL@% %@AB@%'** NEXT row%@AE@%%@NL@% %@AB@%'** NEXT pvt%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Backsolve Ux=Lb to find x.%@AE@%%@NL@% %@AB@%' N%@AE@%%@NL@% %@AB@%'For r = N to 1, x(r) = [b(r) - Σ (A(r,c)*x(c))]/A(r,r)%@AE@%%@NL@% %@AB@%' c=r+1%@AE@%%@NL@% %@AB@%'** FOR row = N TO 1 STEP -1%@AE@%%@NL@% %@AB@%'** x(row) = b(row)%@AE@%%@NL@% %@AB@%'** FOR col = (row + 1) TO N%@AE@%%@NL@% %@AB@%'** x(row) = x(row) - A(row, col) * x(col)%@AE@%%@NL@% %@AB@%'** NEXT col%@AE@%%@NL@% %@AB@%'** x(row) = x(row) / A(row, row)%@AE@%%@NL@% %@AB@%'** NEXT row%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% %@AB@%'$INCLUDE: 'matb.bi'%@AE@%%@NL@% DECLARE FUNCTION matbsD% (A() AS DOUBLE, b() AS DOUBLE, x() AS DOUBLE)%@NL@% DECLARE FUNCTION matbsS% (A() AS SINGLE, b() AS SINGLE, x() AS SINGLE)%@NL@% DECLARE FUNCTION matluD% (A() AS DOUBLE)%@NL@% DECLARE FUNCTION matluS% (A() AS SINGLE)%@NL@% DIM SHARED lo AS INTEGER, up AS INTEGER%@NL@% DIM SHARED continue AS INTEGER, count AS INTEGER%@NL@% DIM SHARED rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER%@NL@% END%@NL@% %@NL@% %@AB@%'=======================MatAddC%====================================%@AE@%%@NL@% %@AB@%'MatAddC% adds two currency type matrices and places the sum in%@AE@%%@NL@% %@AB@%'the first.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Alpha() = Alpha() + Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatAddC% (Alpha() AS CURRENCY, Beta() AS CURRENCY)%@NL@% ON LOCAL ERROR GOTO cadderr: MatAddC% = 0%@NL@% %@AB@%'check if Alpha, Beta have same dimensions if not, exit and send back error%@AE@%%@NL@% IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta, 1)) OR (LBOUND(Alpha, 2) <> LBOUND(Beta, 2)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 2)) THEN ERROR 196%@NL@% %@AB@%'loop through and add elements%@AE@%%@NL@% FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)%@NL@% FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Alpha(row%, col%) = Alpha(row%, col%) + Beta(row%, col%)%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% caddexit:%@NL@% EXIT FUNCTION%@NL@% cadderr:%@NL@% MatAddC% = (ERR + 5) MOD 200 - 5%@NL@% RESUME caddexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatAddD%====================================%@AE@%%@NL@% %@AB@%'MatAddD% adds two double precision matrices and places the sum in%@AE@%%@NL@% %@AB@%'the first.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Alpha() = Alpha() + Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatAddD% (Alpha() AS DOUBLE, Beta() AS DOUBLE)%@NL@% ON LOCAL ERROR GOTO dadderr: MatAddD% = 0%@NL@% %@AB@%'check if Alpha, Beta have same dimensions if not, exit and send back error%@AE@%%@NL@% IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta, 1)) OR (LBOUND(Alpha, 2) <> LBOUND(Beta, 2)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 2)) THEN ERROR 196%@NL@% %@AB@%'loop through and add elements%@AE@%%@NL@% FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)%@NL@% FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Alpha(row%, col%) = Alpha(row%, col%) + Beta(row%, col%)%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% daddexit:%@NL@% EXIT FUNCTION%@NL@% dadderr:%@NL@% MatAddD% = (ERR + 5) MOD 200 - 5%@NL@% RESUME daddexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatAddI%====================================%@AE@%%@NL@% %@AB@%'MatAddI% adds two integer matrices and places the sum in%@AE@%%@NL@% %@AB@%'the first.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Alpha() = Alpha() + Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatAddI% (Alpha() AS INTEGER, Beta() AS INTEGER)%@NL@% ON LOCAL ERROR GOTO iadderr: MatAddI% = 0%@NL@% %@AB@%'check if Alpha, Beta have same dimensions if not, exit and send back error%@AE@%%@NL@% IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta, 1)) OR (LBOUND(Alpha, 2) <> LBOUND(Beta, 2)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 2)) THEN ERROR 196%@NL@% %@AB@%'loop through and add elements%@AE@%%@NL@% FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)%@NL@% FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Alpha(row%, col%) = Alpha(row%, col%) + Beta(row%, col%)%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% iaddexit:%@NL@% EXIT FUNCTION%@NL@% iadderr:%@NL@% MatAddI% = (ERR + 5) MOD 200 - 5%@NL@% RESUME iaddexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatAddL%====================================%@AE@%%@NL@% %@AB@%'MatAddL% adds two long integer matrices and places the sum in%@AE@%%@NL@% %@AB@%'the first.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Alpha() = Alpha() + Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatAddL% (Alpha() AS LONG, Beta() AS LONG)%@NL@% ON LOCAL ERROR GOTO ladderr: MatAddL% = 0%@NL@% %@AB@%'check if Alpha, Beta have same dimensions if not, exit and send back error%@AE@%%@NL@% IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta, 1)) OR (LBOUND(Alpha, 2) <> LBOUND(Beta, 2)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 2)) THEN ERROR 196%@NL@% %@AB@%'loop through and add elements%@AE@%%@NL@% FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)%@NL@% FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Alpha(row%, col%) = Alpha(row%, col%) + Beta(row%, col%)%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% laddexit:%@NL@% EXIT FUNCTION%@NL@% ladderr:%@NL@% MatAddL% = (ERR + 5) MOD 200 - 5%@NL@% RESUME laddexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatAddS%====================================%@AE@%%@NL@% %@AB@%'MatAddS% adds two single precision matrices and places the sum in%@AE@%%@NL@% %@AB@%'the first.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Alpha() = Alpha() + Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatAddS% (Alpha() AS SINGLE, Beta() AS SINGLE)%@NL@% ON LOCAL ERROR GOTO sadderr: MatAddS% = 0%@NL@% %@AB@%'check if Alpha, Beta have same dimensions if not, exit and send back error%@AE@%%@NL@% IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta, 1)) OR (LBOUND(Alpha, 2) <> LBOUND(Beta, 2)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 2)) THEN ERROR 196%@NL@% %@AB@%'loop through and add elements%@AE@%%@NL@% FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)%@NL@% FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Alpha(row%, col%) = Alpha(row%, col%) + Beta(row%, col%)%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% saddexit:%@NL@% EXIT FUNCTION%@NL@% sadderr:%@NL@% MatAddS% = (ERR + 5) MOD 200 - 5%@NL@% RESUME saddexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================matbsD=====================================%@AE@%%@NL@% %@AB@%'matbsD% takes a matrix in LU form, found by matluD%, and a vector b%@AE@%%@NL@% %@AB@%'and solves the system Ux=Lb for x. matrices A,b,x are double precision.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: LU matrix in A, corresponding pivot vectors in rpvt and cpvt,%@AE@%%@NL@% %@AB@%' right side in b%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: solution in x, b is modified, rest unchanged%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION matbsD% (A() AS DOUBLE, b() AS DOUBLE, x() AS DOUBLE)%@NL@% ON LOCAL ERROR GOTO dbserr: matbsD% = 0%@NL@% %@AB@%'do row operations on b using the multipliers in L to find Lb%@AE@%%@NL@% FOR pvt% = lo TO (up - 1)%@NL@% c% = cpvt(pvt%)%@NL@% FOR row% = (pvt% + 1) TO up%@NL@% r% = rpvt(row%)%@NL@% b(r%) = b(r%) + A(r%, c%) * b(rpvt(pvt%))%@NL@% NEXT row%%@NL@% NEXT pvt%%@NL@% %@AB@%'backsolve Ux=Lb to find x%@AE@%%@NL@% FOR row% = up TO lo STEP -1%@NL@% c% = cpvt(row%)%@NL@% r% = rpvt(row%)%@NL@% x(c%) = b(r%)%@NL@% FOR col% = (row% + 1) TO up%@NL@% x(c%) = x(c%) - A(r%, cpvt(col%)) * x(cpvt(col%))%@NL@% NEXT col%%@NL@% x(c%) = x(c%) / A(r%, c%)%@NL@% NEXT row%%@NL@% dbsexit:%@NL@% EXIT FUNCTION%@NL@% dbserr:%@NL@% matbsD% = ERR%@NL@% RESUME dbsexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================matbsS=====================================%@AE@%%@NL@% %@AB@%'matbsS% takes a matrix in LU form, found by matluS%, and a vector b%@AE@%%@NL@% %@AB@%'and solves the system Ux=Lb for x. matrices A,b,x are single precision.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: LU matrix in A, corresponding pivot vectors in rpvt and cpvt,%@AE@%%@NL@% %@AB@%' right side in b%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: solution in x, b is modified, rest unchanged%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION matbsS% (A() AS SINGLE, b() AS SINGLE, x() AS SINGLE)%@NL@% ON LOCAL ERROR GOTO sbserr: matbsS% = 0%@NL@% %@AB@%'do row operations on b using the multipliers in L to find Lb%@AE@%%@NL@% FOR pvt% = lo TO (up - 1)%@NL@% c% = cpvt(pvt%)%@NL@% FOR row% = (pvt% + 1) TO up%@NL@% r% = rpvt(row%)%@NL@% b(r%) = b(r%) + A(r%, c%) * b(rpvt(pvt%))%@NL@% NEXT row%%@NL@% NEXT pvt%%@NL@% %@AB@%'backsolve Ux=Lb to find x%@AE@%%@NL@% FOR row% = up TO lo STEP -1%@NL@% c% = cpvt(row%)%@NL@% r% = rpvt(row%)%@NL@% x(c%) = b(r%)%@NL@% FOR col% = (row% + 1) TO up%@NL@% x(c%) = x(c%) - A(r%, cpvt(col%)) * x(cpvt(col%))%@NL@% NEXT col%%@NL@% x(c%) = x(c%) / A(r%, c%)%@NL@% NEXT row%%@NL@% sbsexit:%@NL@% EXIT FUNCTION%@NL@% sbserr:%@NL@% matbsS% = ERR%@NL@% RESUME sbsexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================MatDetC%===================================%@AE@%%@NL@% %@AB@%'MatDetC% finds the determinant of a square, currency type matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) matrix, det@ to return the determinant%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: matrix A in LU form, determinant%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatDetC% (A() AS CURRENCY, det@)%@NL@% ON LOCAL ERROR GOTO cdeterr: errcode% = 0%@NL@% lo = LBOUND(A, 1)%@NL@% up = UBOUND(A, 1)%@NL@% REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER%@NL@% %@AB@%'make temporary double precision matrix to find pivots%@AE@%%@NL@% DIM Tmp(lo TO up, LBOUND(A, 2) TO UBOUND(A, 2)) AS DOUBLE%@NL@% FOR row% = lo TO up%@NL@% FOR col% = LBOUND(A, 2) TO UBOUND(A, 2)%@NL@% Tmp(row%, col%) = CDBL(A(row%, col%))%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% errcode% = matluD%(Tmp()) 'Get LU matrix%@NL@% IF NOT continue THEN%@NL@% IF errcode% = 199 THEN det@ = 0@%@NL@% ERROR errcode%%@NL@% ELSE%@NL@% detD# = 1# '+/- determinant = product of the pivots%@NL@% FOR pvt% = lo TO up%@NL@% detD# = detD# * Tmp(rpvt(pvt%), cpvt(pvt%))%@NL@% NEXT pvt% 'count contains the total number of row%@NL@% det@ = (-1@) ^ count * CCUR(detD#) 'and column switches due to pivoting.%@NL@% IF errcode% THEN ERROR errcode% 'multiply the determinant by -1 for%@NL@% END IF 'each switch.%@NL@% cdetexit:%@NL@% ERASE rpvt, cpvt, Tmp%@NL@% MatDetC% = errcode%%@NL@% EXIT FUNCTION%@NL@% cdeterr:%@NL@% errcode% = (ERR + 5) MOD 200 - 5%@NL@% RESUME cdetexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================MatDetD%===================================%@AE@%%@NL@% %@AB@%'MatDetD% finds the determinant of a square, double precision matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) matrix, det# to return the determinant%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: matrix A in LU form, determinant%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatDetD% (A() AS DOUBLE, det#)%@NL@% ON LOCAL ERROR GOTO ddeterr: errcode% = 0%@NL@% lo = LBOUND(A, 1)%@NL@% up = UBOUND(A, 1)%@NL@% REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER%@NL@% errcode% = matluD%(A()) 'Get LU matrix%@NL@% IF NOT continue THEN%@NL@% IF errcode% = 199 THEN det# = 0#%@NL@% ERROR errcode%%@NL@% ELSE%@NL@% det# = 1# '+/- determinant = product of the pivots%@NL@% FOR pvt% = lo TO up%@NL@% det# = det# * A(rpvt(pvt%), cpvt(pvt%))%@NL@% NEXT pvt% 'count contains the total number of row%@NL@% det# = (-1) ^ count * det# 'and column switches due to pivoting.%@NL@% IF errcode% THEN ERROR errcode% 'multiply the determinant by -1 for%@NL@% END IF 'each switch%@NL@% ddetexit:%@NL@% ERASE rpvt, cpvt%@NL@% MatDetD% = errcode%%@NL@% EXIT FUNCTION%@NL@% ddeterr:%@NL@% errcode% = (ERR + 5) MOD 200 - 5%@NL@% RESUME ddetexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================MatDetI%===================================%@AE@%%@NL@% %@AB@%'MatDetI% finds the determinant of a square, integer matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) matrix, det% to return the determinant%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: matrix A unchanged, determinant%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatDetI% (A() AS INTEGER, det%)%@NL@% ON LOCAL ERROR GOTO ideterr: errcode% = 0%@NL@% lo = LBOUND(A, 1)%@NL@% up = UBOUND(A, 1)%@NL@% REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER%@NL@% %@AB@%'make temporary single precision matrix to find pivots%@AE@%%@NL@% DIM Tmp(lo TO up, LBOUND(A, 2) TO UBOUND(A, 2)) AS SINGLE%@NL@% FOR row% = lo TO up%@NL@% FOR col% = LBOUND(A, 2) TO UBOUND(A, 2)%@NL@% Tmp(row%, col%) = CSNG(A(row%, col%))%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% errcode% = matluS%(Tmp()) 'Get LU matrix%@NL@% IF NOT continue THEN%@NL@% IF errcode% = 199 THEN det% = 0%@NL@% ERROR errcode%%@NL@% ELSE%@NL@% detS! = 1! '+/- determinant = product of the pivots%@NL@% FOR pvt% = lo TO up%@NL@% detS! = detS! * Tmp(rpvt(pvt%), cpvt(pvt%))%@NL@% NEXT pvt% 'count contains the total number of row%@NL@% det% = (-1) ^ count * CINT(detS!) 'and column switches due to pivoting.%@NL@% IF errcode% THEN ERROR errcode% 'multiply the determinant by -1 for%@NL@% END IF 'each switch%@NL@% idetexit:%@NL@% ERASE rpvt, cpvt, Tmp%@NL@% MatDetI% = errcode%%@NL@% EXIT FUNCTION%@NL@% ideterr:%@NL@% errcode% = (ERR + 5) MOD 200 - 5%@NL@% RESUME idetexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================MatDetL%===================================%@AE@%%@NL@% %@AB@%'MatDetL% finds the determinant of a square, long integer matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) matrix, det& to return the determinant%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: matrix A unchanged, determinant%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatDetL% (A() AS LONG, det&)%@NL@% ON LOCAL ERROR GOTO ldeterr: errcode% = 0%@NL@% lo = LBOUND(A, 1)%@NL@% up = UBOUND(A, 1)%@NL@% REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER%@NL@% %@AB@%'make temporary double precision matrix to find pivots%@AE@%%@NL@% DIM Tmp(lo TO up, LBOUND(A, 2) TO UBOUND(A, 2)) AS DOUBLE%@NL@% FOR row% = lo TO up%@NL@% FOR col% = LBOUND(A, 2) TO UBOUND(A, 2)%@NL@% Tmp(row%, col%) = CDBL(A(row%, col%))%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% errcode% = matluD%(Tmp()) 'Get LU matrix%@NL@% IF NOT continue THEN%@NL@% IF errcode% = 199 THEN det& = 0&%@NL@% ERROR errcode%%@NL@% ELSE%@NL@% detD# = 1# '+/- determinant = product of the pivots%@NL@% FOR pvt% = lo TO up%@NL@% detD# = detD# * Tmp(rpvt(pvt%), cpvt(pvt%))%@NL@% NEXT pvt% 'count contains the total number of row%@NL@% det& = (-1&) ^ count * CLNG(detD#) 'and column switches due to pivoting.%@NL@% IF errcode% THEN ERROR errcode% 'multiply the determinant by -1 for%@NL@% END IF 'each switch%@NL@% ldetexit:%@NL@% ERASE rpvt, cpvt, Tmp%@NL@% MatDetL% = errcode%%@NL@% EXIT FUNCTION%@NL@% ldeterr:%@NL@% errcode% = (ERR + 5) MOD 200 - 5%@NL@% RESUME ldetexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================MatDetS%===================================%@AE@%%@NL@% %@AB@%'MatDetS% finds the determinant of a square, single precision matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) matrix, det! to return the determinant%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: matrix A in LU form, determinant%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatDetS% (A() AS SINGLE, det!)%@NL@% ON LOCAL ERROR GOTO sdeterr: errcode% = 0%@NL@% lo = LBOUND(A, 1)%@NL@% up = UBOUND(A, 1)%@NL@% REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER%@NL@% errcode% = matluS%(A()) 'Get LU matrix%@NL@% IF NOT continue THEN%@NL@% IF errcode% = 199 THEN det! = 0!%@NL@% ERROR errcode%%@NL@% ELSE%@NL@% det! = 1! '+/- determinant = product of the pivots%@NL@% FOR pvt% = lo TO up%@NL@% det! = det! * A(rpvt(pvt%), cpvt(pvt%))%@NL@% NEXT pvt% 'count contains the total number of row%@NL@% det! = (-1) ^ count * det! 'and column switches due to pivoting.%@NL@% IF errcode% THEN ERROR errcode% 'multiply the determinant by -1 for%@NL@% END IF 'each switch%@NL@% sdetexit:%@NL@% ERASE rpvt, cpvt%@NL@% MatDetS% = errcode%%@NL@% EXIT FUNCTION%@NL@% sdeterr:%@NL@% errcode% = (ERR + 5) MOD 200 - 5%@NL@% RESUME sdetexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================MatInvC%===================================%@AE@%%@NL@% %@AB@%'MatInvC% uses the matluD% and matbsD procedures to invert a square, currency%@AE@%%@NL@% %@AB@%'type matrix. Let e(N) contain all zeroes except for the jth position, which%@AE@%%@NL@% %@AB@%'is 1. Then the jth column of A^-1 is x, where Ax=e.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: A^-1%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatInvC% (A() AS CURRENCY)%@NL@% ON LOCAL ERROR GOTO cinverr: errcode% = 0%@NL@% lo = LBOUND(A, 1)%@NL@% up = UBOUND(A, 1)%@NL@% REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER%@NL@% %@AB@%'duplicate A() in a double precision work matrix, Tmp()%@AE@%%@NL@% DIM Tmp(lo TO up, LBOUND(A, 2) TO UBOUND(A, 2)) AS DOUBLE%@NL@% DIM e(lo TO up) AS DOUBLE, x(lo TO up) AS DOUBLE%@NL@% FOR row% = lo TO up%@NL@% FOR col% = LBOUND(A, 2) TO UBOUND(A, 2)%@NL@% Tmp(row%, col%) = CDBL(A(row%, col%))%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% errcode% = matluD%(Tmp()) 'Put LU in Tmp%@NL@% IF NOT continue THEN ERROR errcode%%@NL@% FOR col% = lo TO up 'Find A^-1 one column at a time%@NL@% e(col%) = 1#%@NL@% bserrcode% = matbsD%(Tmp(), e(), x())%@NL@% IF bserrcode% THEN ERROR bserrcode%%@NL@% FOR row% = lo TO up%@NL@% A(row%, col%) = CCUR(x(row%)) 'Put the column into A%@NL@% e(row%) = 0#%@NL@% NEXT row%%@NL@% NEXT col%%@NL@% IF errcode% THEN ERROR errcode%%@NL@% cinvexit:%@NL@% ERASE Tmp, e, x, rpvt, cpvt%@NL@% MatInvC% = errcode%%@NL@% EXIT FUNCTION%@NL@% cinverr:%@NL@% errcode% = (ERR + 5) MOD 200 - 5%@NL@% RESUME cinvexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================MatInvD%===================================%@AE@%%@NL@% %@AB@%'MatInvD% uses the matluD% and matbsD procedures to invert a square, double%@AE@%%@NL@% %@AB@%'precision matrix. Let e(N) contain all zeroes except for the jth position,%@AE@%%@NL@% %@AB@%'which is 1. Then the jth column of A^-1 is x, where Ax=e.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: A^-1%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatInvD% (A() AS DOUBLE)%@NL@% ON LOCAL ERROR GOTO dinverr: errcode% = 0%@NL@% lo = LBOUND(A, 1)%@NL@% up = UBOUND(A, 1)%@NL@% DIM Ain(lo TO up, lo TO up) AS DOUBLE%@NL@% DIM e(lo TO up) AS DOUBLE, x(lo TO up) AS DOUBLE%@NL@% REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER%@NL@% errcode% = matluD%(A()) 'Get LU matrix%@NL@% IF NOT continue THEN ERROR errcode%%@NL@% FOR col% = lo TO up 'Find A^-1 one column at a time%@NL@% e(col%) = 1#%@NL@% bserrcode% = matbsD%(A(), e(), x())%@NL@% IF bserrcode% THEN ERROR bserrcode%%@NL@% FOR row% = lo TO up%@NL@% Ain(row%, col%) = x(row%)%@NL@% e(row%) = 0#%@NL@% NEXT row%%@NL@% NEXT col%%@NL@% FOR col% = lo TO up 'Put A^-1 in A%@NL@% FOR row% = lo TO up%@NL@% A(row%, col%) = Ain(row%, col%)%@NL@% NEXT row%%@NL@% NEXT col%%@NL@% IF errcode% THEN ERROR errcode%%@NL@% dinvexit:%@NL@% ERASE e, x, Ain, rpvt, cpvt%@NL@% MatInvD% = errcode%%@NL@% EXIT FUNCTION%@NL@% dinverr:%@NL@% errcode% = (ERR + 5) MOD 200 - 5%@NL@% RESUME dinvexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================MatInvS%===================================%@AE@%%@NL@% %@AB@%'MatInvS% uses the matluS% and matbsS procedures to invert a square, single%@AE@%%@NL@% %@AB@%'precision matrix. Let e(N) contain all zeroes except for the jth position,%@AE@%%@NL@% %@AB@%'which is 1. Then the jth column of A^-1 is x, where Ax=e.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: A^-1%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatInvS% (A() AS SINGLE)%@NL@% ON LOCAL ERROR GOTO sinverr: errcode% = 0%@NL@% lo = LBOUND(A, 1)%@NL@% up = UBOUND(A, 1)%@NL@% DIM Ain(lo TO up, lo TO up) AS SINGLE%@NL@% DIM e(lo TO up) AS SINGLE, x(lo TO up) AS SINGLE%@NL@% REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER%@NL@% errcode% = matluS%(A()) 'Get LU matrix%@NL@% IF NOT continue THEN ERROR errcode%%@NL@% FOR col% = lo TO up 'find A^-1 one column at a time%@NL@% e(col%) = 1!%@NL@% bserrcode% = matbsS%(A(), e(), x())%@NL@% IF bserrcode% THEN ERROR bserrcode%%@NL@% FOR row% = lo TO up%@NL@% Ain(row%, col%) = x(row%)%@NL@% e(row%) = 0!%@NL@% NEXT row%%@NL@% NEXT col%%@NL@% FOR col% = lo TO up 'put A^-1 in A%@NL@% FOR row% = lo TO up%@NL@% A(row%, col%) = Ain(row%, col%)%@NL@% NEXT row%%@NL@% NEXT col%%@NL@% IF errcode% THEN ERROR errcode%%@NL@% sinvexit:%@NL@% ERASE e, x, Ain, rpvt, cpvt%@NL@% MatInvS% = errcode%%@NL@% EXIT FUNCTION%@NL@% sinverr:%@NL@% errcode% = (ERR + 5) MOD 200 - 5%@NL@% RESUME sinvexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================matluD%====================================%@AE@%%@NL@% %@AB@%'matluD% does Gaussian elimination with total pivoting to put a square, double%@AE@%%@NL@% %@AB@%'precision matrix in LU form. The multipliers used in the row operations to%@AE@%%@NL@% %@AB@%'create zeroes below the main diagonal are saved in the zero spaces.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) matrix, rpvt(n) and cpvt(n) permutation vectors%@AE@%%@NL@% %@AB@%' used to index the row and column pivots%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: A in LU form with corresponding pivot vectors; the total number of%@AE@%%@NL@% %@AB@%' pivots in count, which is used to find the sign of the determinant.%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION matluD% (A() AS DOUBLE)%@NL@% ON LOCAL ERROR GOTO dluerr: errcode% = 0%@NL@% %@AB@%'Checks if A is square, returns error code if not%@AE@%%@NL@% IF NOT (lo = LBOUND(A, 2) AND up = UBOUND(A, 2)) THEN ERROR 198%@NL@% DIM rownorm(lo TO up) AS DOUBLE%@NL@% count = 0 'initialize count, continue%@NL@% continue = -1%@NL@% FOR row% = lo TO up 'initialize rpvt and cpvt%@NL@% rpvt(row%) = row%%@NL@% cpvt(row%) = row%%@NL@% rownorm(row%) = 0# 'find the row norms of A()%@NL@% FOR col% = lo TO up%@NL@% rownorm(row%) = rownorm(row%) + ABS(A(row%, col%))%@NL@% NEXT col%%@NL@% IF rownorm(row%) = 0# THEN 'if any rownorm is zero, the matrix%@NL@% continue = 0 'is singular, set error, exit and%@NL@% ERROR 199 'do not continue%@NL@% END IF%@NL@% NEXT row%%@NL@% FOR pvt% = lo TO (up - 1)%@NL@% %@AB@%'Find best available pivot%@AE@%%@NL@% max# = 0# 'checks all values in rows and columns not%@NL@% FOR row% = pvt% TO up 'already used for pivoting and saves the%@NL@% r% = rpvt(row%) 'largest absolute number and its position%@NL@% FOR col% = pvt% TO up%@NL@% c% = cpvt(col%)%@NL@% temp# = ABS(A(r%, c%)) / rownorm(r%)%@NL@% IF temp# > max# THEN%@NL@% max# = temp#%@NL@% bestrow% = row% 'save the position of new max#%@NL@% bestcol% = col%%@NL@% END IF%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% IF max# = 0# THEN 'if no nonzero number is found, A is%@NL@% continue = 0 'singular, send back error, do not continue%@NL@% ERROR 199%@NL@% ELSEIF pvt% > 1 THEN 'check if drop in pivots is too much%@NL@% IF max# < (deps# * oldmax#) THEN errcode% = 199%@NL@% END IF%@NL@% oldmax# = max#%@NL@% IF rpvt(pvt%) <> rpvt(bestrow%) THEN%@NL@% count = count + 1 'if a row or column pivot is%@NL@% SWAP rpvt(pvt%), rpvt(bestrow%) 'necessary, count it and permute%@NL@% END IF 'rpvt or cpvt. Note: the rows and%@NL@% IF cpvt(pvt%) <> cpvt(bestcol%) THEN 'columns are not actually switched,%@NL@% count = count + 1 'only the order in which they are%@NL@% SWAP cpvt(pvt%), cpvt(bestcol%) 'used.%@NL@% END IF%@NL@% %@AB@%'Eliminate all values below the pivot%@AE@%%@NL@% rp% = rpvt(pvt%)%@NL@% cp% = cpvt(pvt%)%@NL@% FOR row% = (pvt% + 1) TO up%@NL@% r% = rpvt(row%)%@NL@% A(r%, cp%) = -A(r%, cp%) / A(rp%, cp%) 'save multipliers%@NL@% FOR col% = (pvt% + 1) TO up%@NL@% c% = cpvt(col%) 'complete row operations%@NL@% A(r%, c%) = A(r%, c%) + A(r%, cp%) * A(rp%, c%)%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% NEXT pvt%%@NL@% IF A(rpvt(up), cpvt(up)) = 0# THEN%@NL@% continue = 0 'if last pivot is zero or pivot drop is%@NL@% ERROR 199 'too large, A is singular, send back error%@NL@% ELSEIF (ABS(A(rpvt(up), cpvt(up))) / rownorm(rpvt(up))) < (deps# * oldmax#) THEN%@NL@% errcode% = 199 'if pivot is not identically zero then%@NL@% END IF 'continue remains TRUE%@NL@% IF errcode% THEN ERROR errcode%%@NL@% dluexit:%@NL@% matluD% = errcode%%@NL@% EXIT FUNCTION%@NL@% dluerr:%@NL@% IF errcode% < 199 THEN continue = 0%@NL@% errcode% = ERR%@NL@% RESUME dluexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================matluS%====================================%@AE@%%@NL@% %@AB@%'matluS% does Gaussian elimination with total pivoting to put a square, single%@AE@%%@NL@% %@AB@%'precision matrix in LU form. The multipliers used in the row operations to%@AE@%%@NL@% %@AB@%'create zeroes below the main diagonal are saved in the zero spaces.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) matrix, rpvt(n) and cpvt(n) permutation vectors%@AE@%%@NL@% %@AB@%' used to index the row and column pivots%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: A in LU form with corresponding pivot vectors; the total number of%@AE@%%@NL@% %@AB@%' pivots in count, which is used to find the sign of the determinant.%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION matluS% (A() AS SINGLE)%@NL@% ON LOCAL ERROR GOTO sluerr: errcode% = 0%@NL@% %@AB@%'Checks if A is square, returns error code if not%@AE@%%@NL@% IF NOT (lo = LBOUND(A, 2) AND up = UBOUND(A, 2)) THEN ERROR 198%@NL@% DIM rownorm(lo TO up) AS SINGLE%@NL@% count = 0 'initialize count, continue%@NL@% continue = -1%@NL@% FOR row% = lo TO up 'initialize rpvt and cpvt%@NL@% rpvt(row%) = row%%@NL@% cpvt(row%) = row%%@NL@% rownorm(row%) = 0! 'find the row norms of A()%@NL@% FOR col% = lo TO up%@NL@% rownorm(row%) = rownorm(row%) + ABS(A(row%, col%))%@NL@% NEXT col%%@NL@% IF rownorm(row%) = 0! THEN 'if any rownorm is zero, the matrix%@NL@% continue = 0 'is singular, set error, exit and do%@NL@% ERROR 199 'not continue%@NL@% END IF%@NL@% NEXT row%%@NL@% FOR pvt% = lo TO (up - 1)%@NL@% %@AB@%'Find best available pivot%@AE@%%@NL@% max! = 0! 'checks all values in rows and columns not%@NL@% FOR row% = pvt% TO up 'already used for pivoting and finds the%@NL@% r% = rpvt(row%) 'number largest in absolute value relative%@NL@% FOR col% = pvt% TO up 'to its row norm%@NL@% c% = cpvt(col%)%@NL@% temp! = ABS(A(r%, c%)) / rownorm(r%)%@NL@% IF temp! > max! THEN%@NL@% max! = temp!%@NL@% bestrow% = row% 'save the position of new max!%@NL@% bestcol% = col%%@NL@% END IF%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% IF max! = 0! THEN 'if no nonzero number is found, A is%@NL@% continue = 0 'singular, send back error, do not continue%@NL@% ERROR 199%@NL@% ELSEIF pvt% > 1 THEN 'check if drop in pivots is too much%@NL@% IF max! < (seps! * oldmax!) THEN errcode% = 199%@NL@% END IF%@NL@% oldmax! = max!%@NL@% IF rpvt(pvt%) <> rpvt(bestrow%) THEN%@NL@% count = count + 1 'if a row or column pivot is%@NL@% SWAP rpvt(pvt%), rpvt(bestrow%) 'necessary, count it and permute%@NL@% END IF 'rpvt or cpvt. Note: the rows and%@NL@% IF cpvt(pvt%) <> cpvt(bestcol%) THEN 'columns are not actually switched,%@NL@% count = count + 1 'only the order in which they are%@NL@% SWAP cpvt(pvt%), cpvt(bestcol%) 'used.%@NL@% END IF%@NL@% %@AB@%'Eliminate all values below the pivot%@AE@%%@NL@% rp% = rpvt(pvt%)%@NL@% cp% = cpvt(pvt%)%@NL@% FOR row% = (pvt% + 1) TO up%@NL@% r% = rpvt(row%)%@NL@% A(r%, cp%) = -A(r%, cp%) / A(rp%, cp%) 'save multipliers%@NL@% FOR col% = (pvt% + 1) TO up%@NL@% c% = cpvt(col%) 'complete row operations%@NL@% A(r%, c%) = A(r%, c%) + A(r%, cp%) * A(rp%, c%)%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% NEXT pvt%%@NL@% IF A(rpvt(up), cpvt(up)) = 0! THEN%@NL@% continue = 0 'if last pivot is zero or pivot drop is%@NL@% ERROR 199 'too large, A is singular, send back error%@NL@% ELSEIF (ABS(A(rpvt(up), cpvt(up))) / rownorm(rpvt(up))) < (seps! * oldmax!) THEN%@NL@% errcode% = 199 'if pivot is not identically zero then%@NL@% END IF 'continue remains TRUE%@NL@% IF errcode% THEN ERROR errcode%%@NL@% sluexit:%@NL@% matluS% = errcode%%@NL@% EXIT FUNCTION%@NL@% sluerr:%@NL@% errcode% = ERR%@NL@% IF errcode% < 199 THEN continue = 0%@NL@% RESUME sluexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatMultC%===================================%@AE@%%@NL@% %@AB@%'MatMultC% multiplies two currency type matrices and places the%@AE@%%@NL@% %@AB@%'product in a result matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta,Gamma%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Gamma() = Alpha() * Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatMultC% (Alpha() AS CURRENCY, Beta() AS CURRENCY, Gamma() AS CURRENCY)%@NL@% ON LOCAL ERROR GOTO cmulterr: MatMultC% = 0%@NL@% IF (LBOUND(Alpha, 2) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 1)) THEN%@NL@% ERROR 197 'check inside dimensions%@NL@% ELSEIF (LBOUND(Alpha, 1) <> LBOUND(Gamma, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Gamma, 1)) OR (LBOUND(Beta, 2) <> LBOUND(Gamma, 2)) OR (UBOUND(Beta, 2) <> UBOUND(Gamma, 2)) THEN%@NL@% ERROR 195 'check dimensions of result matrix%@NL@% END IF%@NL@% %@AB@%'loop through, Gamma(row,col)=inner product of Alpha(row,*) and Beta(*,col)%@AE@%%@NL@% FOR row% = LBOUND(Gamma, 1) TO UBOUND(Gamma, 1)%@NL@% FOR col% = LBOUND(Gamma, 2) TO UBOUND(Gamma, 2)%@NL@% Gamma(row%, col%) = 0@%@NL@% FOR inside% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Gamma(row%, col%) = Gamma(row%, col%) + Alpha(row%, inside%) * Beta(inside%, col%)%@NL@% NEXT inside%%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% cmultexit:%@NL@% EXIT FUNCTION%@NL@% cmulterr:%@NL@% MatMultC% = (ERR + 5) MOD 200 - 5%@NL@% RESUME cmultexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatMultD%===================================%@AE@%%@NL@% %@AB@%'MatMultD% multiplies two double precision matrices and places the%@AE@%%@NL@% %@AB@%'product in a result matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta,Gamma%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Gamma() = Alpha() * Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatMultD% (Alpha() AS DOUBLE, Beta() AS DOUBLE, Gamma() AS DOUBLE)%@NL@% ON LOCAL ERROR GOTO dmulterr: MatMultD% = 0%@NL@% IF (LBOUND(Alpha, 2) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 1)) THEN%@NL@% ERROR 197 'check inside dimensions%@NL@% ELSEIF (LBOUND(Alpha, 1) <> LBOUND(Gamma, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Gamma, 1)) OR (LBOUND(Beta, 2) <> LBOUND(Gamma, 2)) OR (UBOUND(Beta, 2) <> UBOUND(Gamma, 2)) THEN%@NL@% ERROR 195 'check dimensions of result matrix%@NL@% END IF%@NL@% %@AB@%'loop through, Gamma(row,col)=inner product of Alpha(row,*) and Beta(*,col)%@AE@%%@NL@% FOR row% = LBOUND(Gamma, 1) TO UBOUND(Gamma, 1)%@NL@% FOR col% = LBOUND(Gamma, 2) TO UBOUND(Gamma, 2)%@NL@% Gamma(row%, col%) = 0#%@NL@% FOR inside% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Gamma(row%, col%) = Gamma(row%, col%) + Alpha(row%, inside%) * Beta(inside%, col%)%@NL@% NEXT inside%%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% dmultexit:%@NL@% EXIT FUNCTION%@NL@% dmulterr:%@NL@% MatMultD% = (ERR + 5) MOD 200 - 5%@NL@% RESUME dmultexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatMultI%===================================%@AE@%%@NL@% %@AB@%'MatMultI% multiplies two integer matrices and places the product in%@AE@%%@NL@% %@AB@%'a result matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta,Gamma%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Gamma() = Alpha() * Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatMultI% (Alpha() AS INTEGER, Beta() AS INTEGER, Gamma() AS INTEGER)%@NL@% ON LOCAL ERROR GOTO imulterr: MatMultI% = 0%@NL@% IF (LBOUND(Alpha, 2) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 1)) THEN%@NL@% ERROR 197 'check inside dimensions%@NL@% ELSEIF (LBOUND(Alpha, 1) <> LBOUND(Gamma, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Gamma, 1)) OR (LBOUND(Beta, 2) <> LBOUND(Gamma, 2)) OR (UBOUND(Beta, 2) <> UBOUND(Gamma, 2)) THEN%@NL@% ERROR 195 'check dimensions of result matrix%@NL@% END IF%@NL@% %@AB@%'loop through, Gamma(row,col)=inner product of Alpha(row,*) and Beta(*,col)%@AE@%%@NL@% FOR row% = LBOUND(Gamma, 1) TO UBOUND(Gamma, 1)%@NL@% FOR col% = LBOUND(Gamma, 2) TO UBOUND(Gamma, 2)%@NL@% Gamma(row%, col%) = 0%@NL@% FOR inside% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Gamma(row%, col%) = Gamma(row%, col%) + Alpha(row%, inside%) * Beta(inside%, col%)%@NL@% NEXT inside%%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% imultexit:%@NL@% EXIT FUNCTION%@NL@% imulterr:%@NL@% MatMultI% = (ERR + 5) MOD 200 - 5%@NL@% RESUME imultexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatMultL%===================================%@AE@%%@NL@% %@AB@%'MatMultL% multiplies two long integer matrices and places the product%@AE@%%@NL@% %@AB@%'in a result matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta,Gamma%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Gamma() = Alpha() * Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatMultL% (Alpha() AS LONG, Beta() AS LONG, Gamma() AS LONG)%@NL@% ON LOCAL ERROR GOTO lmulterr: MatMultL% = 0%@NL@% IF (LBOUND(Alpha, 2) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 1)) THEN%@NL@% ERROR 197 'check inside dimensions%@NL@% ELSEIF (LBOUND(Alpha, 1) <> LBOUND(Gamma, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Gamma, 1)) OR (LBOUND(Beta, 2) <> LBOUND(Gamma, 2)) OR (UBOUND(Beta, 2) <> UBOUND(Gamma, 2)) THEN%@NL@% ERROR 195 'check dimensions of result matrix%@NL@% END IF%@NL@% %@AB@%'loop through, Gamma(row,col)=inner product of Alpha(row,*) and Beta(*,col)%@AE@%%@NL@% FOR row% = LBOUND(Gamma, 1) TO UBOUND(Gamma, 1)%@NL@% FOR col% = LBOUND(Gamma, 2) TO UBOUND(Gamma, 2)%@NL@% Gamma(row%, col%) = 0&%@NL@% FOR inside% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Gamma(row%, col%) = Gamma(row%, col%) + Alpha(row%, inside%) * Beta(inside%, col%)%@NL@% NEXT inside%%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% lmultexit:%@NL@% EXIT FUNCTION%@NL@% lmulterr:%@NL@% MatMultL% = (ERR + 5) MOD 200 - 5%@NL@% RESUME lmultexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatMultS%===================================%@AE@%%@NL@% %@AB@%'MatMultS% multiplies two single precision matrices and places the%@AE@%%@NL@% %@AB@%'product in a result matrix%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta,Gamma%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Gamma() = Alpha() * Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatMultS% (Alpha() AS SINGLE, Beta() AS SINGLE, Gamma() AS SINGLE)%@NL@% ON LOCAL ERROR GOTO smulterr: MatMultS% = 0%@NL@% IF (LBOUND(Alpha, 2) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 1)) THEN%@NL@% ERROR 197 'check inside dimensions%@NL@% ELSEIF (LBOUND(Alpha, 1) <> LBOUND(Gamma, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Gamma, 1)) OR (LBOUND(Beta, 2) <> LBOUND(Gamma, 2)) OR (UBOUND(Beta, 2) <> UBOUND(Gamma, 2)) THEN%@NL@% ERROR 195 'check dimensions of result matrix%@NL@% END IF%@NL@% %@AB@%'loop through, Gamma(row,col)=inner product of Alpha(row,*) and Beta(*,col)%@AE@%%@NL@% FOR row% = LBOUND(Gamma, 1) TO UBOUND(Gamma, 1)%@NL@% FOR col% = LBOUND(Gamma, 2) TO UBOUND(Gamma, 2)%@NL@% Gamma(row%, col%) = 0!%@NL@% FOR inside% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Gamma(row%, col%) = Gamma(row%, col%) + Alpha(row%, inside%) * Beta(inside%, col%)%@NL@% NEXT inside%%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% smultexit:%@NL@% EXIT FUNCTION%@NL@% smulterr:%@NL@% MatMultS% = (ERR + 5) MOD 200 - 5%@NL@% RESUME smultexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================MatSEqnC%==================================%@AE@%%@NL@% %@AB@%'MatSEqnC% solves a system of n linear equations, Ax=b, and puts the%@AE@%%@NL@% %@AB@%'answer in b. A is first put in LU form by matluC%, then matbsC is called%@AE@%%@NL@% %@AB@%'to solve the system. matrices A,b are currency type.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) contains coefficient matrix, b(N) contains the right side%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: A in LU form, solution in b%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatSEqnC% (A() AS CURRENCY, b() AS CURRENCY)%@NL@% ON LOCAL ERROR GOTO cseqnerr: errcode% = 0%@NL@% lo = LBOUND(A, 1)%@NL@% up = UBOUND(A, 1)%@NL@% REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER%@NL@% %@AB@%'duplicate A(), b() in temporary double precision matrices Tmp(), btmp()%@AE@%%@NL@% DIM Tmp(lo TO up, LBOUND(A, 2) TO UBOUND(A, 2)) AS DOUBLE%@NL@% DIM x(lo TO up) AS DOUBLE, btmp(lo TO up) AS DOUBLE%@NL@% FOR row% = lo TO up%@NL@% FOR col% = LBOUND(A, 2) TO UBOUND(A, 2)%@NL@% Tmp(row%, col%) = CDBL(A(row%, col%))%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% errcode% = matluD%(Tmp()) 'Get LU matrix%@NL@% IF NOT continue THEN ERROR errcode%%@NL@% %@AB@%'check dimensions of b, make double precision copy if ok.%@AE@%%@NL@% IF (lo <> LBOUND(b)) OR (up <> UBOUND(b)) THEN ERROR 197%@NL@% FOR row% = lo TO up%@NL@% btmp(row%) = CDBL(b(row%))%@NL@% NEXT row%%@NL@% bserrcode% = matbsD%(Tmp(), btmp(), x()) 'Backsolve system%@NL@% IF bserrcode% THEN ERROR bserrcode%%@NL@% FOR row% = lo TO up%@NL@% b(row%) = CCUR(x(row%)) 'Put solution in b for return%@NL@% NEXT row%%@NL@% IF errcode% THEN ERROR errcode%%@NL@% cseqnexit:%@NL@% ERASE Tmp, btmp, x, rpvt, cpvt%@NL@% MatSEqnC% = errcode%%@NL@% EXIT FUNCTION%@NL@% cseqnerr:%@NL@% errcode% = (ERR + 5) MOD 200 - 5%@NL@% RESUME cseqnexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================MatSEqnD%==================================%@AE@%%@NL@% %@AB@%'MatSEqnD% solves a system of n linear equations, Ax=b, and puts the%@AE@%%@NL@% %@AB@%'answer in b. A is first put in LU form by matluD%, then matbsD is called%@AE@%%@NL@% %@AB@%'to solve the system. matrices A,b are double precision.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) contains coefficient matrix, b(N) contains the right side%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: A in LU form, solution in b%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatSEqnD% (A() AS DOUBLE, b() AS DOUBLE)%@NL@% ON LOCAL ERROR GOTO dseqnerr: errcode% = 0%@NL@% lo = LBOUND(A, 1)%@NL@% up = UBOUND(A, 1)%@NL@% DIM x(lo TO up) AS DOUBLE%@NL@% REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER%@NL@% errcode% = matluD%(A()) 'Get LU matrix%@NL@% IF NOT continue THEN ERROR errcode%%@NL@% %@AB@%'check dimensions of b%@AE@%%@NL@% IF (lo <> LBOUND(b)) OR (up <> UBOUND(b)) THEN ERROR 197%@NL@% bserrcode% = matbsD%(A(), b(), x()) 'Backsolve system%@NL@% IF bserrcode% THEN ERROR bserrcode%%@NL@% FOR row% = lo TO up%@NL@% b(row%) = x(row%) 'Put solution in b for return%@NL@% NEXT row%%@NL@% IF errcode% THEN ERROR errcode%%@NL@% dseqnexit:%@NL@% ERASE x, rpvt, cpvt%@NL@% MatSEqnD% = errcode%%@NL@% EXIT FUNCTION%@NL@% dseqnerr:%@NL@% errcode% = (ERR + 5) MOD 200 - 5%@NL@% RESUME dseqnexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'========================MatSEqnS%==================================%@AE@%%@NL@% %@AB@%'MatSEqnS% solves a system of n linear equations, Ax=b, and puts the%@AE@%%@NL@% %@AB@%'answer in b. A is first put in LU form by matluS%, then matbsS is called%@AE@%%@NL@% %@AB@%'to solve the system. matrices A,b are single precision.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: A(n x n) contains coefficient matrix, b(N) contains the right side%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: A in LU form, solution in b%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatSEqnS% (A() AS SINGLE, b() AS SINGLE)%@NL@% ON LOCAL ERROR GOTO sseqnerr: errcode% = 0%@NL@% lo = LBOUND(A, 1)%@NL@% up = UBOUND(A, 1)%@NL@% DIM x(lo TO up) AS SINGLE%@NL@% REDIM rpvt(lo TO up) AS INTEGER, cpvt(lo TO up) AS INTEGER%@NL@% errcode% = matluS%(A()) 'Get LU matrix%@NL@% IF NOT continue THEN ERROR errcode%%@NL@% %@AB@%'check dimensions of b%@AE@%%@NL@% IF (lo <> LBOUND(b)) OR (up <> UBOUND(b)) THEN ERROR 197%@NL@% bserrcode% = matbsS%(A(), b(), x()) 'Backsolve system%@NL@% IF bserrcode% THEN ERROR bserrcode%%@NL@% FOR row% = lo TO up%@NL@% b(row%) = x(row%) 'Put solution in b for return%@NL@% NEXT row%%@NL@% IF errcode% THEN ERROR errcode%%@NL@% sseqnexit:%@NL@% ERASE x, rpvt, cpvt%@NL@% MatSEqnS% = errcode%%@NL@% EXIT FUNCTION%@NL@% sseqnerr:%@NL@% errcode% = (ERR + 5) MOD 200 - 5%@NL@% RESUME sseqnexit%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatSubC%====================================%@AE@%%@NL@% %@AB@%'MatSubC% takes the difference of two currency type matrices and%@AE@%%@NL@% %@AB@%'places the result in the first.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Params: matrices Alpha,Beta%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Alpha=Alpha-Beta%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatSubC% (Alpha() AS CURRENCY, Beta() AS CURRENCY)%@NL@% ON LOCAL ERROR GOTO csuberr: MatSubC% = 0%@NL@% %@AB@%'check if Alpha, Beta have same dimensions if not, exit and send back error%@AE@%%@NL@% IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta, 1)) OR (LBOUND(Alpha, 2) <> LBOUND(Beta, 2)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 2)) THEN ERROR 196%@NL@% %@AB@%'loop through and subtract elements%@AE@%%@NL@% FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)%@NL@% FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Alpha(row%, col%) = Alpha(row%, col%) - Beta(row%, col%)%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% csubexit:%@NL@% EXIT FUNCTION%@NL@% csuberr:%@NL@% MatSubC% = (ERR + 5) MOD 200 - 5%@NL@% RESUME csubexit:%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatSubD%====================================%@AE@%%@NL@% %@AB@%'MatSubD% takes the difference of two double precision matrices and%@AE@%%@NL@% %@AB@%'places the result in the first.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Alpha() = Alpha() - Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatSubD% (Alpha() AS DOUBLE, Beta() AS DOUBLE)%@NL@% ON LOCAL ERROR GOTO dsuberr: MatSubD% = 0%@NL@% %@AB@%'check if Alpha, Beta have same dimensions if not, exit and send back error%@AE@%%@NL@% IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta, 1)) OR (LBOUND(Alpha, 2) <> LBOUND(Beta, 2)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 2)) THEN ERROR 196%@NL@% %@AB@%'loop through and subtract elements%@AE@%%@NL@% FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)%@NL@% FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Alpha(row%, col%) = Alpha(row%, col%) - Beta(row%, col%)%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% dsubexit:%@NL@% EXIT FUNCTION%@NL@% dsuberr:%@NL@% MatSubD% = (ERR + 5) MOD 200 - 5%@NL@% RESUME dsubexit:%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatSubI%====================================%@AE@%%@NL@% %@AB@%'MatSubI% takes the difference of two integer matrices and places the%@AE@%%@NL@% %@AB@%'result in the first.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Alpha() = Alpha() - Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatSubI% (Alpha() AS INTEGER, Beta() AS INTEGER)%@NL@% ON LOCAL ERROR GOTO isuberr: MatSubI% = 0%@NL@% %@AB@%'check if Alpha, Beta have same dimensions if not, exit and send back error%@AE@%%@NL@% IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta, 1)) OR (LBOUND(Alpha, 2) <> LBOUND(Beta, 2)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 2)) THEN ERROR 196%@NL@% %@AB@%'loop through and subtract elements%@AE@%%@NL@% FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)%@NL@% FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Alpha(row%, col%) = Alpha(row%, col%) - Beta(row%, col%)%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% isubexit:%@NL@% EXIT FUNCTION%@NL@% isuberr:%@NL@% MatSubI% = (ERR + 5) MOD 200 - 5%@NL@% RESUME isubexit:%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatSubL%====================================%@AE@%%@NL@% %@AB@%'MatSubL% takes the difference of two long integer matrices and places%@AE@%%@NL@% %@AB@%'the result in the first.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Alpha() = Alpha() - Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatSubL% (Alpha() AS LONG, Beta() AS LONG)%@NL@% ON LOCAL ERROR GOTO lsuberr: MatSubL% = 0%@NL@% %@AB@%'check if Alpha, Beta have same dimensions if not, exit and send back error%@AE@%%@NL@% IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta, 1)) OR (LBOUND(Alpha, 2) <> LBOUND(Beta, 2)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 2)) THEN ERROR 196%@NL@% %@AB@%'loop through and subtract elements%@AE@%%@NL@% FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)%@NL@% FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Alpha(row%, col%) = Alpha(row%, col%) - Beta(row%, col%)%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% lsubexit:%@NL@% EXIT FUNCTION%@NL@% lsuberr:%@NL@% MatSubL% = (ERR + 5) MOD 200 - 5%@NL@% RESUME lsubexit:%@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'=======================MatSubS%====================================%@AE@%%@NL@% %@AB@%'MatSubS% takes the difference of two single precision matrices and%@AE@%%@NL@% %@AB@%'places the result in the first.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Parameters: matrices Alpha,Beta%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'Returns: Alpha() = Alpha() - Beta()%@AE@%%@NL@% %@AB@%'===================================================================%@AE@%%@NL@% FUNCTION MatSubS% (Alpha() AS SINGLE, Beta() AS SINGLE)%@NL@% ON LOCAL ERROR GOTO ssuberr: MatSubS% = 0%@NL@% %@AB@%'check if Alpha, Beta have same dimensions if not, exit and send back error%@AE@%%@NL@% IF (LBOUND(Alpha, 1) <> LBOUND(Beta, 1)) OR (UBOUND(Alpha, 1) <> UBOUND(Beta, 1)) OR (LBOUND(Alpha, 2) <> LBOUND(Beta, 2)) OR (UBOUND(Alpha, 2) <> UBOUND(Beta, 2)) THEN ERROR 196%@NL@% %@AB@%'loop through and subtract elements%@AE@%%@NL@% FOR row% = LBOUND(Alpha, 1) TO UBOUND(Alpha, 1)%@NL@% FOR col% = LBOUND(Alpha, 2) TO UBOUND(Alpha, 2)%@NL@% Alpha(row%, col%) = Alpha(row%, col%) - Beta(row%, col%)%@NL@% NEXT col%%@NL@% NEXT row%%@NL@% ssubexit:%@NL@% EXIT FUNCTION%@NL@% ssuberr:%@NL@% MatSubS% = (ERR + 5) MOD 200 - 5%@NL@% RESUME ssubexit:%@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%MENU.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MENU.BAS%@AE@%%@NL@% %@NL@% %@AB@%'============================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' MENU.BAS - Pull-down Menu Routines for the User Interface Toolbox in%@AE@%%@NL@% %@AB@%' Microsoft BASIC 7.0, Professional Development System%@AE@%%@NL@% %@AB@%' Copyright (C) 1987-1989, Microsoft Corporation%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' NOTE: This sample source code toolbox is intended to demonstrate some%@AE@%%@NL@% %@AB@%' of the extended capabilities of Microsoft BASIC 7.0 Professional%@AE@%%@NL@% %@AB@%' Development system that can help to leverage the professional%@AE@%%@NL@% %@AB@%' developer's time more effectively. While you are free to use,%@AE@%%@NL@% %@AB@%' modify, or distribute the routines in this module in any way you%@AE@%%@NL@% %@AB@%' find useful, it should be noted that these are examples only and%@AE@%%@NL@% %@AB@%' should not be relied upon as a fully-tested "add-on" library.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' PURPOSE: These are the routines which provide support for the pull-down%@AE@%%@NL@% %@AB@%' menus in the user interface toolbox.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' For information on creating a library and QuickLib from the routines%@AE@%%@NL@% %@AB@%' contained in this file, read the comment header of GENERAL.BAS.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'============================================================================%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@NL@% %@AB@%'$INCLUDE: 'general.bi'%@AE@%%@NL@% %@AB@%'$INCLUDE: 'mouse.bi'%@AE@%%@NL@% %@AB@%'$INCLUDE: 'menu.bi'%@AE@%%@NL@% %@NL@% COMMON SHARED /uitools/ GloMenu AS MenuMiscType%@NL@% COMMON SHARED /uitools/ GloTitle() AS MenuTitleType%@NL@% COMMON SHARED /uitools/ GloItem() AS MenuItemType%@NL@% %@NL@% FUNCTION MenuCheck (action%) STATIC%@NL@% %@NL@% SELECT CASE action%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' This simulates "polling" for a menu event. If a menu event occured,%@AE@%%@NL@% %@AB@% ' GloMenu.currMenu and .currItem are set. When MenuCheck(0) is%@AE@%%@NL@% %@AB@% ' called, these values are transfered to .lastMenu and .lastItem.%@AE@%%@NL@% %@AB@% ' MenuCheck(0) then returns the menu number, or 0 (FALSE) if none%@AE@%%@NL@% %@AB@% ' selected as of last call%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% CASE 0%@NL@% GloMenu.lastMenu = GloMenu.currMenu%@NL@% GloMenu.lastItem = GloMenu.currItem%@NL@% GloMenu.currMenu = 0%@NL@% GloMenu.currItem = 0%@NL@% MenuCheck = GloMenu.lastMenu%@NL@% %@NL@% %@AB@% '===================================================================%@AE@%%@NL@% %@AB@% ' Returns the menu item last selected. Functions only after a call%@AE@%%@NL@% %@AB@% ' to MenuCheck(0)%@AE@%%@NL@% %@AB@% '===================================================================%@AE@%%@NL@% %@NL@% CASE 1%@NL@% MenuCheck = GloMenu.lastItem%@NL@% %@NL@% %@AB@% '===================================================================%@AE@%%@NL@% %@AB@% ' Checks GloMenu.currMenu and .currItem. If both are not 0, this%@AE@%%@NL@% %@AB@% ' returns TRUE meaning a menu has been selected since MenuCheck(0)%@AE@%%@NL@% %@AB@% ' was last called. This does not change any values, it simply%@AE@%%@NL@% %@AB@% ' reports on the current state.%@AE@%%@NL@% %@AB@% '===================================================================%@AE@%%@NL@% %@NL@% CASE 2%@NL@% IF GloMenu.currMenu = 0 OR GloMenu.currItem = 0 THEN%@NL@% MenuCheck = FALSE%@NL@% ELSE%@NL@% MenuCheck = TRUE%@NL@% END IF%@NL@% CASE ELSE%@NL@% MenuCheck = 0%@NL@% END SELECT%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% SUB MenuColor (fore, back, highlight, disabled, cursorFore, cursorBack, cursorHi)%@NL@% %@NL@% GloMenu.fore = fore%@NL@% GloMenu.back = back%@NL@% GloMenu.highlight = highlight%@NL@% GloMenu.disabled = disabled%@NL@% GloMenu.cursorFore = cursorFore%@NL@% GloMenu.cursorBack = cursorBack%@NL@% GloMenu.cursorHi = cursorHi%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB MenuDo STATIC%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' If menu event trapping turned off, return immediately%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% IF NOT GloMenu.MenuOn THEN%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' Initialize MenuDo's variables, and then enter the main loop%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% GOSUB MenuDoInit%@NL@% %@NL@% WHILE NOT MenuDoDone%@NL@% %@NL@% %@AB@% '===================================================================%@AE@%%@NL@% %@AB@% ' If in MouseMode then%@AE@%%@NL@% %@AB@% ' if button is pressed, check where mouse is and react acccordingly.%@AE@%%@NL@% %@AB@% ' if button not pressed, switch to keyboard mode.%@AE@%%@NL@% %@AB@% '===================================================================%@AE@%%@NL@% IF mouseMode THEN%@NL@% MousePoll mouseRow, mouseCol, lButton, rButton%@NL@% IF lButton THEN%@NL@% IF mouseRow = 1 THEN%@NL@% GOSUB MenuDoGetMouseMenu%@NL@% ELSE%@NL@% GOSUB MenuDoGetMouseItem%@NL@% END IF%@NL@% ELSE%@NL@% mouseMode = FALSE%@NL@% GOSUB MenuDoMouseRelease%@NL@% IF NOT pulldown THEN%@NL@% GOSUB MenuDoShowTitleAccessKeys%@NL@% END IF%@NL@% END IF%@NL@% ELSE%@NL@% %@NL@% %@AB@% '===============================================================%@AE@%%@NL@% %@AB@% ' If in keyboard mode, show the cursor, wait for key, hide cursor%@AE@%%@NL@% %@AB@% ' Perform the desired action based on what key was pressed.%@AE@%%@NL@% %@AB@% '===============================================================%@AE@%%@NL@% %@NL@% GOSUB MenuDoShowCursor%@NL@% GOSUB MenuDoGetKey%@NL@% GOSUB MenuDoHideCursor%@NL@% %@NL@% SELECT CASE kbd$%@NL@% CASE "enter": GOSUB MenuDoEnter%@NL@% CASE "up": GOSUB MenuDoUp%@NL@% CASE "down": GOSUB menuDoDown%@NL@% CASE "left": GOSUB MenuDoLeft%@NL@% CASE "right": GOSUB MenuDoRight%@NL@% CASE "escape": GOSUB MenuDoEscape%@NL@% CASE "altReleased": GOSUB MenuDoAltReleased%@NL@% CASE "mouse": GOSUB MenuDoMousePress%@NL@% CASE ELSE: GOSUB MenuDoAccessKey%@NL@% END SELECT%@NL@% END IF%@NL@% WEND%@NL@% GOSUB MenuDoHideTitleAccessKeys%@NL@% EXIT SUB%@NL@% %@NL@% %@AB@%'===========================================================================%@AE@%%@NL@% %@AB@%' Initialize variables for proper MenuDo execution.%@AE@%%@NL@% %@AB@%'===========================================================================%@AE@%%@NL@% %@NL@% MenuDoInit:%@NL@% REDIM buffer$(MAXMENU), copyFlag(MAXMENU) 'Stores screen backround%@NL@% %@NL@% FOR a = 1 TO MAXMENU%@NL@% buffer$(a) = "" '1 buffer per menu%@NL@% copyFlag(a) = FALSE 'FALSE means not copied yet%@NL@% NEXT a%@NL@% %@NL@% pulldown = FALSE 'FALSE means no menu is shown%@NL@% MenuDoDone = FALSE 'FALSE means keep going in loop%@NL@% %@NL@% altWasReleased = FALSE 'Set to TRUE if ALT is pressed%@NL@% %@AB@% 'and then released%@AE@%%@NL@% %@NL@% altWasPressedAgain = FALSE 'Set to TRUE is ALT is pressed%@NL@% %@AB@% 'and then released, and then%@AE@%%@NL@% %@AB@% 'pressed again.%@AE@%%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' If mouse installed and button is pressed, then set MouseMode to TRUE%@AE@%%@NL@% %@AB@% ' Else, set MouseMode to FALSE%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% MousePoll mouseRow, mouseCol, lButton, rButton%@NL@% IF lButton THEN%@NL@% mouseMode = TRUE%@NL@% currMenu = 0%@NL@% currItem = 0%@NL@% ELSE%@NL@% mouseMode = FALSE%@NL@% currMenu = 1%@NL@% currItem = 0%@NL@% GOSUB MenuDoShowTitleAccessKeys%@NL@% END IF%@NL@% %@NL@% RETURN%@NL@% %@NL@% %@AB@%'===========================================================================%@AE@%%@NL@% %@AB@%' This shows the cursor at the location CurrMenu,CurrItem.%@AE@%%@NL@% %@AB@%'===========================================================================%@AE@%%@NL@% %@NL@% MenuDoShowCursor:%@NL@% %@NL@% MouseHide%@NL@% IF currMenu <> 0 AND RTRIM$(GloItem(currMenu, currItem).text) <> "-" THEN%@NL@% IF currItem = 0 THEN%@NL@% COLOR GloMenu.cursorFore, GloMenu.cursorBack%@NL@% LOCATE 1, GloTitle(currMenu).lColTitle%@NL@% PRINT " "; RTRIM$(GloTitle(currMenu).text); " ";%@NL@% IF NOT mouseMode THEN%@NL@% COLOR GloMenu.cursorHi, GloMenu.cursorBack%@NL@% LOCATE 1, GloTitle(currMenu).lColTitle + GloTitle(currMenu).accessKey%@NL@% PRINT MID$(GloTitle(currMenu).text, GloTitle(currMenu).accessKey, 1);%@NL@% END IF%@NL@% ELSE%@NL@% IF GloItem(currMenu, currItem).state = 2 THEN%@NL@% chk$ = CHR$(175)%@NL@% ELSE%@NL@% chk$ = " "%@NL@% END IF%@NL@% %@NL@% COLOR GloMenu.cursorFore, GloMenu.cursorBack%@NL@% LOCATE GloItem(currMenu, currItem).row, GloTitle(currMenu).lColItem + 1%@NL@% PRINT chk$; LEFT$(GloItem(currMenu, currItem).text, GloTitle(currMenu).itemLength); " ";%@NL@% %@NL@% IF GloItem(currMenu, currItem).state > 0 THEN%@NL@% COLOR GloMenu.cursorHi, GloMenu.cursorBack%@NL@% LOCATE GloItem(currMenu, currItem).row, col + GloItem(currMenu, currItem).accessKey + 1%@NL@% PRINT MID$(GloItem(currMenu, currItem).text, GloItem(currMenu, currItem).accessKey, 1);%@NL@% END IF%@NL@% %@NL@% END IF%@NL@% END IF%@NL@% MouseShow%@NL@% %@NL@% RETURN%@NL@% %@NL@% %@AB@%'===========================================================================%@AE@%%@NL@% %@AB@%' This hides the cursor at the location CurrMenu,CurrItem.%@AE@%%@NL@% %@AB@%'===========================================================================%@AE@%%@NL@% %@NL@% MenuDoHideCursor:%@NL@% %@NL@% MouseHide%@NL@% IF currMenu <> 0 AND RTRIM$(GloItem(currMenu, currItem).text) <> "-" THEN%@NL@% IF currItem = 0 THEN%@NL@% SELECT CASE GloTitle(currMenu).state%@NL@% CASE 0: COLOR GloMenu.disabled, GloMenu.back%@NL@% CASE 1, 2: COLOR GloMenu.fore, GloMenu.back%@NL@% CASE ELSE%@NL@% END SELECT%@NL@% LOCATE 1, GloTitle(currMenu).lColTitle%@NL@% PRINT " "; RTRIM$(GloTitle(currMenu).text); " ";%@NL@% %@NL@% IF GloTitle(currMenu).state > 0 THEN%@NL@% COLOR GloMenu.highlight, GloMenu.back%@NL@% LOCATE 1, GloTitle(currMenu).lColTitle + GloTitle(currMenu).accessKey%@NL@% PRINT MID$(GloTitle(currMenu).text, GloTitle(currMenu).accessKey, 1);%@NL@% END IF%@NL@% ELSE%@NL@% IF GloItem(currMenu, currItem).state = 2 THEN%@NL@% chk$ = CHR$(175)%@NL@% ELSE%@NL@% chk$ = " "%@NL@% END IF%@NL@% SELECT CASE GloItem(currMenu, currItem).state%@NL@% CASE 0: COLOR GloMenu.disabled, GloMenu.back%@NL@% CASE 1, 2: COLOR GloMenu.fore, GloMenu.back%@NL@% CASE ELSE%@NL@% END SELECT%@NL@% LOCATE GloItem(currMenu, currItem).row, GloTitle(currMenu).lColItem + 1%@NL@% PRINT chk$; LEFT$(GloItem(currMenu, currItem).text, GloTitle(currMenu).itemLength); " ";%@NL@% %@NL@% IF GloItem(currMenu, currItem).state > 0 THEN%@NL@% COLOR GloMenu.highlight, GloMenu.back%@NL@% LOCATE GloItem(currMenu, currItem).row, col + GloItem(currMenu, currItem).accessKey + 1%@NL@% PRINT MID$(GloItem(currMenu, currItem).text, GloItem(currMenu, currItem).accessKey, 1);%@NL@% END IF%@NL@% %@NL@% END IF%@NL@% END IF%@NL@% MouseShow%@NL@% RETURN%@NL@% %@NL@% %@AB@%'===========================================================================%@AE@%%@NL@% %@AB@%' Handles state where mouse is at row #1.%@AE@%%@NL@% %@AB@%'===========================================================================%@AE@%%@NL@% %@NL@% MenuDoGetMouseMenu:%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' Computes the menu number based on mouse column location. Uses info%@AE@%%@NL@% %@AB@% ' calculated in MenuShow()%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% newMenu = CVI(MID$(GloMenu.menuIndex, mouseCol * 2 - 1, 2))%@NL@% %@NL@% IF GloTitle(newMenu).state <> 1 THEN%@NL@% newMenu = 0%@NL@% END IF%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' If new menu<>current menu, hide current menu, show new menu, assign new%@AE@%%@NL@% %@AB@% ' menu to current menu%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% IF newMenu <> currMenu THEN%@NL@% GOSUB MenuDoHidePullDown%@NL@% currMenu = newMenu%@NL@% currItem = 0%@NL@% GOSUB menuDoShowPullDown%@NL@% END IF%@NL@% %@NL@% RETURN%@NL@% %@NL@% %@AB@%'===========================================================================%@AE@%%@NL@% %@AB@%' Handles state where mouse is not in row #1. If a menu is down, it picks%@AE@%%@NL@% %@AB@%' the proper menu item based on which row the mouse is located%@AE@%%@NL@% %@AB@%'===========================================================================%@AE@%%@NL@% %@NL@% MenuDoGetMouseItem:%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' If pulldown, and mouse column is within the menu area, then compute new%@AE@%%@NL@% %@AB@% ' item based on computations done in MenuShow. If not in box, then new%@AE@%%@NL@% %@AB@% ' item = 0%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% IF pulldown THEN%@NL@% IF mouseCol >= GloTitle(currMenu).lColItem AND mouseCol <= GloTitle(currMenu).rColItem AND mouseRow <= GloTitle(currMenu).lowestRow AND mouseRow - 2 <= MAXITEM THEN%@NL@% newItem = GloItem(currMenu, mouseRow - 2).index%@NL@% ELSE%@NL@% newItem = 0%@NL@% END IF%@NL@% %@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@AB@% ' If current item <> new item, hide old cursor, show new cursor,%@AE@%%@NL@% %@AB@% ' assign new item to current item.%@AE@%%@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@NL@% IF currItem <> newItem THEN%@NL@% IF currItem <> 0 THEN%@NL@% GOSUB MenuDoHideCursor%@NL@% END IF%@NL@% currItem = newItem%@NL@% GOSUB MenuDoShowCursor%@NL@% END IF%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' Handles state when MenuDo is in mouse mode, and mouse button is released.%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuDoMouseRelease:%@NL@% menuMode = FALSE%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' If no menu selected, then exit MenuDo returning 0s for menu and item%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% IF currMenu = 0 THEN%@NL@% GloMenu.currMenu = 0%@NL@% GloMenu.currItem = 0%@NL@% MenuDoDone = TRUE%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@AB@% ' If menu is down, but no item is selected then%@AE@%%@NL@% %@AB@% ' if mouse is on the top row, simply gosub the MenuDoDown routine%@AE@%%@NL@% %@AB@% ' else hide menu then exit MenuDo returning 0's for menu and item%@AE@%%@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@NL@% IF currItem = 0 THEN%@NL@% IF mouseRow = 1 THEN%@NL@% GOSUB menuDoDown%@NL@% ELSE%@NL@% GOSUB MenuDoHidePullDown%@NL@% GloMenu.currMenu = 0%@NL@% GloMenu.currItem = 0%@NL@% MenuDoDone = TRUE%@NL@% END IF%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@AB@% ' If current (menu,item)'s state is disabled, then just beep%@AE@%%@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@NL@% IF GloItem(currMenu, currItem).state = 0 THEN%@NL@% BEEP%@NL@% %@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@AB@% ' If current (menu,item)'s state is a line%@AE@%%@NL@% %@AB@% ' then exit MenuDo returning 0s for menu and item%@AE@%%@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@NL@% ELSEIF RTRIM$(GloItem(currMenu, currItem).text) = "-" THEN%@NL@% GOSUB MenuDoHidePullDown%@NL@% GloMenu.currMenu = 0%@NL@% GloMenu.currItem = 0%@NL@% MenuDoDone = TRUE%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' ===========================================================%@AE@%%@NL@% %@AB@% ' Otherwise, selection must be valid, exit MenuDo, returning%@AE@%%@NL@% %@AB@% ' proper menu,item pair in the proper global variables%@AE@%%@NL@% %@AB@% ' ===========================================================%@AE@%%@NL@% GOSUB MenuDoHidePullDown%@NL@% GloMenu.currMenu = currMenu%@NL@% GloMenu.currItem = currItem%@NL@% MenuDoDone = TRUE%@NL@% END IF%@NL@% END IF%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% %@AB@%' ==========================================================================%@AE@%%@NL@% %@AB@%' This routine shows the menu bar's access keys%@AE@%%@NL@% %@AB@%' ==========================================================================%@AE@%%@NL@% %@NL@% MenuDoShowTitleAccessKeys:%@NL@% MouseHide%@NL@% COLOR GloMenu.highlight, GloMenu.back%@NL@% FOR menu = 1 TO MAXMENU%@NL@% IF GloTitle(menu).state = 1 THEN%@NL@% LOCATE 1, GloTitle(menu).lColTitle + GloTitle(menu).accessKey%@NL@% PRINT MID$(GloTitle(menu).text, GloTitle(menu).accessKey, 1);%@NL@% END IF%@NL@% NEXT menu%@NL@% MouseShow%@NL@% RETURN%@NL@% %@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' This routine hides the menu bar's access keys%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuDoHideTitleAccessKeys:%@NL@% MouseHide%@NL@% COLOR GloMenu.fore, GloMenu.back%@NL@% FOR menu = 1 TO MAXMENU%@NL@% IF GloTitle(menu).state = 1 THEN%@NL@% LOCATE 1, GloTitle(menu).lColTitle + GloTitle(menu).accessKey%@NL@% PRINT MID$(GloTitle(menu).text, GloTitle(menu).accessKey, 1);%@NL@% END IF%@NL@% NEXT menu%@NL@% MouseShow%@NL@% RETURN%@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' Waits for key press, then returns the key press. It also returns several%@AE@%%@NL@% %@AB@%' tokens such as "menu", or "altReleased" in special cases. Read on...%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuDoGetKey:%@NL@% DO%@NL@% kbd$ = INKEY$%@NL@% %@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@AB@% ' If ALT key pressed, then if it was a access key (Alt+A..) reduce%@AE@%%@NL@% %@AB@% ' the Alt+A to A.%@AE@%%@NL@% %@AB@% ' Also set the altPressed flags to reflect the current state of the%@AE@%%@NL@% %@AB@% ' ALT key.%@AE@%%@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@NL@% IF GetShiftState(3) THEN%@NL@% IF kbd$ = "" THEN%@NL@% IF altWasReleased THEN%@NL@% altWasPressedAgain = TRUE%@NL@% END IF%@NL@% ELSE%@NL@% altWasPressedAgain = FALSE%@NL@% kbd$ = AltToASCII(kbd$)%@NL@% END IF%@NL@% altWasReleased = FALSE%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@AB@% ' If ALT key is released (initially), then pressed, then released%@AE@%%@NL@% %@AB@% ' again with no other action in between, then return the%@AE@%%@NL@% %@AB@% ' token "altReleased"%@AE@%%@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@NL@% IF altWasPressedAgain THEN%@NL@% kbd$ = "altReleased"%@NL@% altWasPressedAgain = FALSE%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' ===========================================================%@AE@%%@NL@% %@AB@% ' Based on the key that was pressed, return the proper token%@AE@%%@NL@% %@AB@% ' ===========================================================%@AE@%%@NL@% %@NL@% altWasReleased = TRUE%@NL@% %@NL@% SELECT CASE kbd$%@NL@% CASE CHR$(27) + "": kbd$ = "escape"%@NL@% CASE CHR$(32) + "": kbd$ = ""%@NL@% CASE CHR$(13) + "": kbd$ = "enter"%@NL@% CASE CHR$(0) + "H": kbd$ = "up"%@NL@% CASE CHR$(0) + "P": kbd$ = "down"%@NL@% CASE CHR$(0) + "K": kbd$ = "left"%@NL@% CASE CHR$(0) + "M": kbd$ = "right"%@NL@% CASE ELSE%@NL@% IF LEN(kbd$) = 1 THEN%@NL@% kbd$ = UCASE$(kbd$)%@NL@% END IF%@NL@% END SELECT%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@AB@% ' If mouse button is pressed, it overrides all key actions, and%@AE@%%@NL@% %@AB@% ' the token "mouse" is returned%@AE@%%@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@NL@% MousePoll mouseRow, mouseCol, lButton, rButton%@NL@% IF lButton THEN%@NL@% kbd$ = "mouse"%@NL@% END IF%@NL@% %@NL@% LOOP UNTIL kbd$ <> ""%@NL@% %@NL@% RETURN%@NL@% %@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' Handles the state where the up arrow is pressed. It searches for the%@AE@%%@NL@% %@AB@%' first non empty, non "-" (dashed) item.%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuDoUp:%@NL@% IF currItem <> 0 THEN%@NL@% DO%@NL@% currItem = (currItem + MAXITEM - 2) MOD MAXITEM + 1%@NL@% LOOP UNTIL GloItem(currMenu, currItem).state >= 0 AND RTRIM$(GloItem(currMenu, currItem).text) <> "-"%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' Handles 2 different states:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' State 1: Menu is open, and the down arrow is pressed.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' State 2: Any time a new menu is opened, and the top item%@AE@%%@NL@% %@AB@%' is to be the current item. Specifically:%@AE@%%@NL@% %@AB@%' - When no menu is opened, and the down arrow is pressed%@AE@%%@NL@% %@AB@%' - When the mouse is released over the menu title%@AE@%%@NL@% %@AB@%' - When a menu is opened, and the user hits right/left arrow%@AE@%%@NL@% %@AB@%' - When enter is pressed while cursor is on title bar%@AE@%%@NL@% %@AB@%' - When a access key is used on the title bar.%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% menuDoDown:%@NL@% DO%@NL@% IF currItem = 0 THEN%@NL@% GOSUB MenuDoHideTitleAccessKeys%@NL@% GOSUB menuDoShowPullDown%@NL@% currItem = (currItem) MOD MAXITEM + 1%@NL@% ELSEIF currItem > 0 THEN%@NL@% currItem = (currItem) MOD MAXITEM + 1%@NL@% END IF%@NL@% %@NL@% LOOP UNTIL GloItem(currMenu, currItem).state >= 0 AND RTRIM$(GloItem(currMenu, currItem).text) <> "-"%@NL@% RETURN%@NL@% %@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' Handles state when the left arrow is pressed. If a menu is down, it%@AE@%%@NL@% %@AB@%' hides it. It then finds the first valid menu to the left. If the menu%@AE@%%@NL@% %@AB@%' was initially down, then the new menu is pulled down as well%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuDoLeft:%@NL@% IF pulldown THEN%@NL@% GOSUB MenuDoHidePullDown%@NL@% pulldown = TRUE%@NL@% END IF%@NL@% %@NL@% DO%@NL@% currMenu = (currMenu + MAXMENU - 2) MOD MAXMENU + 1%@NL@% LOOP UNTIL GloTitle(currMenu).state = 1%@NL@% %@NL@% IF pulldown THEN%@NL@% currItem = 0%@NL@% GOSUB menuDoDown%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' Handles state when the right arrow is pressed. If a menu is down, it%@AE@%%@NL@% %@AB@%' hides it. It then finds the first valid menu to the right. If the menu%@AE@%%@NL@% %@AB@%' was initially down, then the new menu is pulled down as well%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuDoRight:%@NL@% IF pulldown THEN%@NL@% GOSUB MenuDoHidePullDown%@NL@% pulldown = TRUE%@NL@% END IF%@NL@% %@NL@% DO%@NL@% currMenu = (currMenu) MOD MAXMENU + 1%@NL@% LOOP UNTIL GloTitle(currMenu).state = 1%@NL@% %@NL@% IF pulldown THEN%@NL@% currItem = 0%@NL@% GOSUB menuDoDown%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' Handles state when the ESC key is pressed. First hides the menu, and%@AE@%%@NL@% %@AB@%' then exits menuDo, returning 0's in the proper global variables%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuDoEscape:%@NL@% GOSUB MenuDoHidePullDown%@NL@% GloMenu.currMenu = 0%@NL@% GloMenu.currItem = 0%@NL@% MenuDoDone = TRUE%@NL@% RETURN%@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' Handles state when Enter is pressed. If on a valid item, return the%@AE@%%@NL@% %@AB@%' proper (menu,item) pair and exit. Else beep. If on a valid menu%@AE@%%@NL@% %@AB@%' this will open the menu by calling MenuDoDown%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuDoEnter:%@NL@% IF currItem = 0 THEN%@NL@% IF GloTitle(currMenu).state = 0 THEN%@NL@% BEEP%@NL@% ELSE%@NL@% GOSUB menuDoDown%@NL@% END IF%@NL@% ELSE%@NL@% IF GloItem(currMenu, currItem).state <= 0 THEN%@NL@% BEEP%@NL@% ELSE%@NL@% GOSUB MenuDoHidePullDown%@NL@% GloMenu.currMenu = currMenu%@NL@% GloMenu.currItem = currItem%@NL@% MenuDoDone = TRUE%@NL@% END IF%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' If ALT pressed and released with nothing else happening in between, it%@AE@%%@NL@% %@AB@%' will exit if no menu is open, or close the menu if one is open.%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuDoAltReleased:%@NL@% IF pulldown THEN%@NL@% GOSUB MenuDoHidePullDown%@NL@% currItem = 0%@NL@% GOSUB MenuDoShowTitleAccessKeys%@NL@% ELSE%@NL@% GloMenu.currMenu = 0%@NL@% GloMenu.currItem = 0%@NL@% MenuDoDone = TRUE%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' If mouse is pressed while in keyboard mode, this routine assigns%@AE@%%@NL@% %@AB@%' TRUE to MouseMode, resets the item, and hides the access keys%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuDoMousePress:%@NL@% mouseMode = TRUE%@NL@% currItem = 0%@NL@% IF NOT pulldown THEN%@NL@% GOSUB MenuDoHideTitleAccessKeys%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' If a access key is pressed%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuDoAccessKey:%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' If an access key is pressed%@AE@%%@NL@% %@AB@% ' If no menu selected, search titles for matching access key, and open%@AE@%%@NL@% %@AB@% ' than menu.%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% IF currItem = 0 THEN%@NL@% newMenu = (currMenu + MAXMENU - 2) MOD MAXMENU + 1%@NL@% loopEnd = (currMenu + MAXMENU - 2) MOD MAXMENU + 1%@NL@% DO%@NL@% newMenu = (newMenu) MOD MAXMENU + 1%@NL@% LOOP UNTIL (UCASE$(MID$(GloTitle(newMenu).text, GloTitle(newMenu).accessKey, 1)) = kbd$ AND GloTitle(newMenu).state = 1) OR newMenu = loopEnd%@NL@% %@NL@% IF kbd$ = UCASE$(MID$(GloTitle(newMenu).text, GloTitle(newMenu).accessKey, 1)) THEN%@NL@% currMenu = newMenu%@NL@% GOSUB menuDoDown%@NL@% END IF%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@AB@% ' If menu is selected, search items for matching access key, and%@AE@%%@NL@% %@AB@% ' select that (menu,item) and exit MenuDo if item is enabled%@AE@%%@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@NL@% newItem = (currItem + MAXITEM - 2) MOD MAXITEM + 1%@NL@% loopEnd = (currItem + MAXITEM - 2) MOD MAXITEM + 1%@NL@% DO%@NL@% newItem = (newItem) MOD MAXITEM + 1%@NL@% LOOP UNTIL (UCASE$(MID$(GloItem(currMenu, newItem).text, GloItem(currMenu, newItem).accessKey, 1)) = kbd$ AND GloItem(currMenu, newItem).state > 0 AND RTRIM$(GloItem(currMenu, newItem).text) <> "-") OR newItem = loopEnd%@NL@% %@NL@% %@NL@% IF kbd$ = UCASE$(MID$(GloItem(currMenu, newItem).text, GloItem(currMenu, newItem).accessKey, 1)) THEN%@NL@% currItem = newItem%@NL@% %@NL@% IF GloItem(currMenu, currItem).state <= 0 THEN%@NL@% BEEP%@NL@% ELSE%@NL@% GOSUB MenuDoHidePullDown%@NL@% GloMenu.currMenu = currMenu%@NL@% GloMenu.currItem = currItem%@NL@% MenuDoDone = TRUE%@NL@% END IF%@NL@% END IF%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' Draws the menu -- only if menu is enabled.%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% menuDoShowPullDown:%@NL@% IF currMenu <> 0 AND GloTitle(currMenu).state = 1 THEN%@NL@% %@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@AB@% ' Copies the background if this is the first time this particular%@AE@%%@NL@% %@AB@% ' menu is being drawn%@AE@%%@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@NL@% MouseHide%@NL@% IF NOT copyFlag(currMenu) THEN%@NL@% IF GloTitle(currMenu).rColItem - GloTitle(currMenu).lColItem < LEN(GloTitle(currMenu).text) THEN%@NL@% GloTitle(currMenu).rColItem = GloTitle(currMenu).lColItem + LEN(GloTitle(currMenu).text)%@NL@% END IF%@NL@% %@NL@% GetBackground 1, GloTitle(currMenu).lColItem, GloTitle(currMenu).lowestRow, GloTitle(currMenu).rColItem + 2, buffer$(currMenu)%@NL@% copyFlag(currMenu) = TRUE%@NL@% END IF%@NL@% %@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@AB@% ' Draw the menu, this is pretty straight forward%@AE@%%@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% pulldown = TRUE%@NL@% length = GloTitle(currMenu).itemLength%@NL@% IF length = 0 THEN length = 6%@NL@% lowestRow = 3%@NL@% col = GloTitle(currMenu).lColItem%@NL@% %@NL@% COLOR GloMenu.cursorFore, GloMenu.cursorBack%@NL@% LOCATE 1, GloTitle(currMenu).lColTitle%@NL@% PRINT " "; RTRIM$(GloTitle(currMenu).text); " ";%@NL@% %@NL@% COLOR GloMenu.fore, GloMenu.back%@NL@% LOCATE 2, col%@NL@% PRINT "┌"; STRING$(length + 2, "─"); "┐"%@NL@% %@NL@% FOR item = 1 TO MAXITEM%@NL@% IF GloItem(currMenu, item).state >= 0 THEN%@NL@% IF GloItem(currMenu, item).state = 2 THEN%@NL@% chk$ = CHR$(175)%@NL@% ELSE%@NL@% chk$ = " "%@NL@% END IF%@NL@% %@NL@% LOCATE GloItem(currMenu, item).row, col%@NL@% COLOR GloMenu.fore, GloMenu.back%@NL@% %@NL@% IF RTRIM$(GloItem(currMenu, item).text) = "-" THEN%@NL@% PRINT "├"; STRING$(length + 2, "─"); "┤"%@NL@% ELSE%@NL@% PRINT "│"; chk$;%@NL@% IF GloItem(currMenu, item).state > 0 THEN%@NL@% COLOR GloMenu.fore, GloMenu.back%@NL@% ELSE%@NL@% COLOR GloMenu.disabled, GloMenu.back%@NL@% END IF%@NL@% PRINT LEFT$(GloItem(currMenu, item).text + SPACE$(20), length);%@NL@% COLOR GloMenu.fore, GloMenu.back%@NL@% PRINT " │";%@NL@% %@NL@% IF GloItem(currMenu, item).state > 0 THEN%@NL@% COLOR GloMenu.highlight, GloMenu.back%@NL@% LOCATE GloItem(currMenu, item).row, col + GloItem(currMenu, item).accessKey + 1%@NL@% PRINT MID$(GloItem(currMenu, item).text, GloItem(currMenu, item).accessKey, 1);%@NL@% END IF%@NL@% END IF%@NL@% lowestRow = GloItem(currMenu, item).row + 1%@NL@% END IF%@NL@% NEXT item%@NL@% %@NL@% COLOR GloMenu.fore, GloMenu.back%@NL@% LOCATE lowestRow, col%@NL@% PRINT "└"; STRING$(length + 2, "─"); "┘";%@NL@% %@NL@% rCol = col + length + 5%@NL@% %@NL@% AttrBox 3, rCol - 1, lowestRow, rCol, 8%@NL@% AttrBox lowestRow + 1, col + 2, lowestRow + 1, rCol, 8%@NL@% END IF%@NL@% %@NL@% MouseShow%@NL@% %@NL@% RETURN%@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' Replace the background over the menu%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuDoHidePullDown:%@NL@% IF pulldown THEN%@NL@% MouseHide%@NL@% %@NL@% PutBackground 1, GloTitle(currMenu).lColItem, buffer$(currMenu)%@NL@% %@NL@% MouseShow%@NL@% pulldown = FALSE%@NL@% END IF%@NL@% RETURN%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB MenuEvent%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' If ALT key is pressed, let MenuDo take over. NOTE: This will%@AE@%%@NL@% %@AB@% ' not call MenuDo if the ALT key has not been released at least%@AE@%%@NL@% %@AB@% ' once since the last time MenuDo was called. This prevents the menu%@AE@%%@NL@% %@AB@% ' from flashing if the user simply holds down the ALT key.%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% IF GetShiftState(3) THEN%@NL@% IF GloMenu.altKeyReset THEN%@NL@% MenuDo%@NL@% GloMenu.altKeyReset = FALSE%@NL@% END IF%@NL@% ELSE%@NL@% GloMenu.altKeyReset = TRUE%@NL@% END IF%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Call MenuDo if the mouse button is down, and the cursor is on the top row%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% MousePoll mouseRow, mouseCol, lButton, rButton%@NL@% IF mouseRow = 1 AND lButton THEN%@NL@% MenuDo%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB MenuInit%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Initialize global menu arrays%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% FOR menu = 1 TO MAXMENU%@NL@% GloTitle(menu).text = ""%@NL@% GloTitle(menu).state = -1 'state of -1 means "empty"%@NL@% GloTitle(menu).rColItem = 0 'These get set in MenuShow%@NL@% GloTitle(menu).lColItem = 0 ' |%@NL@% GloTitle(menu).rColTitle = 0 ' |%@NL@% GloTitle(menu).lColTitle = 0 ' |%@NL@% GloTitle(menu).itemLength = 0 ' |%@NL@% GloTitle(menu).accessKey = 1 'Initial AccessKey of 1%@NL@% %@NL@% FOR item = 1 TO MAXITEM%@NL@% GloItem(menu, item).text = ""%@NL@% GloItem(menu, item).state = -1 'state of -1 means "empty"%@NL@% GloItem(menu, item).index = 0 'These get set in MenuShow%@NL@% GloItem(menu, item).row = 0 ' |%@NL@% GloItem(menu, item).accessKey = 1 'Initial AccessKey of 1%@NL@% NEXT item%@NL@% NEXT menu%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Initialize mouse%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% MouseInit%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Set initial state of ALT key to "reset"%@AE@%%@NL@% %@AB@% ' Clear out shortcut key index%@AE@%%@NL@% %@AB@% ' Set initial state of menu to ON%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% GloMenu.altKeyReset = TRUE%@NL@% GloMenu.shortcutKeyIndex = STRING$(100, 0)%@NL@% GloMenu.MenuOn = TRUE%@NL@% %@NL@% GloMenu.fore = 0%@NL@% GloMenu.back = 7%@NL@% GloMenu.highlight = 15%@NL@% GloMenu.disabled = 8%@NL@% GloMenu.cursorFore = 7%@NL@% GloMenu.cursorBack = 0%@NL@% GloMenu.cursorHi = 15%@NL@% %@NL@% END SUB%@NL@% %@NL@% FUNCTION MenuInkey$ STATIC%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Scan keyboard, return KBD$ by default -- unless it is over written below%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% kbd$ = INKEY$%@NL@% MenuInkey$ = kbd$%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Check if KBD$ matches a shortcut key. If it does, return "menu" instead%@AE@%%@NL@% %@AB@% ' of the key that was pressed%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% ShortCutKeyEvent kbd$%@NL@% IF MenuCheck(2) THEN%@NL@% MenuInkey$ = "menu"%@NL@% ELSE%@NL@% %@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@AB@% ' Call menu event, which looks at mouse, and state of ALT key%@AE@%%@NL@% %@AB@% ' If a menu item is selected, return "menu" instead of KBD$%@AE@%%@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@NL@% MenuEvent%@NL@% IF MenuCheck(2) THEN%@NL@% MenuInkey$ = "menu"%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% SUB MenuItemToggle (menu, item)%@NL@% %@NL@% IF item >= 0 AND menu >= 1 AND item <= MAXITEM AND menu <= MAXMENU THEN%@NL@% %@NL@% IF item = 0 OR GloItem(menu, item).state < 1 OR GloItem(menu, item).state > 2 THEN%@NL@% SOUND 2000, 40%@NL@% ELSE%@NL@% GloItem(menu, item).state = 3 - GloItem(menu, item).state%@NL@% END IF%@NL@% %@NL@% END IF%@NL@% END SUB%@NL@% %@NL@% DEFSNG A-Z%@NL@% SUB MenuOff%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Simply assigns FALSE to the proper global variable%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% GloMenu.MenuOn = FALSE%@NL@% %@NL@% END SUB%@NL@% %@NL@% DEFINT A-Z%@NL@% SUB MenuOn%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Simply assigns TRUE to the proper global variable%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% GloMenu.MenuOn = TRUE%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB MenuPreProcess STATIC%@NL@% %@NL@% currCol = 2 'Represents the col where first menu title is located%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Menu index is a fast way of decoding which menu the mouse cursor%@AE@%%@NL@% %@AB@% ' is pointing to based on the col of the cursor. See MENU.BI for details.%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% GloMenu.menuIndex = STRING$(160, 0)%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Process each menu, one at a time%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% FOR menu = 1 TO MAXMENU%@NL@% %@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@AB@% ' If state is empty, or text is "" then clear out data for that menu%@AE@%%@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@NL@% IF GloTitle(menu).state < 0 OR LEN(RTRIM$(GloTitle(menu).text)) = 0 THEN%@NL@% GloTitle(menu).rColItem = 0%@NL@% GloTitle(menu).lColItem = 0%@NL@% GloTitle(menu).rColTitle = 0%@NL@% GloTitle(menu).lColTitle = 0%@NL@% GloTitle(menu).itemLength = 0%@NL@% GloTitle(menu).state = -1%@NL@% ELSE%@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@AB@% ' else, assign data about the column location to the global storage%@AE@%%@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@NL@% GloTitle(menu).lColTitle = currCol%@NL@% GloTitle(menu).rColTitle = currCol + LEN(RTRIM$(GloTitle(menu).text)) + 1%@NL@% GloTitle(menu).lColItem = currCol - 1%@NL@% %@NL@% IF GloTitle(menu).rColTitle > MAXCOL THEN%@NL@% BEEP: CLS : PRINT "Menu bar longer than screen! Cannot function!"%@NL@% END%@NL@% END IF%@NL@% %@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@AB@% ' Update the index about where the menu is located, increment%@AE@%%@NL@% %@AB@% ' currCol%@AE@%%@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@NL@% FOR index = currCol TO currCol + LEN(RTRIM$(GloTitle(menu).text)) + 1%@NL@% MID$(GloMenu.menuIndex, index * 2 - 1, 2) = MKI$(menu)%@NL@% NEXT index%@NL@% %@NL@% currCol = currCol + LEN(RTRIM$(GloTitle(menu).text)) + 2%@NL@% %@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@AB@% ' Process the items in the menu, computing the%@AE@%%@NL@% %@AB@% ' longest item, and preparing the row index%@AE@%%@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@NL@% GloTitle(menu).itemLength = 0%@NL@% currRow = 3%@NL@% iFlag = FALSE%@NL@% %@NL@% FOR item = 1 TO MAXITEM%@NL@% GloItem(menu, currRow - 2).index = 0%@NL@% IF GloItem(menu, item).state >= 0 THEN%@NL@% GloItem(menu, currRow - 2).index = item%@NL@% GloItem(menu, item).row = currRow%@NL@% currRow = currRow + 1%@NL@% IF LEN(RTRIM$(GloItem(menu, item).text)) > GloTitle(menu).itemLength THEN%@NL@% GloTitle(menu).itemLength = LEN(RTRIM$(GloItem(menu, item).text))%@NL@% END IF%@NL@% iFlag = TRUE%@NL@% END IF%@NL@% NEXT item%@NL@% %@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@AB@% ' If all items were empty, disable the menu itself%@AE@%%@NL@% %@AB@% ' else, assign the longest length to the proper variable%@AE@%%@NL@% %@AB@% ' ===============================================================%@AE@%%@NL@% %@NL@% IF NOT iFlag THEN%@NL@% GloTitle(menu).state = 0%@NL@% ELSE%@NL@% GloTitle(menu).rColItem = GloTitle(menu).lColItem + GloTitle(menu).itemLength + 3%@NL@% IF GloTitle(menu).rColItem > MAXCOL - 2 THEN%@NL@% diff = GloTitle(menu).rColItem - (MAXCOL - 2)%@NL@% GloTitle(menu).rColItem = GloTitle(menu).rColItem - diff%@NL@% GloTitle(menu).lColItem = GloTitle(menu).lColItem - diff%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% END IF%@NL@% %@NL@% GloTitle(menu).lowestRow = currRow + 1%@NL@% NEXT menu%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB MenuSet (menu, item, state, text$, accessKey) STATIC%@NL@% %@NL@% IF accessKey > LEN(text$) THEN accessKey = LEN(text$)%@NL@% %@NL@% IF item >= 0 AND menu >= 1 AND item <= MAXITEM AND menu <= MAXMENU THEN%@NL@% %@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@AB@% ' Assign parameters to proper global menu variables%@AE@%%@NL@% %@AB@% ' ===================================================================%@AE@%%@NL@% %@NL@% IF item = 0 THEN%@NL@% IF state < -1 OR state > 1 THEN%@NL@% SOUND 3000, 40%@NL@% ELSE%@NL@% GloTitle(menu).text = text$%@NL@% GloTitle(menu).state = state%@NL@% GloTitle(menu).accessKey = accessKey%@NL@% END IF%@NL@% ELSE%@NL@% IF state < -1 OR state > 2 THEN%@NL@% SOUND 4000, 40%@NL@% ELSE%@NL@% GloItem(menu, item).text = text$%@NL@% GloItem(menu, item).state = state%@NL@% GloItem(menu, item).accessKey = accessKey%@NL@% END IF%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB MenuSetState (menu, item, state) STATIC%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Assign parameters to proper global menu variables%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% IF item = 0 THEN%@NL@% IF state < 0 OR state > 1 OR GloTitle(menu).state < 0 THEN%@NL@% SOUND 5000, 40%@NL@% ELSE%@NL@% GloTitle(menu).state = state%@NL@% END IF%@NL@% ELSE%@NL@% IF state < 0 OR state > 2 OR GloItem(menu, item).state < 0 THEN%@NL@% SOUND 6000, 40%@NL@% ELSE%@NL@% GloItem(menu, item).state = state%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% DEFSNG A-Z%@NL@% SUB MenuShow%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' This section actually prints the menu on the screen%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% COLOR GloMenu.fore, GloMenu.back%@NL@% LOCATE 1, 1%@NL@% PRINT SPACE$(MAXCOL);%@NL@% %@NL@% FOR menu = 1 TO MAXMENU%@NL@% SELECT CASE GloTitle(menu).state%@NL@% CASE 0:%@NL@% COLOR GloMenu.disabled, GloMenu.back%@NL@% LOCATE 1, GloTitle(menu).lColTitle + 1%@NL@% PRINT RTRIM$(GloTitle(menu).text$);%@NL@% CASE 1:%@NL@% COLOR GloMenu.fore, GloMenu.back%@NL@% LOCATE 1, GloTitle(menu).lColTitle + 1%@NL@% PRINT RTRIM$(GloTitle(menu).text$);%@NL@% CASE ELSE%@NL@% END SELECT%@NL@% %@NL@% NEXT menu%@NL@% %@NL@% END SUB%@NL@% %@NL@% DEFINT A-Z%@NL@% SUB ShortCutKeyDelete (menu, item) STATIC%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' Search through shortcut key index until the menu,item pair is found%@AE@%%@NL@% %@AB@% ' or the end of the list is reached.%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% ptr = -1%@NL@% DO%@NL@% ptr = ptr + 1%@NL@% temp = CVI(MID$(GloMenu.shortcutKeyIndex, ptr * 4 + 1, 2))%@NL@% testMenu = INT(temp / 256)%@NL@% testItem = INT(temp MOD 256)%@NL@% LOOP UNTIL (menu = testMenu AND item = testItem) OR testMenu = 0 AND testItem = 0 OR ptr = 25%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' If a match is found, delete the shortcut key by squeezing out the four%@AE@%%@NL@% %@AB@% ' bytes that represents the shortcut key, and adding four chr$(0) at the%@AE@%%@NL@% %@AB@% ' end.%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% IF menu = testMenu AND item = testItem THEN%@NL@% GloMenu.shortcutKeyIndex = LEFT$(GloMenu.shortcutKeyIndex, ptr * 4) + RIGHT$(GloMenu.shortcutKeyIndex, 96 - ptr * 4) + STRING$(4, 0)%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB ShortCutKeyEvent (theKey$)%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' If menu event trapping turned off, return immediately%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% IF NOT GloMenu.MenuOn THEN%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' Make sure the length of theKey$ is two bytes by adding a chr$(0) if%@AE@%%@NL@% %@AB@% ' necessary. If the length is > 2, make it null.%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% SELECT CASE LEN(theKey$)%@NL@% CASE 1%@NL@% theKey$ = theKey$ + CHR$(0)%@NL@% CASE 2%@NL@% CASE ELSE%@NL@% theKey$ = ""%@NL@% END SELECT%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' Search the shortcut key list for a match -- only if theKey$ is valid.%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% IF theKey$ <> "" THEN%@NL@% %@NL@% ptr = -1%@NL@% DO%@NL@% ptr = ptr + 1%@NL@% testKey$ = MID$(GloMenu.shortcutKeyIndex, ptr * 4 + 3, 2)%@NL@% %@NL@% LOOP UNTIL theKey$ = testKey$ OR testKey$ = STRING$(2, 0) OR ptr = 25%@NL@% %@NL@% %@AB@% '===================================================================%@AE@%%@NL@% %@AB@% ' If match is found, make sure menu choice is valid (state > 0)%@AE@%%@NL@% %@AB@% ' If so, assign the proper global variables.%@AE@%%@NL@% %@AB@% '===================================================================%@AE@%%@NL@% %@NL@% IF theKey$ = testKey$ THEN%@NL@% temp = CVI(MID$(GloMenu.shortcutKeyIndex, ptr * 4 + 1, 2))%@NL@% tempMenu = INT(temp / 256)%@NL@% tempItem = INT(temp MOD 256)%@NL@% %@NL@% IF GloItem(tempMenu, tempItem).state > 0 THEN%@NL@% GloMenu.currMenu = tempMenu%@NL@% GloMenu.currItem = tempItem%@NL@% END IF%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB ShortCutKeySet (menu, item, shortcutKey$)%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' Make sure the length of theKey$ is two bytes by adding a chr$(0) if%@AE@%%@NL@% %@AB@% ' necessary. If the length is >2, make it null.%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% SELECT CASE LEN(shortcutKey$)%@NL@% CASE 1%@NL@% shortcutKey$ = shortcutKey$ + CHR$(0)%@NL@% CASE 2%@NL@% CASE ELSE%@NL@% shortcutKey$ = ""%@NL@% END SELECT%@NL@% %@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@AB@% ' First delete the shortcut key, just in case it already exists, and then%@AE@%%@NL@% %@AB@% ' and the shortcut key to the front of the shortcut key index string.%@AE@%%@NL@% %@AB@% '=======================================================================%@AE@%%@NL@% %@NL@% ShortCutKeyDelete menu, item%@NL@% IF shortcutKey$ <> "" THEN%@NL@% newKey$ = MKI$(menu * 256 + item) + shortcutKey$%@NL@% GloMenu.shortcutKeyIndex = newKey$ + LEFT$(GloMenu.shortcutKeyIndex, 396)%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%MOUSE.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MOUSE.BAS%@AE@%%@NL@% %@NL@% %@AB@%'============================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' MOUSE.BAS - Mouse Support Routines for the User Interface Toolbox in%@AE@%%@NL@% %@AB@%' Microsoft BASIC 7.0, Professional Development System%@AE@%%@NL@% %@AB@%' Copyright (C) 1987-1989, Microsoft Corporation%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' NOTE: This sample source code toolbox is intended to demonstrate some%@AE@%%@NL@% %@AB@%' of the extended capabilities of Microsoft BASIC 7.0 Professional%@AE@%%@NL@% %@AB@%' Development system that can help to leverage the professional%@AE@%%@NL@% %@AB@%' developer's time more effectively. While you are free to use,%@AE@%%@NL@% %@AB@%' modify, or distribute the routines in this module in any way you%@AE@%%@NL@% %@AB@%' find useful, it should be noted that these are examples only and%@AE@%%@NL@% %@AB@%' should not be relied upon as a fully-tested "add-on" library.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' PURPOSE: These routines are required for mouse support in the user%@AE@%%@NL@% %@AB@%' interface toolbox, but they may be used independently as well.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' For information on creating a library and QuickLib from the routines%@AE@%%@NL@% %@AB@%' contained in this file, read the comment header of GENERAL.BAS.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%'============================================================================%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@NL@% %@AB@%'$INCLUDE: 'general.bi'%@AE@%%@NL@% %@AB@%'$INCLUDE: 'mouse.bi'%@AE@%%@NL@% %@AB@%'$INCLUDE: 'menu.bi'%@AE@%%@NL@% %@NL@% COMMON SHARED /uitools/ GloMenu AS MenuMiscType%@NL@% COMMON SHARED /uitools/ GloTitle() AS MenuTitleType%@NL@% COMMON SHARED /uitools/ GloItem() AS MenuItemType%@NL@% %@NL@% SUB MouseBorder (row1, col1, row2, col2) STATIC%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Sets max and min bounds on mouse movement both vertically, and%@AE@%%@NL@% %@AB@% ' horizontally%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% MouseDriver 7, 0, (col1 - 1) * 8, (col2 - 1) * 8%@NL@% MouseDriver 8, 0, (row1 - 1) * 8, (row2 - 1) * 8%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB MouseDriver (m0, m1, m2, m3) STATIC%@NL@% %@NL@% DIM regs AS RegType%@NL@% %@NL@% IF MouseChecked = FALSE THEN%@NL@% DEF SEG = 0%@NL@% %@NL@% MouseSegment& = 256& * PEEK(207) + PEEK(206)%@NL@% MouseOffset& = 256& * PEEK(205) + PEEK(204)%@NL@% %@NL@% DEF SEG = MouseSegment&%@NL@% %@NL@% IF (MouseSegment& = 0 AND MouseOffset& = 0) OR PEEK(MouseOffset&) = 207 THEN%@NL@% MousePresent = FALSE%@NL@% MouseChecked = TRUE%@NL@% DEF SEG%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% IF MousePresent = FALSE AND MouseChecked = TRUE THEN%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Calls interrupt 51 to invoke mouse functions in the MS Mouse Driver.%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% regs.ax = m0%@NL@% regs.bx = m1%@NL@% regs.cx = m2%@NL@% regs.dx = m3%@NL@% %@NL@% Interrupt 51, regs, regs%@NL@% %@NL@% m0 = regs.ax%@NL@% m1 = regs.bx%@NL@% m2 = regs.cx%@NL@% m3 = regs.dx%@NL@% %@NL@% IF MouseChecked THEN EXIT SUB%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Check for successful mouse initialization%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% IF m0 AND NOT MouseChecked THEN%@NL@% MousePresent = TRUE%@NL@% END IF%@NL@% %@NL@% MouseChecked = TRUE%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB MouseHide%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Decrements internal cursor flag%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% MouseDriver 2, 0, 0, 0%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB MouseInit%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Mouse driver's initialization routine%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% MouseDriver 0, 0, 0, 0%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB MousePoll (row, col, lButton, rButton) STATIC%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Polls mouse driver, then sets parms correctly%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% MouseDriver 3, button, col, row%@NL@% row = row / 8 + 1%@NL@% col = col / 8 + 1%@NL@% %@NL@% IF button AND 1 THEN%@NL@% lButton = TRUE%@NL@% ELSE%@NL@% lButton = FALSE%@NL@% END IF%@NL@% %@NL@% IF button AND 2 THEN%@NL@% rButton = TRUE%@NL@% ELSE%@NL@% rButton = FALSE%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB MouseShow%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Increments mouse's internal cursor flag%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% MouseDriver 1, 0, 0, 0%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%MUSIC.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MUSIC.BAS%@AE@%%@NL@% %@NL@% %@AB@%' Turn on trapping of background music events:%@AE@%%@NL@% PLAY ON%@NL@% %@NL@% %@AB@%' Branch to the Refresh subroutine when there are fewer than%@AE@%%@NL@% %@AB@%' two notes in the background music buffer:%@AE@%%@NL@% ON PLAY(2) GOSUB Refresh%@NL@% %@NL@% PRINT "Press any key to start, q to end."%@NL@% Pause$ = INPUT$(1)%@NL@% %@NL@% %@AB@%' Select the background music option for PLAY:%@AE@%%@NL@% PLAY "MB"%@NL@% %@NL@% %@AB@%' Start playing the music, so notes will be put in the%@AE@%%@NL@% %@AB@%' background music buffer:%@AE@%%@NL@% GOSUB Refresh%@NL@% %@NL@% I = 0%@NL@% %@NL@% DO%@NL@% %@NL@% %@AB@% ' Print the numbers from 0 to 10,000 over and over until%@AE@%%@NL@% %@AB@% ' the user presses the "q" key. While this is happening,%@AE@%%@NL@% %@AB@% ' the music will repeat in the background:%@AE@%%@NL@% PRINT I%@NL@% I = (I + 1) MOD 10001%@NL@% LOOP UNTIL INKEY$ = "q"%@NL@% %@NL@% END%@NL@% %@NL@% Refresh:%@NL@% %@NL@% %@AB@% ' Plays the opening motive of%@AE@%%@NL@% %@AB@% ' Beethoven's Fifth Symphony:%@AE@%%@NL@% Listen$ = "t180 o2 p2 p8 L8 GGG L2 E-"%@NL@% Fate$ = "p24 p8 L8 FFF L2 D"%@NL@% PLAY Listen$ + Fate$%@NL@% RETURN%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%MXADSTA.ASM%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MXADSTA.ASM%@AE@%%@NL@% %@NL@% %@AB@%;***************************** ADDSTRING ********************************%@AE@%%@NL@% %@AB@%; This procedure accepts two far strings, concatenates them, and%@AE@%%@NL@% %@AB@%; returns the result in the form of a far string.%@AE@%%@NL@% %@NL@% .model medium,basic %@AB@%;Define memory model to match BASIC.%@AE@%%@NL@% .stack%@NL@% .data?%@NL@% maxst = 50 %@AB@%;Maximum bytes reserved for strings%@AE@%%@NL@% inbuffer1 db maxst dup(0) %@AB@%;Room for first fixed-length string%@AE@%%@NL@% inbuffer2 db maxst dup(0) %@AB@%;and second one%@AE@%%@NL@% outbuffer db 2*maxst dup(0) %@AB@%;Work area for string processing%@AE@%%@NL@% .data%@NL@% sh dd 0 %@AB@%;Output string descriptor%@AE@%%@NL@% .code%@NL@% addstring proc uses si di ds, s1:far ptr, s1len, s2:far ptr, s2len%@NL@% %@NL@% %@AB@%;First get BASIC to convert BASIC strings into standard form.%@AE@%%@NL@% les ax,s1 %@AB@%;Push far pointer to%@AE@%%@NL@% push es %@AB@%;input string descriptor.%@AE@%%@NL@% push ax%@NL@% xor ax,ax %@AB@%;Push a zero to indicate%@AE@%%@NL@% push ax %@AB@%;it is variable length.%@AE@%%@NL@% push ds %@AB@%;Push far pointer to%@AE@%%@NL@% lea ax, inbuffer1 %@AB@%;destination string.%@AE@%%@NL@% push ax%@NL@% mov ax,maxst %@AB@%;Push length of destination%@AE@%%@NL@% push ax %@AB@%;fixed-length string.%@AE@%%@NL@% extrn stringassign:proc%@NL@% call stringassign %@AB@%;Call BASIC to assign variable-length%@AE@%%@NL@% %@AB@%;string to fixed-length string.%@AE@%%@NL@% les ax,s2 %@AB@%;Push far pointer to second%@AE@%%@NL@% push es %@AB@%;input string descriptor.%@AE@%%@NL@% push ax%@NL@% xor ax,ax %@AB@%;Push a zero to indicate%@AE@%%@NL@% push ax %@AB@%;it is variable length.%@AE@%%@NL@% push ds %@AB@%;Push far pointer to%@AE@%%@NL@% lea ax,inbuffer2 %@AB@%;second destination string.%@AE@%%@NL@% push ax%@NL@% mov ax,maxst %@AB@%;Push length of destination%@AE@%%@NL@% push ax %@AB@%;fixed-length string.%@AE@%%@NL@% extrn stringassign:proc%@NL@% call stringassign %@AB@%;Call BASIC to assign variable-length%@AE@%%@NL@% %@AB@%;string to fixed-length string.%@AE@%%@NL@% %@AB@%;Concatenate strings.%@AE@%%@NL@% lea si,inbuffer1 %@AB@%;Copy first string to buffer.%@AE@%%@NL@% lea di,outbuffer%@NL@% mov ax,ds%@NL@% mov es,ax%@NL@% mov cx,s1len%@NL@% rep movsb%@NL@% lea si,inbuffer2 %@AB@%;Concatenate second string to%@AE@%%@NL@% mov cx,s2len %@AB@%;end of first.%@AE@%%@NL@% rep movsb%@NL@% %@NL@% %@AB@%;Get BASIC to convert result back into a BASIC string.%@AE@%%@NL@% push ds %@AB@%;Push far pointer to fixed-length%@AE@%%@NL@% lea ax,outbuffer %@AB@%;result string.%@AE@%%@NL@% push ax%@NL@% mov ax,s1len %@AB@%;Compute total length of%@AE@%%@NL@% mov bx,s2len %@AB@%;fixed-length result string.%@AE@%%@NL@% add ax,bx%@NL@% push ax %@AB@%;Push length.%@AE@%%@NL@% push ds %@AB@%;Push far pointer to sh (BASIC%@AE@%%@NL@% lea ax,sh %@AB@%;will use this in StringAssign).%@AE@%%@NL@% push ax%@NL@% xor ax,ax %@AB@%;Push a zero for length%@AE@%%@NL@% push ax %@AB@%;indicating variable-length.%@AE@%%@NL@% call stringassign %@AB@%;Call BASIC to assign the%@AE@%%@NL@% %@AB@%;result to sh.%@AE@%%@NL@% lea ax,sh %@AB@%;Return output string pointer%@AE@%%@NL@% %@AB@%;in ax and go back to BASIC.%@AE@%%@NL@% ret%@NL@% %@NL@% addstring endp%@NL@% end%@NL@% %@NL@% %@NL@% %@2@%%@AH@%MXADSTB.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MXADSTB.BAS%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@NL@% %@AB@%'Start program in BASIC for proper initialization.%@AE@%%@NL@% %@AB@%' Define external and internal procedures.%@AE@%%@NL@% DECLARE SUB shakespeare ()%@NL@% DECLARE SUB StringAssign (BYVAL srcsegment, BYVAL srcoffset, BYVAL srclen, BYVAL destsegment, BYVAL destoffset, BYVAL destlen)%@NL@% DECLARE SUB addstring (instrg1off, instrg1len, instrg2off, instrg2len, outstrgoff, outstrglen)%@NL@% DECLARE SUB StringRelease (s$)%@NL@% %@NL@% %@AB@%'Go to main routine in second language%@AE@%%@NL@% CALL shakespeare%@NL@% %@NL@% %@AB@%'The non-BASIC program calls this SUB to add the two strings together%@AE@%%@NL@% SUB addstring (instrg1off, instrg1len, instrg2off, instrg2len, outstrgoff, outstrglen)%@NL@% %@NL@% %@AB@%'Create variable-length strings and transfer non-BASIC fixed strings to them.%@AE@%%@NL@% %@AB@%'Use VARSEG() to compute the segement of the strings returned from the other%@AE@%%@NL@% %@AB@%'language--this is the DGROUP segment, and all string descriptors are found%@AE@%%@NL@% %@AB@%'in this segment (even though the far string itself is elsewhere).%@AE@%%@NL@% %@NL@% CALL StringAssign(VARSEG(a$), instrg1off, instrg1len, VARSEG(a$), VARPTR(a$), 0)%@NL@% CALL StringAssign(VARSEG(b$), instrg2off, instrg2len, VARSEG(b$), VARPTR(b$), 0)%@NL@% %@NL@% %@AB@%' Process the strings--in this case, add them.%@AE@%%@NL@% c$ = a$ + b$%@NL@% %@NL@% %@AB@%' Calculate the new output length.%@AE@%%@NL@% outstrglen = LEN(c$)%@NL@% %@NL@% %@AB@%' Transfer string output to a non-BASIC fixed-length string.%@AE@%%@NL@% CALL StringAssign(VARSEG(c$), VARPTR(c$), 0, VARSEG(c$), outstrgoff, outstrglen)%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%MXADSTC.C%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MXADSTC.C%@AE@%%@NL@% %@NL@% %@AI@%#include %@AE@%<string.h> %@NL@% %@NL@% %@AB@%/* Function Prototypes force either correct data typing or compiler warnings.%@NL@% %@AB@% * Note all functions exported to BASIC and all BASIC callback (extern)%@NL@% %@AB@% * functions are declared with the far pascal calling convention.%@NL@% %@AB@% * WARNING: This must be compiled with the Medium memory model (/AM)%@NL@% %@AB@% */%@AE@%%@NL@% %@NL@% char * pascal addstring( char far *s1, int s1len,%@NL@% char far *s2, int s2len );%@NL@% extern void far pascal StringAssign( char far *source, int slen,%@NL@% char far *dest, int dlen );%@NL@% %@NL@% %@AB@%/* Declare global char array to contain new BASIC string descriptor.%@NL@% %@AB@% */%@AE@%%@NL@% char BASICDesc[4];%@NL@% %@NL@% char * pascal addstring( char far *s1, int s1len,%@NL@% char far *s2, int s2len )%@NL@% {%@NL@% char TS1[50];%@NL@% char TS2[50];%@NL@% char TSBig[100];%@NL@% %@NL@% %@AB@%/* Use the BASIC callback StringAssign to retrieve information%@NL@% %@AB@% * from the descriptors, s1 and s2, and place them in the temporary%@NL@% %@AB@% * arrays TS1 and TS2.%@NL@% %@AB@% */%@AE@%%@NL@% StringAssign( s1, 0, TS1, 49 ); %@AB@%/* Get S1 as array of char */%@AE@%%@NL@% StringAssign( s2, 0, TS2, 49 ); %@AB@%/* Get S2 as array of char */%@AE@%%@NL@% %@NL@% %@AB@%/* Copy the data from TS1 into TSBig, then append the data from%@NL@% %@AB@% * TS2.%@NL@% %@AB@% */%@AE@%%@NL@% memcpy( TSBig, TS1, s1len );%@NL@% memcpy( &TSBig[s1len], TS2, s2len );%@NL@% %@NL@% StringAssign( TSBig, s1len + s2len, BASICDesc, 0 );%@NL@% %@NL@% return BASICDesc;%@NL@% }%@NL@% %@NL@% %@AB@%/*%@NL@% %@AB@% * If, for example, we wanted to return not just one variable length string,%@NL@% %@AB@% * but rather the variable length string and the reverse of that:%@NL@% %@AB@% *%@NL@% %@AB@% * call addstring( "foo ", 4, "bar", 3, a$, r$ )%@NL@% %@AB@% *%@NL@% %@AB@% * you get "foo bar" in a$ and "rab oof" in r$.%@NL@% %@AB@% *%@NL@% %@AB@% * Say you give me s1, and s2 (and their respective lengths) on input; for%@NL@% %@AB@% * output, I want s3 and s4.%@NL@% %@AB@% *%@NL@% %@AB@% * Change the StringAssign for TSBig to assign to s3 instead of BASICDesc.%@NL@% %@AB@% *%@NL@% %@AB@% * Add the following lines of code:%@NL@% %@AB@% *%@NL@% %@AB@% * TSBig[s1len + s2len] = '\0';%@NL@% %@AB@% * strrev( TSBig );%@NL@% %@AB@% * StringAssign( TSBig, s1len + s2len, s4, 0 );%@NL@% %@AB@% *%@NL@% %@AB@% * Delete the return statement.%@NL@% %@AB@% *%@NL@% %@AB@% * Change the prototype and function header to say:%@NL@% %@AB@% *%@NL@% %@AB@% * void far pascal addstring%@NL@% %@AB@% *%@NL@% %@AB@% * instead of%@NL@% %@AB@% *%@NL@% %@AB@% * char far * pascal addstring%@NL@% %@AB@% */%@AE@%%@NL@% %@NL@% %@NL@% %@2@%%@AH@%MXADSTF.FOR%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MXADSTF.FOR%@AE@%%@NL@% %@NL@% %@AB@%C ******************** ADDSTRING *********************%@AE@%%@NL@% %@AB@%C This program is in file MXADSTF.FOR%@AE@%%@NL@% %@AB@%C Declare interface to Stringassign subprogram. The pointer fields are%@AE@%%@NL@% %@AB@%C declared INTEGER*4, so that different types of far pointers can be%@AE@%%@NL@% %@AB@%C passed without conflict. The INTEGER*4 fields are essentially generic%@AE@%%@NL@% %@AB@%C pointers. [VALUE] must be specified, or FORTRAN will pass pointers to%@AE@%%@NL@% %@AB@%C pointers. INTEGER*2 also passed by [VALUE], to be consistent with%@AE@%%@NL@% %@AB@%C declaration of Stringassign.%@AE@%%@NL@% %@AB@%C%@AE@%%@NL@% INTERFACE TO SUBROUTINE STRASG [ALIAS:'STRINGASSIGN'] (S,SL,D,DL)%@NL@% INTEGER*4 S [VALUE]%@NL@% INTEGER*2 SL [VALUE]%@NL@% INTEGER*4 D [VALUE]%@NL@% INTEGER*2 DL [VALUE]%@NL@% END%@NL@% %@AB@%C%@AE@%%@NL@% %@AB@%C Declare heading of Addstring function in the same way as above: the%@AE@%%@NL@% %@AB@%C pointer fields are INTEGER*4%@AE@%%@NL@% %@AB@%C%@AE@%%@NL@% INTEGER*2 FUNCTION ADDSTR [ALIAS:'ADDSTRING'] (S1,S1LEN,S2,S2LEN)%@NL@% INTEGER*4 S1 [VALUE]%@NL@% INTEGER*2 S1LEN [VALUE]%@NL@% INTEGER*4 S2 [VALUE]%@NL@% INTEGER*2 S2LEN [VALUE]%@NL@% %@AB@%C%@AE@%%@NL@% %@AB@%C Local parameters TS1, TS2, and BIGSTR are temporary strings. STRDES is%@AE@%%@NL@% %@AB@%C a four-byte object into which Stringassign will put BASIC string%@AE@%%@NL@% %@AB@%C descriptor.%@AE@%%@NL@% %@AB@%C%@AE@%%@NL@% %@AB@% CHARACTER*50 TS1, TS2%@AE@%%@NL@% %@AB@% CHARACTER*100 BIGSTR%@AE@%%@NL@% INTEGER*4 STRDES%@NL@% %@NL@% TS1 = " "%@NL@% TS2 = " "%@NL@% STRDES = 0%@NL@% %@NL@% %@AB@%C%@AE@%%@NL@% %@AB@%C Use the LOCFAR function to take the far address of data. LOCFAR returns%@AE@%%@NL@% %@AB@%C a value of type INTEGER*4.%@AE@%%@NL@% %@AB@%C%@AE@%%@NL@% %@AB@% CALL STRASG (S1, 0, LOCFAR(TS1), S1LEN)%@AE@%%@NL@% %@AB@% CALL STRASG (S2, 0, LOCFAR(TS2), S2LEN)%@AE@%%@NL@% BIGSTR = TS1(1:S1LEN) // TS2(1:S2LEN)%@NL@% %@AB@% CALL STRASG (LOCFAR(BIGSTR), S1LEN+S2LEN, LOCFAR(STRDES), 0)%@AE@%%@NL@% ADDSTR = LOC(STRDES)%@NL@% RETURN%@NL@% END%@NL@% %@NL@% %@NL@% %@2@%%@AH@%MXSHKA.ASM%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MXSHKA.ASM%@AE@%%@NL@% %@NL@% %@AB@%;*************************** SHAKESPEARE ******************************%@AE@%%@NL@% %@AB@%; This program creates two strings and passes them to a BASIC procedure%@AE@%%@NL@% %@AB@%; called addstring (in file MXADSTB.BAS). This procedure concatenates%@AE@%%@NL@% %@AB@%; the strings and passes the result to MASM which prints it.%@AE@%%@NL@% %@NL@% .model medium,basic %@AB@%;Use same memory model as BASIC.%@AE@%%@NL@% .stack%@NL@% .data %@AB@%;Create the data.%@AE@%%@NL@% phrase1 db "To be or not to be%@AB@%;"%@AE@%%@NL@% phrase1len dw $-phrase1%@NL@% phrase1off dw phrase1%@NL@% phrase2 db " that is the question."%@NL@% phrase2len dw $-phrase2%@NL@% phrase2off dw phrase2%@NL@% sentence db 100 dup(0) %@AB@%;Make room for return data%@AE@%%@NL@% sentencelen dw 0 %@AB@%;and a length indicator.%@AE@%%@NL@% sentenceoff dw sentence%@NL@% %@NL@% .code%@NL@% shakespeare proc uses si%@NL@% %@NL@% %@AB@%;First call BASIC to concatenate strings.%@AE@%%@NL@% lea ax,phrase1off %@AB@%;Push far address of%@AE@%%@NL@% push ax %@AB@%;fixed-length string #1,%@AE@%%@NL@% lea ax,phrase1len %@AB@%;and its length.%@AE@%%@NL@% push ax%@NL@% lea ax,phrase2off %@AB@%;Do the same for the%@AE@%%@NL@% push ax %@AB@%;address of string #2,%@AE@%%@NL@% lea ax,phrase2len %@AB@%;and its length.%@AE@%%@NL@% push ax%@NL@% lea ax,sentenceoff %@AB@%;Push far address of%@AE@%%@NL@% push ax %@AB@%;the return string,%@AE@%%@NL@% lea ax,sentencelen %@AB@%;and its length.%@AE@%%@NL@% push ax%@NL@% extrn addstring:proc %@AB@%;Call BASIC function to%@AE@%%@NL@% call addstring %@AB@%;concatenate the strings and%@AE@%%@NL@% %@AB@%;put the result in the%@AE@%%@NL@% %@AB@%;fixed-length return string.%@AE@%%@NL@% %@NL@% %@AB@%;Call DOS to print string. The DOS string output routine (09H)%@AE@%%@NL@% %@AB@%;requires that strings end with a "$" character.%@AE@%%@NL@% mov bx,sentencelen %@AB@%;Go to end of the result string%@AE@%%@NL@% lea si,sentence %@AB@%;and add a "$" (24h) character.%@AE@%%@NL@% mov byte ptr [bx + si],24h%@NL@% %@NL@% lea dx,sentence %@AB@%;Set up registers%@AE@%%@NL@% mov ah,9 %@AB@%;and call DOS to%@AE@%%@NL@% int 21h %@AB@%;print result string.%@AE@%%@NL@% ret%@NL@% %@NL@% shakespeare endp%@NL@% %@NL@% end%@NL@% %@NL@% %@NL@% %@2@%%@AH@%MXSHKB.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MXSHKB.BAS%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@AB@%'Define non-basic procedures%@AE@%%@NL@% DECLARE FUNCTION addstring$(SEG s1$, BYVAL s1length, SEG s2$, BYVAL s2length)%@NL@% %@NL@% %@NL@% %@AB@%'Create the data%@AE@%%@NL@% a$ = "To be or not to be;"%@NL@% b$ = " that is the question."%@NL@% %@NL@% %@AB@%'Use non-BASIC function to add two BASIC far strings%@AE@%%@NL@% c$ = addstring(a$, LEN(a$), b$, LEN(b$))%@NL@% %@NL@% %@AB@%'print the result on the screen%@AE@%%@NL@% %@NL@% PRINT c$%@NL@% %@NL@% %@NL@% %@2@%%@AH@%MXSHKC.C%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MXSHKC.C%@AE@%%@NL@% %@NL@% %@AI@%#include %@AE@%<stdio.h> %@NL@% %@AI@%#include %@AE@%<string.h> %@NL@% %@NL@% %@AB@%/* Function Prototypes force either correct data typing or compiler warnings.%@NL@% %@AB@% * Note all functions exported to BASIC and all BASIC callback (extern)%@NL@% %@AB@% * functions are declared with the far pascal calling convention.%@NL@% %@AB@% * IMPORTANT: This must be compiled with the Medium memory model (/AM)%@NL@% %@AB@% */%@AE@%%@NL@% void far pascal shakespeare( void );%@NL@% extern void far pascal addstring( char ** s1, int * s1len,%@NL@% char ** s2, int * s2len,%@NL@% char ** s3, int * s3len );%@NL@% %@NL@% void far pascal shakespeare( void )%@NL@% {%@NL@% char * s1 = "To be or not to be;";%@NL@% int s1len;%@NL@% char * s2 = " that is the question.";%@NL@% int s2len;%@NL@% char s3[100];%@NL@% int s3len;%@NL@% char * s3add = s3;%@NL@% %@NL@% s1len = strlen( s1 );%@NL@% s2len = strlen( s2 );%@NL@% addstring( &s1, &s1len, &s2, &s2len, &s3add, &s3len );%@NL@% %@NL@% s3[s3len] = '\0';%@NL@% printf("\n%s", s3 );%@NL@% }%@NL@% %@NL@% %@NL@% %@2@%%@AH@%MXSHKF.FOR%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\MXSHKF.FOR%@AE@%%@NL@% %@NL@% %@AB@%C *********************** SHAKESPEARE ****************%@AE@%%@NL@% %@AB@%C This program is in file MXSHKF.FOR%@AE@%%@NL@% %@AB@%C Declare interface to BASIC routine ADDSTRING.%@AE@%%@NL@% %@AB@%C All parameters must be passed NEAR, for compatibility with BASIC's%@AE@%%@NL@% %@AB@%C conventions.%@AE@%%@NL@% %@AB@%C%@AE@%%@NL@% %@NL@% %@NL@% INTERFACE TO SUBROUTINE ADDSTR[ALIAS:'ADDSTRING']%@NL@% * (S1,L1,S2,L2,S3,L3)%@NL@% INTEGER*2 S1 [NEAR]%@NL@% INTEGER*2 L1 [NEAR]%@NL@% INTEGER*2 S2 [NEAR]%@NL@% INTEGER*2 L2 [NEAR]%@NL@% INTEGER*2 S3 [NEAR]%@NL@% INTEGER*2 L3 [NEAR]%@NL@% END%@NL@% %@AB@%C%@AE@%%@NL@% %@AB@%C Declare subroutine SHAKESPEARE, which declares two strings, calls BASIC%@AE@%%@NL@% %@AB@%C subroutine ADDSTRING, and prints the result.%@AE@%%@NL@% %@AB@%C%@AE@%%@NL@% SUBROUTINE SHAKES [ALIAS:'SHAKESPEARE']%@NL@% %@AB@% CHARACTER*50 STR1, STR2%@AE@%%@NL@% %@AB@% CHARACTER*100 STR3%@AE@%%@NL@% INTEGER*2 STRLEN1, STRLEN2, STRLEN3%@NL@% INTEGER*2 TMP1, TMP2, TMP3%@NL@% %@AB@%C%@AE@%%@NL@% %@AB@%C The subroutine uses FORTRAN LEN_TRIM function, which returns the length%@AE@%%@NL@% %@AB@%C of string, excluding trailing blanks. (All FORTRAN strings are initialized%@AE@%%@NL@% %@AB@%C to blanks.)%@AE@%%@NL@% %@AB@%C%@AE@%%@NL@% STR1 = 'To be or not to be;'%@NL@% STRLEN1 = LEN_TRIM(STR1)%@NL@% STR2 = ' that is the question.'%@NL@% STRLEN2 = LEN_TRIM(STR2)%@NL@% TMP1 = LOC(STR1)%@NL@% TMP2 = LOC(STR2)%@NL@% TMP3 = LOC(STR3)%@NL@% %@AB@% CALL ADDSTR (TMP1, STRLEN1, TMP2, STRLEN2, TMP3, STRLEN3)%@AE@%%@NL@% WRITE (*,*) STR3%@NL@% END%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%PALETTE.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\PALETTE.BAS%@AE@%%@NL@% %@NL@% DECLARE SUB InitPalette ()%@NL@% DECLARE SUB ChangePalette ()%@NL@% DECLARE SUB DrawEllipses ()%@NL@% %@NL@% DEFINT A-Z%@NL@% DIM SHARED PaletteArray(15)%@NL@% %@NL@% SCREEN 8 ' 640 x 200 resolution; 16 colors%@NL@% %@NL@% InitPalette ' Initialize PaletteArray.%@NL@% DrawEllipses ' Draw and paint concentric ellipses.%@NL@% %@NL@% DO ' Shift the palette until a key%@NL@% ChangePalette ' is pressed.%@NL@% LOOP WHILE INKEY$ = ""%@NL@% %@NL@% END%@NL@% %@NL@% %@NL@% %@AB@%' ====================== InitPalette ======================%@AE@%%@NL@% %@AB@%' This procedure initializes the integer array used to%@AE@%%@NL@% %@AB@%' change the palette.%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% SUB InitPalette STATIC%@NL@% FOR I = 0 TO 15%@NL@% PaletteArray(I) = I%@NL@% NEXT I%@NL@% END SUB%@NL@% %@AB@%' ===================== DrawEllipses ======================%@AE@%%@NL@% %@AB@%' This procedure draws 15 concentric ellipses and%@AE@%%@NL@% %@AB@%' paints the interior of each with a different color.%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% SUB DrawEllipses STATIC%@NL@% CONST ASPECT = 1 / 3%@NL@% FOR ColorVal = 15 TO 1 STEP -1%@NL@% Radius = 20 * ColorVal%@NL@% CIRCLE (320, 100), Radius, ColorVal, , , ASPECT%@NL@% PAINT (320, 100), ColorVal%@NL@% NEXT%@NL@% END SUB%@NL@% %@NL@% %@NL@% %@AB@%' ===================== ChangePalette =====================%@AE@%%@NL@% %@AB@%' This procedure rotates the palette by one each time it%@AE@%%@NL@% %@AB@%' is called. For example, after the first call to%@AE@%%@NL@% %@AB@%' ChangePalette, PaletteArray(1) = 2, PaletteArray(2) = 3,%@AE@%%@NL@% %@AB@%' . . . , PaletteArray(14) = 15, and PaletteArray(15) = 1%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% SUB ChangePalette STATIC%@NL@% FOR I = 1 TO 15%@NL@% PaletteArray(I) = (PaletteArray(I) MOD 15) + 1%@NL@% NEXT I%@NL@% PALETTE USING PaletteArray(0) ' Shift the color displayed%@NL@% %@AB@% ' by each of the attributes.%@AE@%%@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%PASSWRD.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\PASSWRD.BAS%@AE@%%@NL@% %@NL@% DECLARE FUNCTION CertifiedOperator% ()%@NL@% CONST FALSE = 0, True = NOT FALSE%@NL@% %@NL@% IF CertifiedOperator = FALSE THEN%@NL@% PRINT "Connection Refused."%@NL@% END%@NL@% END IF%@NL@% %@NL@% PRINT "Connected to Network."%@NL@% %@AB@%'Main program continues here.%@AE@%%@NL@% %@AB@%' .%@AE@%%@NL@% %@AB@%' .%@AE@%%@NL@% %@AB@%' .%@AE@%%@NL@% END%@NL@% %@NL@% FUNCTION CertifiedOperator%%@NL@% ON LOCAL ERROR GOTO Handler%@NL@% %@AB@%'Count the number of times the operator tries to sign on.%@AE@%%@NL@% Attempts% = 0%@NL@% %@NL@% TryAgain:%@NL@% %@AB@%'Assume the operator has valid credentials.%@AE@%%@NL@% CertifiedOperator = True%@NL@% %@AB@%'Keep track of bad entries.%@AE@%%@NL@% Attempts% = Attempts% + 1%@NL@% IF Attempts% > 3 THEN ERROR 255%@NL@% %@AB@%'Check out the operator's credentials.%@AE@%%@NL@% INPUT "Enter Account Number"; Account$%@NL@% IF LEFT$(Account$, 4) <> "1234" THEN ERROR 200%@NL@% INPUT "Enter Password"; Password$%@NL@% IF Password$ <> "Swordfish" THEN ERROR 201%@NL@% EXIT FUNCTION%@NL@% %@NL@% Handler:%@NL@% SELECT CASE ERR%@NL@% %@AB@% 'Start over if account number doesn't have "1234" in it.%@AE@%%@NL@% CASE 200%@NL@% PRINT "Illegal account number. Please re-enter."%@NL@% RESUME TryAgain%@NL@% %@AB@% 'Start over if the password is wrong.%@AE@%%@NL@% CASE 201%@NL@% PRINT "Wrong password. Please re-enter both items."%@NL@% RESUME TryAgain%@NL@% %@AB@% 'Return false if operator makes too many mistakes.%@AE@%%@NL@% CASE 255%@NL@% CertifiedOperator% = FALSE%@NL@% EXIT FUNCTION%@NL@% END SELECT%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@2@%%@AH@%PGBAR.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\PGBAR.BAS%@AE@%%@NL@% %@NL@% %@AB@%' PGBAR.BAS: Create sample bar chart%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@AB@%' $INCLUDE: 'CHRTB.BI'%@AE@%%@NL@% CONST FALSE = 0, TRUE = NOT FALSE, MONTHS = 12%@NL@% CONST HIGHESTMODE = 13, TEXTONLY = 0%@NL@% %@NL@% DIM Env AS ChartEnvironment ' See CHRTB.BI for declaration of ' the ChartEnvironment type%@NL@% DIM MonthCategories(1 TO MONTHS) AS STRING ' Array for categories (used for%@NL@% %@AB@% ' Pie, Column and Bar Charts)%@AE@%%@NL@% DIM OJvalues(1 TO MONTHS) AS SINGLE ' Array for 1st data series%@NL@% %@NL@% DECLARE FUNCTION BestMode ()%@NL@% %@NL@% %@AB@%' Initialize the data arrays%@AE@%%@NL@% FOR index = 1 TO MONTHS: READ OJvalues(index): NEXT index%@NL@% FOR index = 1 TO MONTHS: READ MonthCategories$(index): NEXT index%@NL@% %@NL@% %@AB@%' Pass the value returned by the BestMode function to the Presentation%@AE@%%@NL@% %@AB@%' Graphics routine ChartScreen to set the graphics mode for charting%@AE@%%@NL@% %@NL@% ChartScreen (BestMode) ' Even if SCREEN is already set to an acceptable%@NL@% %@AB@% ' mode, you still have to set it with ChartScreen%@AE@%%@NL@% IF ChartErr = cBadScreen THEN ' Check to make sure ChartScreen succeeded%@NL@% PRINT "Sorry --- There is a screen-mode problem in the Charting library"%@NL@% END%@NL@% END IF%@NL@% %@AB@%' Initialize a default pie chart%@AE@%%@NL@% %@AB@% ' Pass Env (the environment variable),%@AE@%%@NL@% DefaultChart Env, cBar, cPlain ' the constant cBar (for Bar Chart) and%@NL@% %@AB@% ' cPlain%@AE@%%@NL@% %@NL@% %@AB@%' Add Titles and some chart options. These assignments modify some default%@AE@%%@NL@% %@AB@%' values set in the variable Env (of type ChartEnvironment) by DefaultChart%@AE@%%@NL@% %@NL@% Env.MainTitle.Title = "Good Neighbor Grocery" ' Specifies text of chart title%@NL@% Env.MainTitle.TitleColor = 15 ' Specifies color of title text%@NL@% Env.MainTitle.Justify = cRight ' How to align of title text%@NL@% Env.SubTitle.Title = "Orange Juice Sales" ' Text of chart subtitle%@NL@% Env.SubTitle.TitleColor = 15 ' Color of subtitle text%@NL@% Env.SubTitle.Justify = cRight ' How to align of subtitle text%@NL@% Env.ChartWindow.Border = cNo ' Specifies chart has no border%@NL@% %@NL@% %@AB@%' The next 2 assignments label the x-axis and y-axis%@AE@%%@NL@% Env.XAxis.AxisTitle.Title = "Quantity (cases)"%@NL@% Env.YAxis.AxisTitle.Title = "Months"%@NL@% %@NL@% %@AB@%' Call the bar-charting routine --- Arguments for call to Chart are:%@AE@%%@NL@% %@AB@%' Env - Environment variable%@AE@%%@NL@% %@AB@%' MonthCategories() - Array containing Category labels%@AE@%%@NL@% %@AB@%' OJvalues() - Array containing Data values to chart%@AE@%%@NL@% %@AB@%' MONTHS - Tells number of data values to chart%@AE@%%@NL@% %@NL@% Chart Env, MonthCategories(), OJvalues(), MONTHS%@NL@% SLEEP%@NL@% %@AB@% ' If the rest of your program isn't graphic, reset original mode here%@AE@%%@NL@% END%@NL@% %@NL@% %@AB@%' Simulate data generation for chart values and category labels%@AE@%%@NL@% DATA 33,27,42,64,106,157,182,217,128,62,43,36%@NL@% DATA "Jan","Feb","Mar","Apr","May","Jun","Jly","Aug","Sep","Oct","Nov","Dec",%@NL@% %@NL@% %@AB@%'============= Function to determine and set highest resolution ========%@AE@%%@NL@% %@AB@%' The BestMode function uses a local error trap to check available modes,%@AE@%%@NL@% %@AB@%' then assigns the integer representing the best mode for charting to its%@AE@%%@NL@% %@AB@%' name so it is returned to the caller. The function terminate execution if%@AE@%%@NL@% %@AB@%' the hardware doesn't support a mode appropriate for Presentation Graphics%@AE@%%@NL@% %@AB@%'========================================================================%@AE@%%@NL@% FUNCTION BestMode%@NL@% %@NL@% %@AB@%' Set a trap for an expected local error --- handled within the function%@AE@%%@NL@% ON LOCAL ERROR GOTO ScreenError%@NL@% %@NL@% FOR TestValue = HIGHESTMODE TO 0 STEP -1%@NL@% DisplayError = FALSE%@NL@% SCREEN TestValue%@NL@% IF DisplayError = FALSE THEN%@NL@% SELECT CASE TestValue%@NL@% CASE 12, 13%@NL@% BestMode = 12%@NL@% CASE 9, 10, 11%@NL@% BestMode = 9%@NL@% CASE 8, 4, 3%@NL@% BestMode = TestValue%@NL@% CASE 2, 7%@NL@% BestMode = 2%@NL@% CASE 1%@NL@% BestMode = 1%@NL@% CASE ELSE%@NL@% PRINT "Sorry, you need graphics to display charts"%@NL@% END%@NL@% END SELECT%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% NEXT TestValue%@NL@% %@AB@%' Note there is no need to turn off the local error handler. It is turned off%@AE@%%@NL@% %@AB@%' automatically when control passes out of the function%@AE@%%@NL@% %@NL@% EXIT FUNCTION%@NL@% %@AB@%'==================== | Local error handler code |=======================%@AE@%%@NL@% %@AB@%' The ScreenError label identifies a local error handler relied in the%@AE@%%@NL@% %@AB@%' BestMode function. Invalid SCREEN values generate Error # 5 (Illegal%@AE@%%@NL@% %@AB@%' function call) --- so if that is not the error reset ERROR to the ERR%@AE@%%@NL@% %@AB@%' value that was generated so the error can be passed to other, possibly%@AE@%%@NL@% %@AB@%' more appropriate errors.%@AE@%%@NL@% ScreenError:%@NL@% IF ERR = 5 THEN%@NL@% DisplayError = TRUE%@NL@% RESUME NEXT%@NL@% ELSE%@NL@% ERROR ERR%@NL@% END IF%@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%PGLINEMS.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\PGLINEMS.BAS%@AE@%%@NL@% %@NL@% %@AB@%' PGLINEMS.BAS - Program to generate a simple multi-data series line chart%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@AB@%'$INCLUDE: 'CHRTB.BI' ' Declarations and Definitions%@AE@%%@NL@% DIM Env AS ChartEnvironment ' Variable to hold environment structure%@NL@% DIM AxisLabels(1 TO 4) AS STRING ' Array of categories%@NL@% DIM LegendLabels(1 TO 2) AS STRING ' Array of series labels%@NL@% DIM Values(1 TO 4, 1 TO 3) AS SINGLE ' 2-dimentsion array of values to plot%@NL@% %@NL@% DIM Col%(0 TO cPalLen) ' Define arrays to hold values retrieved with%@NL@% DIM Lines%(0 TO cPalLen) ' call to GetPaletteDef. By modifying these%@NL@% DIM Fill$(0 TO cPalLen) ' values, then calling ResetPaletteDef, you%@NL@% DIM Char%(0 TO cPalLen) ' can change colors, plot characters, borders,%@NL@% DIM Bord%(0 TO cPalLen) ' and even the line styles and fill patterns%@NL@% %@NL@% %@AB@%' Read the data to display into the arrays%@AE@%%@NL@% %@NL@% FOR index = 1 TO 2: READ LegendLabels(index): NEXT index%@NL@% FOR index = 1 TO 4: READ AxisLabels(index): NEXT index%@NL@% %@NL@% FOR columnindex = 1 TO 2 ' The array has 2 columns, each of%@NL@% FOR rowindex = 1 TO 4 ' which has 4 rows. Each column rep-%@NL@% READ Values(rowindex, columnindex) ' resents 1 full data series. First,%@NL@% NEXT rowindex ' fill column 1, then fill column 2%@NL@% NEXT columnindex ' with values from the last DATA%@NL@% %@AB@% ' statement (below).%@AE@%%@NL@% CLS%@NL@% %@NL@% ChartScreen 2 ' Set a common graphics mode%@NL@% %@NL@% %@AB@%' Retrieve current palette settings, then assign some new values%@AE@%%@NL@% %@NL@% GetPaletteDef Col%(), Lines%(), Fill$(), Char%(), Bord%()%@NL@% %@NL@% Col%(2) = (15) ' Assign white as color for second-series plot line%@NL@% Char%(1) = (4) ' Assign "" as plot character for 1st plot line%@NL@% Char%(2) = (18) ' Assign "" as plot character for 2nd plot line%@NL@% %@NL@% %@AB@%' Reset the palettes with modified arrays%@AE@%%@NL@% %@NL@% SetPaletteDef Col%(), Lines%(), Fill$(), Char%(), Bord%() ' Enter the changes%@NL@% %@NL@% DefaultChart Env, cLine, cLines ' Set up multi-series line chart%@NL@% %@NL@% %@AB@%' Display the chart%@AE@%%@NL@% %@NL@% ChartMS Env, AxisLabels(), Values(), 4, 1, 2, LegendLabels()%@NL@% %@NL@% SLEEP ' Keep it onscreen until user presses%@NL@% %@AB@% ' a key%@AE@%%@NL@% END%@NL@% %@NL@% %@AB@%' Simulated data to be shown on chart%@AE@%%@NL@% DATA "Qtr 1","Qtr 2"%@NL@% DATA "Admn","Markg","Prodn","Devel"%@NL@% DATA 38,30,40,32,18,40,20,12%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%PGPIE.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\PGPIE.BAS%@AE@%%@NL@% %@NL@% %@AB@%' PGPIE.BAS: Create sample pie chart%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@AB@%' $INCLUDE: 'fontb.BI'%@AE@%%@NL@% %@AB@%' $INCLUDE: 'CHRTB.BI'%@AE@%%@NL@% CONST FALSE = 0, TRUE = NOT FALSE, MONTHS = 12%@NL@% CONST HIGHESTMODE = 13, TEXTONLY = 0%@NL@% %@NL@% DIM Env AS ChartEnvironment ' See CHRTB.BI for declaration of ' the ChartEnvironment type%@NL@% DIM MonthCategories(1 TO MONTHS) AS STRING ' Array for categories%@NL@% DIM OJvalues(1 TO MONTHS) AS SINGLE ' Array for 1st data series%@NL@% DIM Exploded(1 TO MONTHS) AS INTEGER ' "Explode" flags array (specifies%@NL@% %@AB@% ' which pie slices are separated)%@AE@%%@NL@% DECLARE FUNCTION BestMode ()%@NL@% %@NL@% %@AB@%' Initialize the data arrays%@AE@%%@NL@% FOR index = 1 TO MONTHS: READ OJvalues(index): NEXT index%@NL@% FOR index = 1 TO MONTHS: READ MonthCategories$(index): NEXT index%@NL@% %@NL@% %@AB@%' Set the elements of the array that determines separation of the pie slices%@AE@%%@NL@% FOR Flags = 1 TO MONTHS ' If value of OJvalues(Flags)%@NL@% Exploded(Flags) = (OJvalues(Flags) >= 100) ' >= 100 the corresponding flag%@NL@% NEXT Flags ' is set true, separating slices%@NL@% %@NL@% %@AB@%' Pass the value returned by the BestMode function to the Presentation%@AE@%%@NL@% %@AB@%' Graphics routine ChartScreen to set the graphics mode for charting%@AE@%%@NL@% %@NL@% ChartScreen (BestMode) ' Even if SCREEN is already set to an acceptable%@NL@% %@AB@% ' mode, you still have to set it with ChartScreen%@AE@%%@NL@% %@NL@% IF ChartErr = cBadScreen THEN ' Check to make sure ChartScreen succeeded%@NL@% PRINT "Sorry --- There is a screen-mode problem in the Charting library"%@NL@% END%@NL@% END IF%@NL@% %@NL@% %@AB@%' Initialize a default pie chart%@AE@%%@NL@% %@AB@% ' Pass Env (the environment variable),%@AE@%%@NL@% DefaultChart Env, cPie, cPercent ' the constant cPie (for Pie Chart) and%@NL@% %@AB@% ' cPercent (label slices with percentage)%@AE@%%@NL@% %@NL@% %@AB@%' Add Titles and some chart options. These assignments modify some default%@AE@%%@NL@% %@AB@%' values set in the variable Env (of type ChartEnvironment) by DefaultChart%@AE@%%@NL@% %@NL@% %@NL@% Env.MainTitle.Title = "Good Neighbor Grocery" ' Specifies text of chart title%@NL@% Env.MainTitle.TitleColor = 15 ' Specifies color of title text%@NL@% Env.MainTitle.Justify = cCenter ' How to align of title text%@NL@% Env.SubTitle.Title = "Orange Juice Sales" ' Text of chart subtitle%@NL@% Env.SubTitle.TitleColor = 11 ' Color of subtitle text%@NL@% Env.SubTitle.Justify = cCenter ' How to align of subtitle text%@NL@% Env.ChartWindow.Border = cYes ' Specifies chart has no border%@NL@% %@NL@% %@AB@%' Call the pie-charting routine --- Arguments for call to ChartPie are:%@AE@%%@NL@% %@AB@%' Env - Environment variable%@AE@%%@NL@% %@AB@%' MonthCategories() - Array containing Category labels%@AE@%%@NL@% %@AB@%' OJvalues() - Array containing Data values to chart%@AE@%%@NL@% %@AB@%' Exploded() - Integer array tells which pieces of the pie should%@AE@%%@NL@% %@AB@%' be separated (non-zero=exploded, 0=not exploded)%@AE@%%@NL@% %@AB@%' MONTHS - Tells number of data values to chart%@AE@%%@NL@% %@NL@% ChartPie Env, MonthCategories(), OJvalues(), Exploded(), MONTHS%@NL@% SLEEP%@NL@% %@AB@% ' If the rest of your program isn't graphic, reset original mode here%@AE@%%@NL@% END%@NL@% %@NL@% %@AB@%' Simulate data generation for chart values and category labels%@AE@%%@NL@% DATA 33,27,42,64,106,157,182,217,128,62,43,36%@NL@% DATA "Jan","Feb","Mar","Apr","May","Jun","Jly","Aug","Sep","Oct","Nov","Dec"%@NL@% %@NL@% %@AB@%'============= Function to determine and set highest resolution ========%@AE@%%@NL@% %@AB@%' The BestMode function uses a local error trap to check available modes,%@AE@%%@NL@% %@AB@%' then assigns the integer representing the best mode for charting to its%@AE@%%@NL@% %@AB@%' name so it is returned to the caller. The function terminate execution if%@AE@%%@NL@% %@AB@%' the hardware doesn't support a mode appropriate for Presentation Graphics%@AE@%%@NL@% %@AB@%'========================================================================%@AE@%%@NL@% FUNCTION BestMode%@NL@% %@NL@% %@AB@%' Set a trap for an expected local error --- handled within the function%@AE@%%@NL@% ON LOCAL ERROR GOTO ScreenError%@NL@% %@NL@% FOR TestValue = HIGHESTMODE TO 0 STEP -1%@NL@% DisplayError = FALSE%@NL@% SCREEN TestValue%@NL@% IF DisplayError = FALSE THEN%@NL@% SELECT CASE TestValue%@NL@% CASE 12, 13%@NL@% BestMode = 12%@NL@% CASE 9, 10, 11%@NL@% BestMode = 9%@NL@% CASE 8, 4, 3%@NL@% BestMode = TestValue%@NL@% CASE 2, 7%@NL@% BestMode = 2%@NL@% CASE 1%@NL@% BestMode = 1%@NL@% CASE ELSE%@NL@% PRINT "Sorry, you need graphics to display charts"%@NL@% END%@NL@% END SELECT%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% NEXT TestValue%@NL@% %@AB@%' Note there is no need to turn off the local error handler. It is turned off%@AE@%%@NL@% %@AB@%' automatically when control passes out of the function%@AE@%%@NL@% %@NL@% EXIT FUNCTION%@NL@% %@AB@%'==================== | Local error handler code |=======================%@AE@%%@NL@% %@AB@%' The ScreenError label identifies a local error handler relied in the%@AE@%%@NL@% %@AB@%' BestMode function. Invalid SCREEN values generate Error # 5 (Illegal%@AE@%%@NL@% %@AB@%' function call) --- so if that is not the error reset ERROR to the ERR%@AE@%%@NL@% %@AB@%' value that was generated so the error can be passed to other, possibly%@AE@%%@NL@% %@AB@%' more appropriate errors.%@AE@%%@NL@% ScreenError:%@NL@% IF ERR = 5 THEN%@NL@% DisplayError = TRUE%@NL@% RESUME NEXT%@NL@% ELSE%@NL@% ERROR ERR%@NL@% END IF%@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%PGSCAT.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\PGSCAT.BAS%@AE@%%@NL@% %@NL@% %@AB@%' PGSCAT.BAS: Create sample scatter diagram%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@AB@%' $INCLUDE: 'CHRTB.BI'%@AE@%%@NL@% CONST FALSE = 0, TRUE = NOT FALSE, MONTHS = 12%@NL@% CONST HIGHESTMODE = 13, TEXTONLY = 0%@NL@% %@NL@% DIM Env AS ChartEnvironment ' See CHRTB.BI for declaration of ' the%@NL@% %@AB@% ' ChartEnvironment type%@AE@%%@NL@% DIM OJvalues(1 TO MONTHS) AS SINGLE ' Array for 1st data series%@NL@% DIM HCvalues(1 TO MONTHS) AS SINGLE ' Array for 2nd data series%@NL@% DECLARE FUNCTION BestMode ()%@NL@% %@NL@% %@AB@%' Initialize the data arrays%@AE@%%@NL@% FOR index = 1 TO MONTHS: READ OJvalues(index): NEXT index%@NL@% FOR index = 1 TO MONTHS: READ HCvalues(index): NEXT index%@NL@% %@NL@% %@AB@%' Pass the value returned by the BestMode function to the Presentation%@AE@%%@NL@% %@AB@%' Graphics routine ChartScreen to set the graphics mode for charting%@AE@%%@NL@% %@NL@% ChartScreen (BestMode) ' Even if SCREEN is already set to an acceptable%@NL@% %@AB@% ' mode, you still have to set it with ChartScreen%@AE@%%@NL@% IF ChartErr = cBadScreen THEN ' Check to make sure ChartScreen succeeded%@NL@% PRINT "Sorry --- There is a screen-mode problem in the Charting library"%@NL@% END%@NL@% END IF%@NL@% %@NL@% %@AB@%' Initialize a default pie chart%@AE@%%@NL@% %@AB@% ' Pass Env (the environment variable);%@AE@%%@NL@% DefaultChart Env, cScatter, cNoLines ' constant cScatter (for Scatter Chart);%@NL@% %@AB@% ' cNoLines (unjoined points)%@AE@%%@NL@% %@NL@% %@AB@%' Add Titles and some chart options. These assignments modify some default%@AE@%%@NL@% %@AB@%' values set in the variable Env (of type ChartEnvironment) by DefaultChart%@AE@%%@NL@% %@NL@% Env.MainTitle.Title = "Good Neighbor Grocery" ' Specifies text of chart title%@NL@% Env.MainTitle.TitleColor = 11 ' Specifies color of title text%@NL@% Env.MainTitle.Justify = cRight ' How to align of title text%@NL@% Env.SubTitle.Title = "OJ vs. Hot Chocolate" ' Text of chart subtitle%@NL@% Env.SubTitle.TitleColor = 15 ' Color of subtitle text%@NL@% Env.SubTitle.Justify = cRight ' How to align of subtitle text%@NL@% Env.ChartWindow.Border = cNo ' Specifies chart has no border%@NL@% %@NL@% %@AB@%' The next two assignments label the x and y axes of the chart%@AE@%%@NL@% Env.XAxis.AxisTitle.Title = "Orange Juice Sales"%@NL@% Env.YAxis.AxisTitle.Title = "Hot Chocolate Sales"%@NL@% %@NL@% %@AB@%' Call the pie-charting routine --- Arguments for call to ChartPie are:%@AE@%%@NL@% %@AB@%' Env - Environment variable%@AE@%%@NL@% %@AB@%' OJvalues - Array containing orange-juice sales values to chart%@AE@%%@NL@% %@AB@%' HCvalues - Array containing hot-chocolate sales values to chart%@AE@%%@NL@% %@AB@%' MONTHS - Tells number of data values to chart%@AE@%%@NL@% %@NL@% ChartScatter Env, OJvalues(), HCvalues(), MONTHS%@NL@% SLEEP%@NL@% %@AB@% ' If the rest of your program isn't graphic, reset original mode here%@AE@%%@NL@% END%@NL@% %@NL@% %@AB@%' Simulate data generation for chart values and category labels%@AE@%%@NL@% DATA 33,27,42,64,106,157,182,217,128,62,43,36%@NL@% DATA 37,37,30,19,10,5,2,1,7,15,28,39%@NL@% %@NL@% %@AB@%'============= Function to determine and set highest resolution ========%@AE@%%@NL@% %@AB@%' The BestMode function uses a local error trap to check available modes,%@AE@%%@NL@% %@AB@%' then assigns the integer representing the best mode for charting to its%@AE@%%@NL@% %@AB@%' name so it is returned to the caller. The function terminate execution if%@AE@%%@NL@% %@AB@%' the hardware doesn't support a mode appropriate for Presentation Graphics%@AE@%%@NL@% %@AB@%'========================================================================%@AE@%%@NL@% FUNCTION BestMode%@NL@% %@NL@% %@AB@%' Set a trap for an expected local error --- handled within the function%@AE@%%@NL@% ON LOCAL ERROR GOTO ScreenError%@NL@% %@NL@% FOR TestValue = HIGHESTMODE TO 0 STEP -1%@NL@% DisplayError = FALSE%@NL@% SCREEN TestValue%@NL@% IF DisplayError = FALSE THEN%@NL@% SELECT CASE TestValue%@NL@% CASE 12, 13%@NL@% BestMode = 12%@NL@% CASE 9, 10, 11%@NL@% BestMode = 9%@NL@% CASE 8, 4, 3%@NL@% BestMode = TestValue%@NL@% CASE 2, 7%@NL@% BestMode = 2%@NL@% CASE 1%@NL@% BestMode = 1%@NL@% CASE ELSE%@NL@% PRINT "Sorry, you need graphics to display charts"%@NL@% END%@NL@% END SELECT%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% NEXT TestValue%@NL@% %@AB@%' Note there is no need to turn off the local error handler. It is turned off%@AE@%%@NL@% %@AB@%' automatically when control passes out of the function%@AE@%%@NL@% %@NL@% EXIT FUNCTION%@NL@% %@AB@%'==================== | Local error handler code |=======================%@AE@%%@NL@% %@AB@%' The ScreenError label identifies a local error handler relied in the%@AE@%%@NL@% %@AB@%' BestMode function. Invalid SCREEN values generate Error # 5 (Illegal%@AE@%%@NL@% %@AB@%' function call) --- so if that is not the error reset ERROR to the ERR%@AE@%%@NL@% %@AB@%' value that was generated so the error can be passed to other, possibly%@AE@%%@NL@% %@AB@%' more appropriate errors.%@AE@%%@NL@% ScreenError:%@NL@% IF ERR = 5 THEN%@NL@% DisplayError = TRUE%@NL@% RESUME NEXT%@NL@% ELSE%@NL@% ERROR ERR%@NL@% END IF%@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%PLOTTER.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\PLOTTER.BAS%@AE@%%@NL@% %@NL@% %@AB@%' Values for keys on the numeric keypad and the spacebar:%@AE@%%@NL@% CONST UP = 72, DOWN = 80, LFT = 75, RGHT = 77%@NL@% CONST UPLFT = 71, UPRGHT = 73, DOWNLFT = 79, DOWNRGHT = 81%@NL@% CONST SPACEBAR = " "%@NL@% %@NL@% %@AB@%' Null$ is the first character of the two-character INKEY$%@AE@%%@NL@% %@AB@%' value returned for direction keys such as UP and DOWN:%@AE@%%@NL@% Null$ = CHR$(0)%@NL@% %@AB@%' Plot$ = "" means draw lines; Plot$ = "B" means%@AE@%%@NL@% %@AB@%' move graphics cursor, but don't draw lines:%@AE@%%@NL@% Plot$ = ""%@NL@% %@NL@% PRINT "Use the cursor movement keys to draw lines."%@NL@% PRINT "Press spacebar to toggle line drawing on and off."%@NL@% PRINT "Press <ENTER> to begin. Press q to end the program."%@NL@% DO : LOOP WHILE INKEY$ = ""%@NL@% %@NL@% SCREEN 1%@NL@% %@NL@% DO%@NL@% SELECT CASE KeyVal$%@NL@% CASE Null$ + CHR$(UP)%@NL@% DRAW Plot$ + "C1 U2"%@NL@% CASE Null$ + CHR$(DOWN)%@NL@% DRAW Plot$ + "C1 D2"%@NL@% CASE Null$ + CHR$(LFT)%@NL@% DRAW Plot$ + "C2 L2"%@NL@% CASE Null$ + CHR$(RGHT)%@NL@% DRAW Plot$ + "C2 R2"%@NL@% CASE Null$ + CHR$(UPLFT)%@NL@% DRAW Plot$ + "C3 H2"%@NL@% CASE Null$ + CHR$(UPRGHT)%@NL@% DRAW Plot$ + "C3 E2"%@NL@% CASE Null$ + CHR$(DOWNLFT)%@NL@% DRAW Plot$ + "C3 G2"%@NL@% CASE Null$ + CHR$(DOWNRGHT)%@NL@% DRAW Plot$ + "C3 F2"%@NL@% CASE SPACEBAR%@NL@% IF Plot$ = "" THEN Plot$ = "B " ELSE Plot$ = ""%@NL@% CASE ELSE%@NL@% %@AB@% ' The user pressed some key other than one of the%@AE@%%@NL@% %@AB@% ' direction keys, the spacebar, or "q," so%@AE@%%@NL@% %@AB@% ' don't do anything.%@AE@%%@NL@% END SELECT%@NL@% %@NL@% KeyVal$ = INKEY$%@NL@% %@NL@% LOOP UNTIL KeyVal$ = "q"%@NL@% %@NL@% SCREEN 0, 0 ' Restore the screen to 80-column%@NL@% WIDTH 80 ' text mode and end.%@NL@% END%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%QLBDUMP.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\QLBDUMP.BAS%@AE@%%@NL@% %@NL@% %@AB@%'This program prints the names of Quick library procedures.%@AE@%%@NL@% %@NL@% DECLARE SUB DumpSym (SymStart AS INTEGER, QHdrPos AS LONG)%@NL@% %@NL@% TYPE ExeHdr 'Part of DOS .EXE header.%@NL@% other1 AS STRING * 8 'Other header information.%@NL@% CParHdr AS INTEGER 'Size of header in paragraphs.%@NL@% other2 AS STRING * 10 'Other header information.%@NL@% IP AS INTEGER 'Initial IP value.%@NL@% CS AS INTEGER 'Initial (relative) CS value.%@NL@% END TYPE%@NL@% TYPE QBHdr 'QLB header.%@NL@% QBHead AS STRING * 6 'QBX specific heading.%@NL@% Magic AS INTEGER 'Magic word: identifies file as a Quick library.%@NL@% SymStart AS INTEGER 'Offset from header to first code symbol.%@NL@% DatStart AS INTEGER 'Offset from header to first data symbol.%@NL@% END TYPE%@NL@% %@NL@% TYPE QbSym 'QuickLib symbol entry.%@NL@% Flags AS INTEGER 'Symbol flags.%@NL@% NameStart AS INTEGER 'Offset into name table.%@NL@% other AS STRING * 4 'Other header information.%@NL@% END TYPE%@NL@% %@NL@% DIM EHdr AS ExeHdr, Qhdr AS QBHdr, QHdrPos AS LONG%@NL@% %@NL@% INPUT "Enter Quick library file name: ", FileName$%@NL@% FileName$ = UCASE$(FileName$)%@NL@% IF INSTR(FileName$, ".QLB") = 0 THEN FileName$ = FileName$ + ".QLB"%@NL@% INPUT "Enter output file name or press ENTER for screen: ", OutFile$%@NL@% OutFile$ = UCASE$(OutFile$)%@NL@% IF OutFile$ = "" THEN OutFile$ = "CON"%@NL@% %@NL@% IF DIR$(FileName$) = "" THEN PRINT "File "; FileName$; " not found.": END%@NL@% %@NL@% OPEN FileName$ FOR BINARY AS #1%@NL@% OPEN OutFile$ FOR OUTPUT AS #2%@NL@% %@NL@% GET #1, , EHdr 'Read the EXE format header.%@NL@% TEMP1& = EHdr.CParHdr + EHdr.CS 'Use a LONG temp to prevent overflow.%@NL@% QHdrPos = TEMP1& * 16 + EHdr.IP + 1%@NL@% %@NL@% GET #1, QHdrPos, Qhdr 'Read the QuickLib format header.%@NL@% IF Qhdr.Magic <> &H6C75 THEN PRINT "Not a valid QBX Quick-Library": END%@NL@% %@NL@% PRINT #2, "Code Symbols:": PRINT #2,%@NL@% DumpSym Qhdr.SymStart, QHdrPos 'Dump code symbols.%@NL@% PRINT #2,%@NL@% PRINT #2, "Data Symbols:": PRINT #2, ""%@NL@% DumpSym Qhdr.DatStart, QHdrPos 'Dump data symbols.%@NL@% PRINT #2,%@NL@% %@NL@% END%@NL@% %@NL@% SUB DumpSym (SymStart AS INTEGER, QHdrPos AS LONG)%@NL@% DIM QlbSym AS QbSym%@NL@% DIM NextSym AS LONG, CurrentSym AS LONG%@NL@% %@NL@% %@AB@% 'Calculate the location of the first symbol entry, then read that entry.%@AE@%%@NL@% NextSym = QHdrPos + SymStart%@NL@% GET #1, NextSym, QlbSym%@NL@% DO%@NL@% NextSym = SEEK(1) 'Save the location of the next symbol.%@NL@% CurrentSym = QHdrPos + QlbSym.NameStart%@NL@% SEEK #1, CurrentSym 'Use SEEK to move to the name%@NL@% %@AB@% 'for the current symbol entry.%@AE@%%@NL@% Prospect$ = INPUT$(40, 1) 'Read the longest legal string,%@NL@% %@AB@% 'plus one additional byte for%@AE@%%@NL@% %@AB@% 'the final null character (CHR$(0)).%@AE@%%@NL@% %@NL@% %@AB@% 'Extract the null-terminated name.%@AE@%%@NL@% SName$ = LEFT$(Prospect$, INSTR(Prospect$, CHR$(0)))%@NL@% %@NL@% %@AB@% 'Print only those names that do not begin with "__", "$", or "b$"%@AE@%%@NL@% %@AB@% 'as these names are usually considered reserved.%@AE@%%@NL@% T$ = LEFT$(SName$, 2)%@NL@% IF T$ <> "__" AND LEFT$(SName$, 1) <> "$" AND UCASE$(T$) <> "B$" THEN%@NL@% PRINT #2, " " + SName$%@NL@% END IF%@NL@% %@NL@% GET #1, NextSym, QlbSym 'Read a symbol entry.%@NL@% LOOP WHILE QlbSym.Flags 'Flags=0 (false) means end of table.%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@2@%%@AH@%REMLINE.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\REMLINE.BAS%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Microsoft RemLine - Line Number Removal Utility%@AE@%%@NL@% %@AB@%' Copyright (C) Microsoft Corporation - 1985, 1986, 1987%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' REMLINE.BAS is a program to remove line numbers from Microsoft BASIC%@AE@%%@NL@% %@AB@%' Programs. It removes only those line numbers that are not the object%@AE@%%@NL@% %@AB@%' of one of the following statements: GOSUB, RETURN, GOTO, THEN, ELSE,%@AE@%%@NL@% %@AB@%' RESUME, RESTORE, or RUN.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' REMLINE is run by typing%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' REMLINE [<input> [, <output>]]%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' where <input> is the name of the file to be processed and <output>%@AE@%%@NL@% %@AB@%' is the name of the file or device to receive the reformatted output.%@AE@%%@NL@% %@AB@%' If no extension is given, .BAS is assumed (except for output devices).%@AE@%%@NL@% %@AB@%' If file names are not given, REMLINE prompts for file names. If both%@AE@%%@NL@% %@AB@%' file names are the same, REMLINE saves the original file with the%@AE@%%@NL@% %@AB@%' extension .BAK.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' REMLINE makes several assumptions about the program:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' 1. It must be correct syntactically, and must run in BASICA or%@AE@%%@NL@% %@AB@%' GWBASIC interpreter.%@AE@%%@NL@% %@AB@%' 2. There is a 400 line limit. To process larger files, change%@AE@%%@NL@% %@AB@%' MaxLines constant.%@AE@%%@NL@% %@AB@%' 3. The first number encountered on a line is considered a line%@AE@%%@NL@% %@AB@%' number; thus some continuation lines (in a compiler specific%@AE@%%@NL@% %@AB@%' constructiion) may not be handled correctly.%@AE@%%@NL@% %@AB@%' 4. REMLINE can handle simple statements that test the ERL function%@AE@%%@NL@% %@AB@%' using relational operators such as =, <, and >. For example,%@AE@%%@NL@% %@AB@%' the following statement is handled correctly:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' IF ERL = 100 THEN END%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Line 100 is not removed from the source code. However, more%@AE@%%@NL@% %@AB@%' complex expressions that contain the +, -, AND, OR, XOR, EQV,%@AE@%%@NL@% %@AB@%' MOD, or IMP operators may not be handled correctly. For example,%@AE@%%@NL@% %@AB@%' in the following statement REMLINE does not recognize line 105%@AE@%%@NL@% %@AB@%' as a referenced line number and removes it from the source code:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' IF ERL + 5 = 105 THEN END%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' If you do not like the way REMLINE formats its output, you can modify%@AE@%%@NL@% %@AB@%' the output lines in SUB GenOutFile. An example is shown in comments.%@AE@%%@NL@% %@NL@% %@AB@%' Function and Subprogram declarations%@AE@%%@NL@% %@NL@% DECLARE FUNCTION GetToken$ (Search$, Delim$)%@NL@% DECLARE FUNCTION StrSpn% (InString$, Separator$)%@NL@% DECLARE FUNCTION StrBrk% (InString$, Separator$)%@NL@% DECLARE FUNCTION IsDigit% (Char$)%@NL@% DECLARE SUB GetFileNames ()%@NL@% DECLARE SUB BuildTable ()%@NL@% DECLARE SUB GenOutFile ()%@NL@% DECLARE SUB InitKeyTable ()%@NL@% %@NL@% %@AB@%' Global and constant data%@AE@%%@NL@% %@NL@% CONST TRUE = -1%@NL@% CONST false = 0%@NL@% CONST MaxLines = 400%@NL@% %@NL@% DIM SHARED LineTable!(MaxLines)%@NL@% DIM SHARED LineCount%@NL@% DIM SHARED Seps$, InputFile$, OutputFile$, TmpFile$%@NL@% %@NL@% %@AB@%' Keyword search data%@AE@%%@NL@% %@NL@% CONST KeyWordCount = 9%@NL@% DIM SHARED KeyWordTable$(KeyWordCount)%@NL@% %@NL@% KeyData:%@NL@% DATA THEN, ELSE, GOSUB, GOTO, RESUME, RETURN, RESTORE, RUN, ERL, ""%@NL@% %@NL@% %@AB@%' Start of module-level program code%@AE@%%@NL@% %@NL@% Seps$ = " ,:=<>()" + CHR$(9)%@NL@% InitKeyTable%@NL@% GetFileNames%@NL@% ON ERROR GOTO FileErr1%@NL@% OPEN InputFile$ FOR INPUT AS 1%@NL@% ON ERROR GOTO 0%@NL@% COLOR 7: PRINT "Working"; : COLOR 23: PRINT " . . .": COLOR 7: PRINT%@NL@% BuildTable%@NL@% CLOSE #1%@NL@% OPEN InputFile$ FOR INPUT AS 1%@NL@% ON ERROR GOTO FileErr2%@NL@% OPEN OutputFile$ FOR OUTPUT AS 2%@NL@% ON ERROR GOTO 0%@NL@% GenOutFile%@NL@% CLOSE #1, #2%@NL@% IF OutputFile$ <> "CON" THEN CLS%@NL@% %@NL@% END%@NL@% %@NL@% FileErr1:%@NL@% CLS%@NL@% PRINT " Invalid file name": PRINT%@NL@% INPUT " New input file name (ENTER to terminate): ", InputFile$%@NL@% IF InputFile$ = "" THEN END%@NL@% FileErr2:%@NL@% INPUT " Output file name (ENTER to print to screen) :", OutputFile$%@NL@% PRINT%@NL@% IF (OutputFile$ = "") THEN OutputFile$ = "CON"%@NL@% IF TmpFile$ = "" THEN%@NL@% RESUME%@NL@% ELSE%@NL@% TmpFile$ = ""%@NL@% RESUME NEXT%@NL@% END IF%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' BuildTable:%@AE@%%@NL@% %@AB@%' Examines the entire text file looking for line numbers that are%@AE@%%@NL@% %@AB@%' the object of GOTO, GOSUB, etc. As each is found, it is entered%@AE@%%@NL@% %@AB@%' into a table of line numbers. The table is used during a second%@AE@%%@NL@% %@AB@%' pass (see GenOutFile), when all line numbers not in the list%@AE@%%@NL@% %@AB@%' are removed.%@AE@%%@NL@% %@AB@%' Input:%@AE@%%@NL@% %@AB@%' Uses globals KeyWordTable$, KeyWordCount, and Seps$%@AE@%%@NL@% %@AB@%' Output:%@AE@%%@NL@% %@AB@%' Modefies LineTable! and LineCount%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB BuildTable STATIC%@NL@% %@NL@% DO WHILE NOT EOF(1)%@NL@% %@AB@% ' Get line and first token%@AE@%%@NL@% LINE INPUT #1, InLin$%@NL@% token$ = GetToken$(InLin$, Seps$)%@NL@% DO WHILE (token$ <> "")%@NL@% FOR KeyIndex = 1 TO KeyWordCount%@NL@% %@AB@% ' See if token is keyword%@AE@%%@NL@% IF (KeyWordTable$(KeyIndex) = UCASE$(token$)) THEN%@NL@% %@AB@% ' Get possible line number after keyword%@AE@%%@NL@% token$ = GetToken$("", Seps$)%@NL@% %@AB@% ' Check each token to see if it is a line number%@AE@%%@NL@% %@AB@% ' (the LOOP is necessary for the multiple numbers%@AE@%%@NL@% %@AB@% ' of ON GOSUB or ON GOTO). A non-numeric token will%@AE@%%@NL@% %@AB@% ' terminate search.%@AE@%%@NL@% DO WHILE (IsDigit(LEFT$(token$, 1)))%@NL@% LineCount = LineCount + 1%@NL@% LineTable!(LineCount) = VAL(token$)%@NL@% token$ = GetToken$("", Seps$)%@NL@% IF token$ <> "" THEN KeyIndex = 0%@NL@% LOOP%@NL@% END IF%@NL@% NEXT KeyIndex%@NL@% %@AB@% ' Get next token%@AE@%%@NL@% token$ = GetToken$("", Seps$)%@NL@% LOOP%@NL@% LOOP%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' GenOutFile:%@AE@%%@NL@% %@AB@%' Generates an output file with unreferenced line numbers removed.%@AE@%%@NL@% %@AB@%' Input:%@AE@%%@NL@% %@AB@%' Uses globals LineTable!, LineCount, and Seps$%@AE@%%@NL@% %@AB@%' Output:%@AE@%%@NL@% %@AB@%' Processed file%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB GenOutFile STATIC%@NL@% %@NL@% %@AB@% ' Speed up by eliminating comma and colon (can't separate first token)%@AE@%%@NL@% Sep$ = " " + CHR$(9)%@NL@% DO WHILE NOT EOF(1)%@NL@% LINE INPUT #1, InLin$%@NL@% IF (InLin$ <> "") THEN%@NL@% %@AB@% ' Get first token and process if it is a line number%@AE@%%@NL@% token$ = GetToken$(InLin$, Sep$)%@NL@% IF IsDigit(LEFT$(token$, 1)) THEN%@NL@% LineNumber! = VAL(token$)%@NL@% FoundNumber = false%@NL@% %@AB@% ' See if line number is in table of referenced line numbers%@AE@%%@NL@% FOR index = 1 TO LineCount%@NL@% IF (LineNumber! = LineTable!(index)) THEN%@NL@% FoundNumber = TRUE%@NL@% END IF%@NL@% NEXT index%@NL@% %@AB@% ' Modify line strings%@AE@%%@NL@% IF (NOT FoundNumber) THEN%@NL@% token$ = SPACE$(LEN(token$))%@NL@% MID$(InLin$, StrSpn(InLin$, Sep$), LEN(token$)) = token$%@NL@% END IF%@NL@% %@NL@% %@AB@% ' You can replace the previous lines with your own%@AE@%%@NL@% %@AB@% ' code to reformat output. For example, try these lines:%@AE@%%@NL@% %@NL@% %@AB@% 'TmpPos1 = StrSpn(InLin$, Sep$) + LEN(Token$)%@AE@%%@NL@% %@AB@% 'TmpPos2 = TmpPos1 + StrSpn(MID$(InLin$, TmpPos1), Sep$)%@AE@%%@NL@% %@AB@% '%@AE@%%@NL@% %@AB@% 'IF FoundNumber THEN%@AE@%%@NL@% %@AB@% ' InLin$ = LEFT$(InLin$, TmpPos1 - 1) + CHR$(9) + MID$(InLin$, TmpPos2)%@AE@%%@NL@% %@AB@% 'ELSE%@AE@%%@NL@% %@AB@% ' InLin$ = CHR$(9) + MID$(InLin$, TmpPos2)%@AE@%%@NL@% %@AB@% 'END IF%@AE@%%@NL@% %@NL@% END IF%@NL@% END IF%@NL@% %@AB@% ' Print line to file or console (PRINT is faster than console device)%@AE@%%@NL@% IF OutputFile$ = "CON" THEN%@NL@% PRINT InLin$%@NL@% ELSE%@NL@% PRINT #2, InLin$%@NL@% END IF%@NL@% LOOP%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' GetFileNames:%@AE@%%@NL@% %@AB@%' Gets a file name from COMMAND$ or by prompting the user.%@AE@%%@NL@% %@AB@%' Input:%@AE@%%@NL@% %@AB@%' Used Command$ or user input%@AE@%%@NL@% %@AB@%' Output:%@AE@%%@NL@% %@AB@%' Defines InputFiles$ and OutputFiles$%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB GetFileNames STATIC%@NL@% %@NL@% IF (COMMAND$ = "") THEN%@NL@% CLS%@NL@% PRINT " Microsoft RemLine: Line Number Removal Utility"%@NL@% PRINT " (.BAS assumed if no extension given)"%@NL@% PRINT%@NL@% INPUT " Input file name (ENTER to terminate): ", InputFile$%@NL@% IF InputFile$ = "" THEN END%@NL@% INPUT " Output file name (ENTER to print to screen): ", OutputFile$%@NL@% PRINT%@NL@% IF (OutputFile$ = "") THEN OutputFile$ = "CON"%@NL@% ELSE%@NL@% InputFile$ = UCASE$(GetToken$(COMMAND$, Seps$))%@NL@% OutputFile$ = UCASE$(GetToken$("", Seps$))%@NL@% IF (OutputFile$ = "") THEN%@NL@% INPUT " Output file name (ENTER to print to screen): ", OutputFile$%@NL@% PRINT%@NL@% IF (OutputFile$ = "") THEN OutputFile$ = "CON"%@NL@% END IF%@NL@% END IF%@NL@% IF INSTR(InputFile$, ".") = 0 THEN%@NL@% InputFile$ = InputFile$ + ".BAS"%@NL@% END IF%@NL@% IF INSTR(OutputFile$, ".") = 0 THEN%@NL@% SELECT CASE OutputFile$%@NL@% CASE "CON", "SCRN", "PRN", "COM1", "COM2", "LPT1", "LPT2", "LPT3"%@NL@% EXIT SUB%@NL@% CASE ELSE%@NL@% OutputFile$ = OutputFile$ + ".BAS"%@NL@% END SELECT%@NL@% END IF%@NL@% DO WHILE InputFile$ = OutputFile$%@NL@% TmpFile$ = LEFT$(InputFile$, INSTR(InputFile$, ".")) + "BAK"%@NL@% ON ERROR GOTO FileErr1%@NL@% NAME InputFile$ AS TmpFile$%@NL@% ON ERROR GOTO 0%@NL@% IF TmpFile$ <> "" THEN InputFile$ = TmpFile$%@NL@% LOOP%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' GetToken$:%@AE@%%@NL@% %@AB@%' Extracts tokens from a string. A token is a word that is surrounded%@AE@%%@NL@% %@AB@%' by separators, such as spaces or commas. Tokens are extracted and%@AE@%%@NL@% %@AB@%' analyzed when parsing sentences or commands. To use the GetToken$%@AE@%%@NL@% %@AB@%' function, pass the string to be parsed on the first call, then pass%@AE@%%@NL@% %@AB@%' a null string on subsequent calls until the function returns a null%@AE@%%@NL@% %@AB@%' to indicate that the entire string has been parsed.%@AE@%%@NL@% %@AB@%' Input:%@AE@%%@NL@% %@AB@%' Search$ = string to search%@AE@%%@NL@% %@AB@%' Delim$ = String of separators%@AE@%%@NL@% %@AB@%' Output:%@AE@%%@NL@% %@AB@%' GetToken$ = next token%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION GetToken$ (Search$, Delim$) STATIC%@NL@% %@NL@% %@AB@% ' Note that SaveStr$ and BegPos must be static from call to call%@AE@%%@NL@% %@AB@% ' (other variables are only static for efficiency).%@AE@%%@NL@% %@AB@% ' If first call, make a copy of the string%@AE@%%@NL@% IF (Search$ <> "") THEN%@NL@% BegPos = 1%@NL@% SaveStr$ = Search$%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Find the start of the next token%@AE@%%@NL@% NewPos = StrSpn(MID$(SaveStr$, BegPos, LEN(SaveStr$)), Delim$)%@NL@% IF NewPos THEN%@NL@% %@AB@% ' Set position to start of token%@AE@%%@NL@% BegPos = NewPos + BegPos - 1%@NL@% ELSE%@NL@% %@AB@% ' If no new token, quit and return null%@AE@%%@NL@% GetToken$ = ""%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Find end of token%@AE@%%@NL@% NewPos = StrBrk(MID$(SaveStr$, BegPos, LEN(SaveStr$)), Delim$)%@NL@% IF NewPos THEN%@NL@% %@AB@% ' Set position to end of token%@AE@%%@NL@% NewPos = BegPos + NewPos - 1%@NL@% ELSE%@NL@% %@AB@% ' If no end of token, return set to end a value%@AE@%%@NL@% NewPos = LEN(SaveStr$) + 1%@NL@% END IF%@NL@% %@AB@% ' Cut token out of search string%@AE@%%@NL@% GetToken$ = MID$(SaveStr$, BegPos, NewPos - BegPos)%@NL@% %@AB@% ' Set new starting position%@AE@%%@NL@% BegPos = NewPos%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' InitKeyTable:%@AE@%%@NL@% %@AB@%' Initializes a keyword table. Keywords must be recognized so that%@AE@%%@NL@% %@AB@%' line numbers can be distinguished from numeric constants.%@AE@%%@NL@% %@AB@%' Input:%@AE@%%@NL@% %@AB@%' Uses KeyData%@AE@%%@NL@% %@AB@%' Output:%@AE@%%@NL@% %@AB@%' Modifies global array KeyWordTable$%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB InitKeyTable STATIC%@NL@% %@NL@% RESTORE KeyData%@NL@% FOR Count = 1 TO KeyWordCount%@NL@% READ KeyWord$%@NL@% KeyWordTable$(Count) = KeyWord$%@NL@% NEXT%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' IsDigit:%@AE@%%@NL@% %@AB@%' Returns true if character passed is a decimal digit. Since any%@AE@%%@NL@% %@AB@%' BASIC token starting with a digit is a number, the function only%@AE@%%@NL@% %@AB@%' needs to check the first digit. Doesn't check for negative numbers,%@AE@%%@NL@% %@AB@%' but that's not needed here.%@AE@%%@NL@% %@AB@%' Input:%@AE@%%@NL@% %@AB@%' Char$ - initial character of string to check%@AE@%%@NL@% %@AB@%' Output:%@AE@%%@NL@% %@AB@%' IsDigit - true if within 0 - 9%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION IsDigit (Char$) STATIC%@NL@% %@NL@% IF (Char$ = "") THEN%@NL@% IsDigit = false%@NL@% ELSE%@NL@% CharAsc = ASC(Char$)%@NL@% IsDigit = (CharAsc >= ASC("0")) AND (CharAsc <= ASC("9"))%@NL@% END IF%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' StrBrk:%@AE@%%@NL@% %@AB@%' Searches InString$ to find the first character from among those in%@AE@%%@NL@% %@AB@%' Separator$. Returns the index of that character. This function can%@AE@%%@NL@% %@AB@%' be used to find the end of a token.%@AE@%%@NL@% %@AB@%' Input:%@AE@%%@NL@% %@AB@%' InString$ = string to search%@AE@%%@NL@% %@AB@%' Separator$ = characters to search for%@AE@%%@NL@% %@AB@%' Output:%@AE@%%@NL@% %@AB@%' StrBrk = index to first match in InString$ or 0 if none match%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION StrBrk (InString$, Separator$) STATIC%@NL@% %@NL@% Ln = LEN(InString$)%@NL@% BegPos = 1%@NL@% %@AB@% ' Look for end of token (first character that is a delimiter).%@AE@%%@NL@% DO WHILE INSTR(Separator$, MID$(InString$, BegPos, 1)) = 0%@NL@% IF BegPos > Ln THEN%@NL@% StrBrk = 0%@NL@% EXIT FUNCTION%@NL@% ELSE%@NL@% BegPos = BegPos + 1%@NL@% END IF%@NL@% LOOP%@NL@% StrBrk = BegPos%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' StrSpn:%@AE@%%@NL@% %@AB@%' Searches InString$ to find the first character that is not one of%@AE@%%@NL@% %@AB@%' those in Separator$. Returns the index of that character. This%@AE@%%@NL@% %@AB@%' function can be used to find the start of a token.%@AE@%%@NL@% %@AB@%' Input:%@AE@%%@NL@% %@AB@%' InString$ = string to search%@AE@%%@NL@% %@AB@%' Separator$ = characters to search for%@AE@%%@NL@% %@AB@%' Output:%@AE@%%@NL@% %@AB@%' StrSpn = index to first nonmatch in InString$ or 0 if all match%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION StrSpn% (InString$, Separator$) STATIC%@NL@% %@NL@% Ln = LEN(InString$)%@NL@% BegPos = 1%@NL@% %@AB@% ' Look for start of a token (character that isn't a delimiter).%@AE@%%@NL@% DO WHILE INSTR(Separator$, MID$(InString$, BegPos, 1))%@NL@% IF BegPos > Ln THEN%@NL@% StrSpn = 0%@NL@% EXIT FUNCTION%@NL@% ELSE%@NL@% BegPos = BegPos + 1%@NL@% END IF%@NL@% LOOP%@NL@% StrSpn = BegPos%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%SINEWAVE.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\SINEWAVE.BAS%@AE@%%@NL@% %@NL@% SCREEN 2%@NL@% %@NL@% %@AB@%' Viewport sized to proper scale for graph:%@AE@%%@NL@% VIEW (20, 2)-(620, 172), , 1%@NL@% CONST PI = 3.141592653589#%@NL@% %@NL@% %@AB@%' Make window large enough to graph sine wave from%@AE@%%@NL@% %@AB@%' 0 radians to pi radians:%@AE@%%@NL@% WINDOW (0, -1.1)-(2 * PI, 1.1)%@NL@% Style% = &HFF00 ' Use to make dashed line.%@NL@% VIEW PRINT 23 TO 24 ' Scroll printed output in rows 23, 24.%@NL@% DO%@NL@% PRINT TAB(20);%@NL@% INPUT "Number of cycles (0 to end): ", Cycles%@NL@% CLS%@NL@% LINE (2 * PI, 0)-(0, 0), , , Style% ' Draw the x axis.%@NL@% IF Cycles > 0 THEN%@NL@% %@NL@% %@AB@% ' Start at (0,0) and plot the graph:%@AE@%%@NL@% FOR X = 0 TO 2 * PI STEP .01%@NL@% Y = SIN(Cycles * X) ' Calculate the y coordinate.%@NL@% LINE -(X, Y) ' Draw a line to new point.%@NL@% NEXT X%@NL@% END IF%@NL@% LOOP WHILE Cycles > 0%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%STRTONUM.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\STRTONUM.BAS%@AE@%%@NL@% %@NL@% DECLARE FUNCTION Filter$ (Txt$, FilterString$)%@NL@% %@NL@% %@AB@%' Input a line:%@AE@%%@NL@% LINE INPUT "Enter a number with commas: "; A$%@NL@% %@NL@% %@AB@%' Look only for valid numeric characters (0123456789.-)%@AE@%%@NL@% %@AB@%' in the input string:%@AE@%%@NL@% CleanNum$ = Filter$(A$, "0123456789.-")%@NL@% %@NL@% %@AB@%' Convert the string to a number:%@AE@%%@NL@% PRINT "The number's value = "; VAL(CleanNum$)%@NL@% END%@NL@% %@NL@% %@AB@%' ========================== FILTER =======================%@AE@%%@NL@% %@AB@%' Takes unwanted characters out of a string by%@AE@%%@NL@% %@AB@%' comparing them with a filter string containing%@AE@%%@NL@% %@AB@%' only acceptable numeric characters%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@NL@% FUNCTION Filter$ (Txt$, FilterString$) STATIC%@NL@% Temp$ = ""%@NL@% TxtLength = LEN(Txt$)%@NL@% %@NL@% FOR I = 1 TO TxtLength ' Isolate each character in%@NL@% C$ = MID$(Txt$, I, 1) ' the string.%@NL@% %@NL@% %@AB@% ' If the character is in the filter string, save it:%@AE@%%@NL@% IF INSTR(FilterString$, C$) <> 0 THEN%@NL@% Temp$ = Temp$ + C$%@NL@% END IF%@NL@% NEXT I%@NL@% %@NL@% Filter$ = Temp$%@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%TERMINAL.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\TERMINAL.BAS%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% %@NL@% DECLARE SUB Filter (InString$)%@NL@% %@NL@% COLOR 7, 1 ' Set screen color.%@NL@% CLS%@NL@% %@NL@% Quit$ = CHR$(0) + CHR$(16) ' Value returned by INKEY$%@NL@% %@AB@% ' when ALT+q is pressed.%@AE@%%@NL@% %@NL@% %@AB@%' Set up prompt on bottom line of screen and turn cursor on:%@AE@%%@NL@% LOCATE 24, 1, 1%@NL@% PRINT STRING$(80, "_");%@NL@% LOCATE 25, 1%@NL@% PRINT TAB(30); "Press ALT+q to quit";%@NL@% %@NL@% VIEW PRINT 1 TO 23 ' Print between lines 1 & 23.%@NL@% %@NL@% %@AB@%' Open communications (1200 baud, no parity, 8-bit data,%@AE@%%@NL@% %@AB@%' 1 stop bit, 256-byte input buffer):%@AE@%%@NL@% OPEN "COM1:1200,N,8,1" FOR RANDOM AS #1 LEN = 256%@NL@% %@NL@% DO ' Main communications loop.%@NL@% %@NL@% KeyInput$ = INKEY$ ' Check the keyboard.%@NL@% %@NL@% IF KeyInput$ = Quit$ THEN ' Exit the loop if the user%@NL@% EXIT DO ' pressed ALT+q.%@NL@% %@NL@% ELSEIF KeyInput$ <> "" THEN ' Otherwise, if the user has%@NL@% PRINT #1, KeyInput$; ' pressed a key, send the%@NL@% END IF ' character typed to modem.%@NL@% %@AB@% ' Check the modem. If characters are waiting (EOF(1) is%@AE@%%@NL@% %@AB@% ' true), get them and print them to the screen:%@AE@%%@NL@% IF NOT EOF(1) THEN%@NL@% %@NL@% %@AB@% ' LOC(1) gives the number of characters waiting:%@AE@%%@NL@% ModemInput$ = INPUT$(LOC(1), #1)%@NL@% %@NL@% Filter ModemInput$ ' Filter out line feeds and%@NL@% PRINT ModemInput$; ' backspaces, then print.%@NL@% END IF%@NL@% LOOP%@NL@% %@NL@% CLOSE ' End communications.%@NL@% CLS%@NL@% END%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ========================= FILTER ========================%@AE@%%@NL@% %@AB@%' Filters characters in an input string%@AE@%%@NL@% %@AB@%' =========================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB Filter (InString$) STATIC%@NL@% %@NL@% %@AB@% ' Look for backspace characters and recode%@AE@%%@NL@% %@AB@% ' them to CHR$(29) (the LEFT cursor key):%@AE@%%@NL@% DO%@NL@% BackSpace = INSTR(InString$, CHR$(8))%@NL@% IF BackSpace THEN%@NL@% MID$(InString$, BackSpace) = CHR$(29)%@NL@% END IF%@NL@% LOOP WHILE BackSpace%@NL@% %@NL@% %@AB@% ' Look for line-feed characters and%@AE@%%@NL@% %@AB@% ' remove any found:%@AE@%%@NL@% DO%@NL@% LnFd = INSTR(InString$, CHR$(10))%@NL@% IF LnFd THEN%@NL@% InString$=LEFT$(InString$,LnFd-1)+MID$(InString$,LnFd+1)%@NL@% END IF%@NL@% LOOP WHILE LnFd%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%TIMER.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\TIMER.BAS%@AE@%%@NL@% %@NL@% %@AB@%' Declare external MASM procedures.%@AE@%%@NL@% DECLARE SUB SetInt%@NL@% DECLARE SUB RestInt%@NL@% %@NL@% %@AB@%' Install new interrupt service routine.%@AE@%%@NL@% CALL SetInt%@NL@% %@NL@% %@AB@%' Set up the BASIC event handler.%@AE@%%@NL@% ON UEVENT GOSUB SpecialTask%@NL@% UEVENT ON%@NL@% %@NL@% DO%@NL@% %@AB@%' Normal program operation occurs here.%@AE@%%@NL@% %@AB@%' Program ends when any key is pressed.%@AE@%%@NL@% LOOP UNTIL INKEY$ <> ""%@NL@% %@NL@% %@AB@%' Restore old interrupt service routine before quitting.%@AE@%%@NL@% CALL RestInt%@NL@% %@NL@% END%@NL@% %@NL@% %@AB@%' Program branches here every 4.5 seconds.%@AE@%%@NL@% SpecialTask:%@NL@% %@AB@%' Code for performing the special task goes here, for example:%@AE@%%@NL@% PRINT "Arrived here after 4.5 seconds."%@NL@% RETURN%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%TIMERA.ASM%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\TIMERA.ASM%@AE@%%@NL@% %@NL@% %@AB@%;************************* TIMERA.ASM ******************************%@AE@%%@NL@% %@AB@%; This program, along with TIMER.BAS, makes use of the BASIC SetUEvent%@AE@%%@NL@% %@AB@%; routine to print a message on the screen every 4.5 seconds.%@AE@%%@NL@% %@AB@%; This file has three procedures. SetInt sets up the new DOS interrupt%@AE@%%@NL@% %@AB@%; vector. EventHandler increments a counter 18 times a second and%@AE@%%@NL@% %@AB@%; notifies BASIC when 4.5 seconds have elapsed. RestInt restores the%@AE@%%@NL@% %@AB@%; old interrupt vector.%@AE@%%@NL@% %@NL@% .model medium, basic %@AB@%;Stay compatible with BASIC.%@AE@%%@NL@% .code%@NL@% SetInt proc uses ds %@AB@%;Get old interrupt vector%@AE@%%@NL@% mov ax, 351CH %@AB@%;and save it.%@AE@%%@NL@% int 21h%@NL@% mov word ptr cs:OldVector, bx%@NL@% mov word ptr cs:OldVector + 2, es%@NL@% %@NL@% push cs %@AB@%;Set the new%@AE@%%@NL@% pop ds %@AB@%;interrupt vector%@AE@%%@NL@% lea dx, EventHandler %@AB@%;to the address%@AE@%%@NL@% mov ax, 251CH %@AB@%;of our service%@AE@%%@NL@% int 21H %@AB@%;routine.%@AE@%%@NL@% ret%@NL@% SetInt endp%@NL@% %@NL@% public EventHandler %@AB@%;Make this routine%@AE@%%@NL@% %@AB@%;public for debugging--%@AE@%%@NL@% EventHandler proc %@AB@%;it will check to see if%@AE@%%@NL@% extrn SetUEvent: proc %@AB@%;4.5 seconds have passed.%@AE@%%@NL@% %@NL@% push bx%@NL@% lea bx, TimerTicks%@NL@% inc byte ptr cs:[bx] %@AB@%;Have 4.5 seconds elapsed?%@AE@%%@NL@% cmp byte ptr cs:[bx], 82%@NL@% jnz Continue%@NL@% mov byte ptr cs:[bx], 0 %@AB@%;If true, reset counter,%@AE@%%@NL@% push ax %@AB@%;save registers, and%@AE@%%@NL@% push cx %@AB@%;have BASIC set the%@AE@%%@NL@% push dx %@AB@%;user event flag.%@AE@%%@NL@% push es%@NL@% call SetUevent%@NL@% pop es%@NL@% pop dx %@AB@%;Restore registers.%@AE@%%@NL@% pop cx%@NL@% pop ax%@NL@% Continue:%@NL@% pop bx%@NL@% jmp cs:OldVector %@AB@%;Continue on with the%@AE@%%@NL@% %@AB@%;old service routine.%@AE@%%@NL@% %@NL@% TimerTicks db 0 %@AB@%;Keep data in code segment%@AE@%%@NL@% OldVector dd 0 %@AB@%;where it can be found no%@AE@%%@NL@% %@AB@%;matter where in memory the%@AE@%%@NL@% EventHandler endp %@AB@%;interrupt occurs.%@AE@%%@NL@% %@NL@% RestInt proc uses ds %@AB@%;Restore the old%@AE@%%@NL@% lds dx, cs:OldVector %@AB@%;interrupt vector%@AE@%%@NL@% mov ax, 251CH %@AB@%;so things will%@AE@%%@NL@% int 21h %@AB@%;keep working when%@AE@%%@NL@% ret %@AB@%;this BASIC program is%@AE@%%@NL@% RestInt endp %@AB@%;finished.%@AE@%%@NL@% end%@NL@% %@NL@% %@NL@% %@2@%%@AH@%TOKEN.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\TOKEN.BAS%@AE@%%@NL@% %@NL@% %@AB@%' TOKEN.BAS%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Demonstrates a BASIC version of the strtok C function.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% DECLARE FUNCTION StrTok$(Source$,Delimiters$)%@NL@% %@NL@% LINE INPUT "Enter string: ",P$%@NL@% %@AB@%' Set up the characters that separate tokens.%@AE@%%@NL@% Delimiters$=" ,;:().?"+CHR$(9)+CHR$(34)%@NL@% %@AB@%' Invoke StrTok$ with the string to tokenize.%@AE@%%@NL@% Token$=StrTok$(P$,Delimiters$)%@NL@% WHILE Token$<>""%@NL@% PRINT Token$%@NL@% %@AB@% ' Call StrTok$ with a null string so it knows this%@AE@%%@NL@% %@AB@% ' isn't the first call.%@AE@%%@NL@% Token$=StrTok$("",Delimiters$)%@NL@% WEND%@NL@% %@NL@% FUNCTION StrTok$(Srce$,Delim$)%@NL@% STATIC Start%, SaveStr$%@NL@% %@NL@% %@AB@% ' If first call, make a copy of the string.%@AE@%%@NL@% IF Srce$<>"" THEN%@NL@% Start%=1 : SaveStr$=Srce$%@NL@% END IF%@NL@% %@NL@% BegPos%=Start% : Ln%=LEN(SaveStr$)%@NL@% %@AB@% ' Look for start of a token (character that isn't delimiter).%@AE@%%@NL@% WHILE BegPos%<=Ln% AND INSTR(Delim$,MID$(SaveStr$,BegPos%,1))<>0%@NL@% BegPos%=BegPos%+1%@NL@% WEND%@NL@% %@AB@% ' Test for token start found.%@AE@%%@NL@% IF BegPos% > Ln% THEN%@NL@% StrTok$="" : EXIT FUNCTION%@NL@% END IF%@NL@% %@AB@% ' Find the end of the token.%@AE@%%@NL@% EndPos%=BegPos%%@NL@% WHILE EndPos% <= Ln% AND INSTR(Delim$,MID$(SaveStr$,EndPos%,1))=0%@NL@% EndPos%=EndPos%+1%@NL@% WEND%@NL@% StrTok$=MID$(SaveStr$,BegPos%,EndPos%-BegPos%)%@NL@% %@AB@% ' Set starting point for search for next token.%@AE@%%@NL@% Start%=EndPos%%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@NL@% %@2@%%@AH@%TORUS.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\TORUS.BAS%@AE@%%@NL@% %@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%' TORUS%@AE@%%@NL@% %@AB@%' This program draws a Torus figure. The program accepts user input%@AE@%%@NL@% %@AB@%' to specify various TORUS parameters. It checks the current system%@AE@%%@NL@% %@AB@%' configuration and takes appropriate action to set the best possible%@AE@%%@NL@% %@AB@%' initial mode.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@NL@% DEFINT A-Z%@NL@% DECLARE SUB GetConfig ()%@NL@% DECLARE SUB SetPalette ()%@NL@% DECLARE SUB TorusDefine ()%@NL@% DECLARE SUB TorusCalc (T() AS ANY)%@NL@% DECLARE SUB TorusColor (T() AS ANY)%@NL@% DECLARE SUB TorusSort (Low, High)%@NL@% DECLARE SUB TorusDraw (T() AS ANY, Index())%@NL@% DECLARE SUB TileDraw (T AS ANY)%@NL@% DECLARE SUB TorusRotate (First)%@NL@% DECLARE SUB Delay (Seconds!)%@NL@% DECLARE SUB CountTiles (T1, T2)%@NL@% DECLARE SUB Message (Text$)%@NL@% DECLARE SUB SetConfig (mode)%@NL@% DECLARE FUNCTION Inside (T AS ANY)%@NL@% DECLARE FUNCTION DegToRad! (Degrees)%@NL@% DECLARE FUNCTION Rotated (Lower, Upper, Current, Inc)%@NL@% %@NL@% %@AB@%' General purpose constants%@AE@%%@NL@% CONST PI = 3.14159%@NL@% CONST TRUE = -1, FALSE = 0%@NL@% CONST BACK = 0%@NL@% CONST TROW = 24, TCOL = 60%@NL@% %@NL@% %@AB@%' Rotation flags%@AE@%%@NL@% CONST RNDM = -1%@NL@% CONST START = 0%@NL@% CONST CONTINUE = 1%@NL@% %@NL@% %@AB@%' Constants for best available screen mode%@AE@%%@NL@% CONST VGA = 12%@NL@% CONST MCGA = 13%@NL@% CONST EGA256 = 9%@NL@% CONST EGA64 = 8%@NL@% CONST MONO = 10%@NL@% CONST HERC = 3%@NL@% CONST CGA = 1%@NL@% %@NL@% %@AB@%' User-defined type for tiles - an array of these make a torus%@AE@%%@NL@% TYPE Tile%@NL@% x1 AS SINGLE%@NL@% x2 AS SINGLE%@NL@% x3 AS SINGLE%@NL@% x4 AS SINGLE%@NL@% y1 AS SINGLE%@NL@% y2 AS SINGLE%@NL@% y3 AS SINGLE%@NL@% y4 AS SINGLE%@NL@% z1 AS SINGLE%@NL@% xc AS SINGLE%@NL@% yc AS SINGLE%@NL@% TColor AS INTEGER%@NL@% END TYPE%@NL@% %@NL@% %@AB@%' User-defined type to hold information about the mode%@AE@%%@NL@% TYPE Config%@NL@% Scrn AS INTEGER%@NL@% Colors AS INTEGER%@NL@% Atribs AS INTEGER%@NL@% XPix AS INTEGER%@NL@% YPix AS INTEGER%@NL@% TCOL AS INTEGER%@NL@% TROW AS INTEGER%@NL@% END TYPE%@NL@% %@NL@% DIM VC AS Config%@NL@% %@NL@% %@AB@%' User-defined type to hold information about current Torus%@AE@%%@NL@% TYPE TORUS%@NL@% Panel AS INTEGER%@NL@% Sect AS INTEGER%@NL@% Thick AS SINGLE%@NL@% XDegree AS INTEGER%@NL@% YDegree AS INTEGER%@NL@% Bord AS STRING * 3%@NL@% Delay AS SINGLE%@NL@% END TYPE%@NL@% %@NL@% DIM TOR AS TORUS, Max AS INTEGER%@NL@% %@NL@% %@AB@%' A palette of colors to paint with%@AE@%%@NL@% DIM Pal(0 TO 300) AS LONG%@NL@% %@NL@% %@AB@%' Error variables to check screen type%@AE@%%@NL@% DIM InitRows AS INTEGER, BestMode AS INTEGER, Available AS STRING%@NL@% %@NL@% %@AB@%' The code of the module-level program begins here%@AE@%%@NL@% %@NL@% %@AB@% ' Initialize defaults%@AE@%%@NL@% TOR.Thick = 3: TOR.Bord = "YES"%@NL@% TOR.Panel = 8: TOR.Sect = 14%@NL@% TOR.XDegree = 60: TOR.YDegree = 165%@NL@% %@NL@% %@AB@% ' Get best configuration and set initial graphics mode to it%@AE@%%@NL@% GetConfig%@NL@% VC.Scrn = BestMode%@NL@% %@NL@% DO WHILE TRUE ' Loop forever (exit is from within a SUB)%@NL@% %@NL@% %@AB@% ' Get Torus definition from user%@AE@%%@NL@% TorusDefine%@NL@% %@NL@% %@AB@% ' Dynamically dimension arrays%@AE@%%@NL@% DO%@NL@% Tmp = TOR.Panel%@NL@% Max = TOR.Panel * TOR.Sect%@NL@% %@NL@% %@AB@% ' Array for indexes%@AE@%%@NL@% REDIM Index(0 TO Max - 1) AS INTEGER%@NL@% %@AB@% ' Turn on error trap for insufficient memory%@AE@%%@NL@% ON ERROR GOTO MemErr%@NL@% %@AB@% ' Array for tiles%@AE@%%@NL@% REDIM T(0 TO Max - 1) AS Tile%@NL@% ON ERROR GOTO 0%@NL@% LOOP UNTIL Tmp = TOR.Panel%@NL@% %@NL@% %@AB@% ' Initialize array of indexes%@AE@%%@NL@% FOR Til = 0 TO Max - 1%@NL@% Index(Til) = Til%@NL@% NEXT%@NL@% %@NL@% %@AB@% ' Calculate the points of each tile on the torus%@AE@%%@NL@% Message "Calculating"%@NL@% TorusCalc T()%@NL@% %@NL@% %@AB@% ' Color each tile in the torus.%@AE@%%@NL@% TorusColor T()%@NL@% %@NL@% %@AB@% ' Sort the tiles by their "distance" from the screen%@AE@%%@NL@% Message "Sorting"%@NL@% TorusSort 0, Max - 1%@NL@% %@NL@% %@AB@% ' Set the screen mode%@AE@%%@NL@% SCREEN VC.Scrn%@NL@% %@NL@% %@AB@% ' Mix a palette of colors%@AE@%%@NL@% SetPalette%@NL@% %@NL@% %@AB@% ' Set logical window with variable thickness%@AE@%%@NL@% %@AB@% ' Center is 0, up and right are positive, down and left are negative%@AE@%%@NL@% WINDOW (-(TOR.Thick + 1), -(TOR.Thick + 1))-(TOR.Thick + 1, TOR.Thick + 1)%@NL@% %@NL@% %@AB@% ' Draw and paint the tiles, the farthest first and nearest last%@AE@%%@NL@% TorusDraw T(), Index()%@NL@% %@NL@% %@AB@% ' Rotate the torus by rotating the color palette%@AE@%%@NL@% DO WHILE INKEY$ = ""%@NL@% Delay (TOR.Delay)%@NL@% TorusRotate CONTINUE%@NL@% LOOP%@NL@% SCREEN 0%@NL@% WIDTH 80%@NL@% LOOP%@NL@% %@NL@% %@AB@% ' Restore original rows%@AE@%%@NL@% WIDTH 80, InitRows%@NL@% %@NL@% END%@NL@% %@NL@% %@AB@%' Error trap to make torus screen independent%@AE@%%@NL@% VideoErr:%@NL@% SELECT CASE BestMode ' Fall through until something works%@NL@% CASE VGA%@NL@% BestMode = MCGA%@NL@% Available = "12BD"%@NL@% CASE MCGA%@NL@% BestMode = EGA256%@NL@% Available = "12789"%@NL@% CASE EGA256%@NL@% BestMode = CGA%@NL@% Available = "12"%@NL@% CASE CGA%@NL@% BestMode = MONO%@NL@% Available = "A"%@NL@% CASE MONO%@NL@% BestMode = HERC%@NL@% Available = "3"%@NL@% CASE ELSE%@NL@% PRINT "Sorry. Graphics not available. Can't run Torus."%@NL@% END%@NL@% END SELECT%@NL@% RESUME%@NL@% %@NL@% %@AB@%' Trap to detect 64K EGA%@AE@%%@NL@% EGAErr:%@NL@% BestMode = EGA64%@NL@% Available = "12789"%@NL@% RESUME NEXT%@NL@% %@NL@% %@AB@%' Trap to detect insufficient memory for large Torus%@AE@%%@NL@% MemErr:%@NL@% LOCATE 22, 1%@NL@% PRINT "Out of memory"%@NL@% PRINT "Reducing panels from"; TOR.Panel; "to"; TOR.Panel - 1%@NL@% PRINT "Reducing sections from"; TOR.Sect; "to"; TOR.Sect - 1;%@NL@% DO WHILE INKEY$ = "": LOOP%@NL@% TOR.Panel = TOR.Panel - 1%@NL@% TOR.Sect = TOR.Sect - 1%@NL@% RESUME NEXT%@NL@% %@NL@% %@AB@%' Trap to determine initial number of rows so they can be restored%@AE@%%@NL@% RowErr:%@NL@% IF InitRows = 50 THEN%@NL@% InitRows = 43%@NL@% RESUME%@NL@% ELSE%@NL@% InitRows = 25%@NL@% RESUME NEXT%@NL@% END IF%@NL@% %@NL@% %@AB@%' ============================ CountTiles ==============================%@AE@%%@NL@% %@AB@%' Displays number of the tiles currently being calculated or sorted.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB CountTiles (T1, T2) STATIC%@NL@% %@NL@% %@AB@% ' Erase previous%@AE@%%@NL@% LOCATE TROW - 1, TCOL: PRINT SPACE$(19);%@NL@% %@AB@% ' If positive, display - give negative values to erase%@AE@%%@NL@% IF T1 > 0 AND T2 > 0 THEN%@NL@% LOCATE TROW - 1, TCOL%@NL@% PRINT "Tile ";%@NL@% PRINT USING " ###"; T1;%@NL@% PRINT USING " ###"; T2;%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%' ============================ DegToRad ================================%@AE@%%@NL@% %@AB@%' Convert degrees to radians, since BASIC trigonometric functions%@AE@%%@NL@% %@AB@%' require radians.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION DegToRad! (Degrees) STATIC%@NL@% %@NL@% DegToRad! = (Degrees * 2 * PI) / 360%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%' =============================== Delay ================================%@AE@%%@NL@% %@AB@%' Delay based on time so that wait will be the same on any processor.%@AE@%%@NL@% %@AB@%' Notice the check for negative numbers so that the delay won't%@AE@%%@NL@% %@AB@%' freeze at midnight when the delay could become negative.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB Delay (Seconds!) STATIC%@NL@% %@NL@% Begin! = TIMER%@NL@% DO UNTIL (TIMER - Begin! > Seconds!) OR (TIMER - Begin! < 0)%@NL@% LOOP%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%' ============================ GetConfig ===============================%@AE@%%@NL@% %@AB@%' Get the starting number of lines and the video adapter.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB GetConfig STATIC%@NL@% SHARED InitRows AS INTEGER, BestMode AS INTEGER, Available AS STRING%@NL@% %@NL@% %@AB@% ' Assume 50 line display and fall through error%@AE@%%@NL@% %@AB@% ' until we get the actual number%@AE@%%@NL@% InitRows = 50%@NL@% ON ERROR GOTO RowErr%@NL@% LOCATE InitRows, 1%@NL@% %@NL@% %@AB@% ' Assume best possible screen mode%@AE@%%@NL@% BestMode = VGA%@NL@% Available = "12789BCD"%@NL@% %@NL@% ON ERROR GOTO VideoErr%@NL@% %@AB@% ' Fall through error trap until a mode works%@AE@%%@NL@% SCREEN BestMode%@NL@% %@AB@% ' If EGA, then check pages to see whether more than 64K%@AE@%%@NL@% ON ERROR GOTO EGAErr%@NL@% IF BestMode = EGA256 THEN SCREEN 8, , 1%@NL@% %@NL@% ON ERROR GOTO 0%@NL@% %@NL@% %@AB@% ' Reset text mode%@AE@%%@NL@% SCREEN 0, , 0%@NL@% WIDTH 80, 25%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%' ============================== Inside ================================%@AE@%%@NL@% %@AB@%' Finds a point, T.xc and T.yc, that is mathematically within a tile.%@AE@%%@NL@% %@AB@%' Then check to see if the point is actually inside. Because of the%@AE@%%@NL@% %@AB@%' jagged edges of tiles, the center point is often actually inside%@AE@%%@NL@% %@AB@%' very thin tiles. Such tiles will not be painted, This causes%@AE@%%@NL@% %@AB@%' imperfections that are often visible at the edge of the Torus.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Return FALSE if a center point is not found inside a tile.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION Inside (T AS Tile) STATIC%@NL@% SHARED VC AS Config%@NL@% DIM Highest AS SINGLE, Lowest AS SINGLE%@NL@% %@NL@% Border = VC.Atribs - 1%@NL@% %@NL@% %@AB@% ' Find an inside point. Since some tiles are triangles, the%@AE@%%@NL@% %@AB@% ' diagonal center isn't good enough. Instead find the center%@AE@%%@NL@% %@AB@% ' by drawing a diagonal from the center of the outside to%@AE@%%@NL@% %@AB@% ' a bottom corner.%@AE@%%@NL@% T.xc = T.x2 + ((T.x3 + (T.x4 - T.x3) / 2 - T.x2) / 2)%@NL@% T.yc = T.y2 + ((T.y3 + (T.y4 - T.y3) / 2 - T.y2) / 2)%@NL@% %@NL@% %@AB@% ' If we're on a border, no need to fill%@AE@%%@NL@% IF POINT(T.xc, T.yc) = Border THEN%@NL@% Inside = FALSE%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Find highest and lowest Y on the tile%@AE@%%@NL@% Highest = T.y1%@NL@% Lowest = T.y1%@NL@% IF T.y2 > Highest THEN Highest = T.y2%@NL@% IF T.y2 < Lowest THEN Lowest = T.y2%@NL@% IF T.y3 > Highest THEN Highest = T.y3%@NL@% IF T.y3 < Lowest THEN Lowest = T.y3%@NL@% IF T.y4 > Highest THEN Highest = T.y4%@NL@% IF T.y4 < Lowest THEN Lowest = T.y4%@NL@% %@NL@% %@AB@% ' Convert coordinates to pixels%@AE@%%@NL@% X = PMAP(T.xc, 0)%@NL@% YU = PMAP(T.yc, 1)%@NL@% YD = YU%@NL@% H = PMAP(Highest, 1)%@NL@% L = PMAP(Lowest, 1)%@NL@% %@NL@% %@AB@% ' Search for top and bottom tile borders until we either find them%@AE@%%@NL@% %@AB@% ' both, or check beyond the highest and lowest points.%@AE@%%@NL@% %@NL@% IsUp = FALSE%@NL@% IsDown = FALSE%@NL@% %@NL@% DO%@NL@% YU = YU - 1%@NL@% YD = YD + 1%@NL@% %@NL@% %@AB@% ' Search up%@AE@%%@NL@% IF NOT IsUp THEN%@NL@% IF POINT(T.xc, PMAP(YU, 3)) = Border THEN IsUp = TRUE%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Search down%@AE@%%@NL@% IF NOT IsDown THEN%@NL@% IF POINT(T.xc, PMAP(YD, 3)) = Border THEN IsDown = TRUE%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If top and bottom are found, we're inside%@AE@%%@NL@% IF IsUp AND IsDown THEN%@NL@% Inside = TRUE%@NL@% EXIT FUNCTION%@NL@% END IF%@NL@% %@NL@% LOOP UNTIL (YD > L) AND (YU < H)%@NL@% Inside = FALSE%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%' ============================= Message ================================%@AE@%%@NL@% %@AB@%' Displays a status message followed by blinking dots.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB Message (Text$) STATIC%@NL@% SHARED VC AS Config%@NL@% %@NL@% LOCATE TROW, TCOL: PRINT SPACE$(19);%@NL@% LOCATE TROW, TCOL%@NL@% COLOR 7 ' White%@NL@% PRINT Text$;%@NL@% COLOR 23 ' Blink%@NL@% PRINT " . . .";%@NL@% COLOR 7 ' White%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%' ============================ Rotated =================================%@AE@%%@NL@% %@AB@%' Returns the Current value adjusted by Inc and rotated if necessary%@AE@%%@NL@% %@AB@%' so that it falls within the range of Lower and Upper.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% FUNCTION Rotated (Lower, Upper, Current, Inc)%@NL@% %@NL@% %@AB@% ' Calculate the next value%@AE@%%@NL@% Current = Current + Inc%@NL@% %@NL@% %@AB@% ' Handle special cases of rotating off top or bottom%@AE@%%@NL@% IF Current > Upper THEN Current = Lower%@NL@% IF Current < Lower THEN Current = Upper%@NL@% Rotated = Current%@NL@% %@NL@% END FUNCTION%@NL@% %@NL@% %@AB@%' ============================ SetConfig ===============================%@AE@%%@NL@% %@AB@%' Sets the correct values for each field of the VC variable. They%@AE@%%@NL@% %@AB@%' vary depending on Mode and on the current configuration.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB SetConfig (mode AS INTEGER) STATIC%@NL@% SHARED VC AS Config, BestMode AS INTEGER%@NL@% %@NL@% SELECT CASE mode%@NL@% CASE 1 ' Four-color graphics for CGA, EGA, VGA, and MCGA%@NL@% IF BestMode = CGA OR BestMode = MCGA THEN%@NL@% VC.Colors = 0%@NL@% ELSE%@NL@% VC.Colors = 16%@NL@% END IF%@NL@% VC.Atribs = 4%@NL@% VC.XPix = 319%@NL@% VC.YPix = 199%@NL@% VC.TCOL = 40%@NL@% VC.TROW = 25%@NL@% CASE 2 ' Two-color medium-res graphics for CGA, EGA, VGA, and MCGA%@NL@% IF BestMode = CGA OR BestMode = MCGA THEN%@NL@% VC.Colors = 0%@NL@% ELSE%@NL@% VC.Colors = 16%@NL@% END IF%@NL@% VC.Atribs = 2%@NL@% VC.XPix = 639%@NL@% VC.YPix = 199%@NL@% VC.TCOL = 80%@NL@% VC.TROW = 25%@NL@% CASE 3 ' Two-color high-res graphics for Hercules%@NL@% VC.Colors = 0%@NL@% VC.Atribs = 2%@NL@% VC.XPix = 720%@NL@% VC.YPix = 348%@NL@% VC.TCOL = 80%@NL@% VC.TROW = 25%@NL@% CASE 7 ' 16-color medium-res graphics for EGA and VGA%@NL@% VC.Colors = 16%@NL@% VC.Atribs = 16%@NL@% VC.XPix = 319%@NL@% VC.YPix = 199%@NL@% VC.TCOL = 40%@NL@% VC.TROW = 25%@NL@% CASE 8 ' 16-color high-res graphics for EGA and VGA%@NL@% VC.Colors = 16%@NL@% VC.Atribs = 16%@NL@% VC.XPix = 639%@NL@% VC.YPix = 199%@NL@% VC.TCOL = 80%@NL@% VC.TROW = 25%@NL@% CASE 9 ' 16- or 4-color very high-res graphics for EGA and VGA%@NL@% VC.Colors = 64%@NL@% IF BestMode = EGA64 THEN VC.Atribs = 4 ELSE VC.Atribs = 16%@NL@% VC.XPix = 639%@NL@% VC.YPix = 349%@NL@% VC.TCOL = 80%@NL@% VC.TROW = 25%@NL@% CASE 10 ' Two-color high-res graphics for EGA or VGA monochrome%@NL@% VC.Colors = 0%@NL@% VC.Atribs = 2%@NL@% VC.XPix = 319%@NL@% VC.YPix = 199%@NL@% VC.TCOL = 80%@NL@% VC.TROW = 25%@NL@% CASE 11 ' Two-color very high-res graphics for VGA and MCGA%@NL@% %@AB@% ' Note that for VGA screens 11, 12, and 13, more colors are%@AE@%%@NL@% %@AB@% ' available, depending on how the colors are mixed.%@AE@%%@NL@% VC.Colors = 216%@NL@% VC.Atribs = 2%@NL@% VC.XPix = 639%@NL@% VC.YPix = 479%@NL@% VC.TCOL = 80%@NL@% VC.TROW = 30%@NL@% CASE 12 ' 16-color very high-res graphics for VGA%@NL@% VC.Colors = 216%@NL@% VC.Atribs = 16%@NL@% VC.XPix = 639%@NL@% VC.YPix = 479%@NL@% VC.TCOL = 80%@NL@% VC.TROW = 30%@NL@% CASE 13 ' 256-color medium-res graphics for VGA and MCGA%@NL@% VC.Colors = 216%@NL@% VC.Atribs = 256%@NL@% VC.XPix = 639%@NL@% VC.YPix = 479%@NL@% VC.TCOL = 40%@NL@% VC.TROW = 25%@NL@% CASE ELSE%@NL@% VC.Colors = 16%@NL@% VC.Atribs = 16%@NL@% VC.XPix = 0%@NL@% VC.YPix = 0%@NL@% VC.TCOL = 80%@NL@% VC.TROW = 25%@NL@% VC.Scrn = 0%@NL@% EXIT SUB%@NL@% END SELECT%@NL@% VC.Scrn = mode%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%' ============================ SetPalette ==============================%@AE@%%@NL@% %@AB@%' Mixes palette colors in an array.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB SetPalette STATIC%@NL@% SHARED VC AS Config, Pal() AS LONG%@NL@% %@NL@% %@AB@% ' Mix only if the adapter supports color attributes%@AE@%%@NL@% IF VC.Colors THEN%@NL@% SELECT CASE VC.Scrn%@NL@% CASE 1, 2, 7, 8%@NL@% %@AB@% ' Red, green, blue, and intense in four bits of a byte%@AE@%%@NL@% %@AB@% ' Bits: 0000irgb%@AE@%%@NL@% %@AB@% ' Change the order of FOR loops to change color mix%@AE@%%@NL@% Index = 0%@NL@% FOR Bs = 0 TO 1%@NL@% FOR Gs = 0 TO 1%@NL@% FOR Rs = 0 TO 1%@NL@% FOR Hs = 0 TO 1%@NL@% Pal(Index) = Hs * 8 + Rs * 4 + Gs * 2 + Bs%@NL@% Index = Index + 1%@NL@% NEXT%@NL@% NEXT%@NL@% NEXT%@NL@% NEXT%@NL@% CASE 9%@NL@% %@AB@% ' EGA red, green, and blue colors in 6 bits of a byte%@AE@%%@NL@% %@AB@% ' Capital letters repesent intense, lowercase normal%@AE@%%@NL@% %@AB@% ' Bits: 00rgbRGB%@AE@%%@NL@% %@AB@% ' Change the order of FOR loops to change color mix%@AE@%%@NL@% Index = 0%@NL@% FOR Bs = 0 TO 1%@NL@% FOR Gs = 0 TO 1%@NL@% FOR Rs = 0 TO 1%@NL@% FOR HRs = 0 TO 1%@NL@% FOR HGs = 0 TO 1%@NL@% FOR HBs = 0 TO 1%@NL@% Pal(Index) = Rs * 32 + Gs * 16 + Bs * 8 + HRs * 4 + HGs * 2 + HBs%@NL@% Index = Index + 1%@NL@% NEXT%@NL@% NEXT%@NL@% NEXT%@NL@% NEXT%@NL@% NEXT%@NL@% NEXT%@NL@% CASE 11, 12, 13%@NL@% %@AB@% ' VGA colors in 6 bits of 3 bytes of a long integer%@AE@%%@NL@% %@AB@% ' Bits: 000000000 00bbbbbb 00gggggg 00rrrrrr%@AE@%%@NL@% %@AB@% ' Change the order of FOR loops to change color mix%@AE@%%@NL@% %@AB@% ' Decrease the STEP and increase VC.Colors to get more colors%@AE@%%@NL@% Index = 0%@NL@% FOR Rs = 0 TO 63 STEP 11%@NL@% FOR Bs = 0 TO 63 STEP 11%@NL@% FOR Gs = 0 TO 63 STEP 11%@NL@% Pal(Index) = (65536 * Bs) + (256 * Gs) + Rs%@NL@% Index = Index + 1%@NL@% NEXT%@NL@% NEXT%@NL@% NEXT%@NL@% CASE ELSE%@NL@% END SELECT%@NL@% %@AB@% ' Assign colors%@AE@%%@NL@% IF VC.Atribs > 2 THEN TorusRotate RNDM%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%' ============================ TileDraw ================================%@AE@%%@NL@% %@AB@%' Draw and optionally paint a tile. Tiles are painted if there are%@AE@%%@NL@% %@AB@%' more than two atributes and if the inside of the tile can be found.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB TileDraw (T AS Tile) STATIC%@NL@% SHARED VC AS Config, TOR AS TORUS%@NL@% %@NL@% %@AB@% 'Set border%@AE@%%@NL@% Border = VC.Atribs - 1%@NL@% %@NL@% IF VC.Atribs = 2 THEN%@NL@% %@AB@% ' Draw and quit for two-color modes%@AE@%%@NL@% LINE (T.x1, T.y1)-(T.x2, T.y2), T.TColor%@NL@% LINE -(T.x3, T.y3), T.TColor%@NL@% LINE -(T.x4, T.y4), T.TColor%@NL@% LINE -(T.x1, T.y1), T.TColor%@NL@% EXIT SUB%@NL@% ELSE%@NL@% %@AB@% ' For other modes, draw in the border color%@AE@%%@NL@% %@AB@% ' (which must be different than any tile color)%@AE@%%@NL@% LINE (T.x1, T.y1)-(T.x2, T.y2), Border%@NL@% LINE -(T.x3, T.y3), Border%@NL@% LINE -(T.x4, T.y4), Border%@NL@% LINE -(T.x1, T.y1), Border%@NL@% END IF%@NL@% %@NL@% %@AB@% ' See if tile is large enough to be painted%@AE@%%@NL@% IF Inside(T) THEN%@NL@% %@AB@% 'Black out the center to make sure it isn't paint color%@AE@%%@NL@% PRESET (T.xc, T.yc)%@NL@% %@AB@% ' Paint tile black so colors of underlying tiles can't interfere%@AE@%%@NL@% PAINT STEP(0, 0), BACK, Border%@NL@% %@AB@% ' Fill with the final tile color.%@AE@%%@NL@% PAINT STEP(0, 0), T.TColor, Border%@NL@% END IF%@NL@% %@NL@% %@AB@% ' A border drawn with the background color looks like a border.%@AE@%%@NL@% %@AB@% ' One drawn with the tile color doesn't look like a border.%@AE@%%@NL@% IF TOR.Bord = "YES" THEN%@NL@% Border = BACK%@NL@% ELSE%@NL@% Border = T.TColor%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Redraw with the final border%@AE@%%@NL@% LINE (T.x1, T.y1)-(T.x2, T.y2), Border%@NL@% LINE -(T.x3, T.y3), Border%@NL@% LINE -(T.x4, T.y4), Border%@NL@% LINE -(T.x1, T.y1), Border%@NL@% %@NL@% END SUB%@NL@% %@NL@% DEFSNG A-Z%@NL@% %@AB@%' =========================== TorusCalc ================================%@AE@%%@NL@% %@AB@%' Calculates the x and y coordinates for each tile.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB TorusCalc (T() AS Tile) STATIC%@NL@% SHARED TOR AS TORUS, Max AS INTEGER%@NL@% DIM XSect AS INTEGER, YPanel AS INTEGER%@NL@% %@NL@% %@AB@% ' Calculate sine and cosine of the angles of rotation%@AE@%%@NL@% XRot = DegToRad(TOR.XDegree)%@NL@% YRot = DegToRad(TOR.YDegree)%@NL@% CXRot = COS(XRot)%@NL@% SXRot = SIN(XRot)%@NL@% CYRot = COS(YRot)%@NL@% SYRot = SIN(YRot)%@NL@% %@NL@% %@AB@% ' Calculate the angle to increment between one tile and the next.%@AE@%%@NL@% XInc = 2 * PI / TOR.Sect%@NL@% YInc = 2 * PI / TOR.Panel%@NL@% %@NL@% %@AB@% ' First calculate the first point, which will be used as a reference%@AE@%%@NL@% %@AB@% ' for future points. This point must be calculated separately because%@AE@%%@NL@% %@AB@% ' it is both the beginning and the end of the center seam.%@AE@%%@NL@% FirstY = (TOR.Thick + 1) * CYRot%@NL@% %@NL@% %@AB@% ' Starting point is x1 of 0 section, 0 panel last 0%@AE@%%@NL@% T(0).x1 = FirstY ' +------+------+%@NL@% %@AB@% ' Also x2 of tile on last section, 0 panel ' | | | last%@AE@%%@NL@% T(TOR.Sect - 1).x2 = FirstY ' | x3|x4 |%@NL@% %@AB@% ' Also x3 of last section, last panel ' +------+------+%@AE@%%@NL@% T(Max - 1).x3 = FirstY ' | x2|x1 | 0%@NL@% %@AB@% ' Also x4 of 0 section, last panel ' | | |%@AE@%%@NL@% T(Max - TOR.Sect).x4 = FirstY ' +------+------+%@NL@% %@AB@% ' A similar pattern is used for assigning all points of Torus%@AE@%%@NL@% %@NL@% %@AB@% ' Starting Y point is 0 (center)%@AE@%%@NL@% T(0).y1 = 0%@NL@% T(TOR.Sect - 1).y2 = 0%@NL@% T(Max - 1).y3 = 0%@NL@% T(Max - TOR.Sect).y4 = 0%@NL@% %@NL@% %@AB@% ' Only one z coordinate is used in sort, so other three can be ignored%@AE@%%@NL@% T(0).z1 = -(TOR.Thick + 1) * SYRot%@NL@% %@NL@% %@AB@% ' Starting at first point, work around the center seam of the Torus.%@AE@%%@NL@% %@AB@% ' Assign points for each section. The seam must be calculated separately%@AE@%%@NL@% %@AB@% ' because it is both beginning and of each section.%@AE@%%@NL@% FOR XSect = 1 TO TOR.Sect - 1%@NL@% %@NL@% %@AB@% ' X, Y, and Z elements of equation%@AE@%%@NL@% sx = (TOR.Thick + 1) * COS(XSect * XInc)%@NL@% sy = (TOR.Thick + 1) * SIN(XSect * XInc) * CXRot%@NL@% sz = (TOR.Thick + 1) * SIN(XSect * XInc) * SXRot%@NL@% ssx = (sz * SYRot) + (sx * CYRot)%@NL@% %@NL@% T(XSect).x1 = ssx%@NL@% T(XSect - 1).x2 = ssx%@NL@% T(Max - TOR.Sect + XSect - 1).x3 = ssx%@NL@% T(Max - TOR.Sect + XSect).x4 = ssx%@NL@% %@NL@% T(XSect).y1 = sy%@NL@% T(XSect - 1).y2 = sy%@NL@% T(Max - TOR.Sect + XSect - 1).y3 = sy%@NL@% T(Max - TOR.Sect + XSect).y4 = sy%@NL@% %@NL@% T(XSect).z1 = (sz * CYRot) - (sx * SYRot)%@NL@% NEXT%@NL@% %@NL@% %@AB@% ' Now start at the first seam between panel and assign points for%@AE@%%@NL@% %@AB@% ' each section of each panel. The outer loop assigns the initial%@AE@%%@NL@% %@AB@% ' point for the panel. This point must be calculated separately%@AE@%%@NL@% %@AB@% ' since it is both the beginning and the end of the seam of panels.%@AE@%%@NL@% FOR YPanel = 1 TO TOR.Panel - 1%@NL@% %@NL@% %@AB@% ' X, Y, and Z elements of equation%@AE@%%@NL@% sx = TOR.Thick + COS(YPanel * YInc)%@NL@% sy = -SIN(YPanel * YInc) * SXRot%@NL@% sz = SIN(YPanel * YInc) * CXRot%@NL@% ssx = (sz * SYRot) + (sx * CYRot)%@NL@% %@NL@% %@AB@% ' Assign X points for each panel%@AE@%%@NL@% %@AB@% ' Current ring, current side%@AE@%%@NL@% T(TOR.Sect * YPanel).x1 = ssx%@NL@% %@AB@% ' Current ring minus 1, next side%@AE@%%@NL@% T(TOR.Sect * (YPanel + 1) - 1).x2 = ssx%@NL@% %@AB@% ' Current ring minus 1, previous side%@AE@%%@NL@% T(TOR.Sect * YPanel - 1).x3 = ssx%@NL@% %@AB@% ' Current ring, previous side%@AE@%%@NL@% T(TOR.Sect * (YPanel - 1)).x4 = ssx%@NL@% %@NL@% %@AB@% ' Assign Y points for each panel%@AE@%%@NL@% T(TOR.Sect * YPanel).y1 = sy%@NL@% T(TOR.Sect * (YPanel + 1) - 1).y2 = sy%@NL@% T(TOR.Sect * YPanel - 1).y3 = sy%@NL@% T(TOR.Sect * (YPanel - 1)).y4 = sy%@NL@% %@NL@% %@AB@% ' Z point for each panel%@AE@%%@NL@% T(TOR.Sect * YPanel).z1 = (sz * CYRot) - (sx * SYRot)%@NL@% %@NL@% %@AB@% ' The inner loop assigns points for each ring (except the first)%@AE@%%@NL@% %@AB@% ' on the current side.%@AE@%%@NL@% FOR XSect = 1 TO TOR.Sect - 1%@NL@% %@NL@% %@AB@% ' Display section and panel%@AE@%%@NL@% CountTiles XSect, YPanel%@NL@% %@NL@% ty = (TOR.Thick + COS(YPanel * YInc)) * SIN(XSect * XInc)%@NL@% tz = SIN(YPanel * YInc)%@NL@% sx = (TOR.Thick + COS(YPanel * YInc)) * COS(XSect * XInc)%@NL@% sy = ty * CXRot - tz * SXRot%@NL@% sz = ty * SXRot + tz * CXRot%@NL@% ssx = (sz * SYRot) + (sx * CYRot)%@NL@% %@NL@% T(TOR.Sect * YPanel + XSect).x1 = ssx%@NL@% T(TOR.Sect * YPanel + XSect - 1).x2 = ssx%@NL@% T(TOR.Sect * (YPanel - 1) + XSect - 1).x3 = ssx%@NL@% T(TOR.Sect * (YPanel - 1) + XSect).x4 = ssx%@NL@% %@NL@% T(TOR.Sect * YPanel + XSect).y1 = sy%@NL@% T(TOR.Sect * YPanel + XSect - 1).y2 = sy%@NL@% T(TOR.Sect * (YPanel - 1) + XSect - 1).y3 = sy%@NL@% T(TOR.Sect * (YPanel - 1) + XSect).y4 = sy%@NL@% %@NL@% T(TOR.Sect * YPanel + XSect).z1 = (sz * CYRot) - (sx * SYRot)%@NL@% NEXT%@NL@% NEXT%@NL@% %@AB@% ' Erase message%@AE@%%@NL@% CountTiles -1, -1%@NL@% %@NL@% END SUB%@NL@% %@NL@% DEFINT A-Z%@NL@% %@AB@%' =========================== TorusColor ===============================%@AE@%%@NL@% %@AB@%' Assigns color atributes to each tile.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB TorusColor (T() AS Tile) STATIC%@NL@% SHARED VC AS Config, Max AS INTEGER%@NL@% %@NL@% %@AB@% ' Skip first and last atributes%@AE@%%@NL@% LastAtr = VC.Atribs - 2%@NL@% Atr = 1%@NL@% %@NL@% %@AB@% ' Cycle through each attribute until all tiles are done%@AE@%%@NL@% FOR Til = 0 TO Max - 1%@NL@% IF (Atr >= LastAtr) THEN%@NL@% Atr = 1%@NL@% ELSE%@NL@% Atr = Atr + 1%@NL@% END IF%@NL@% T(Til).TColor = Atr%@NL@% NEXT%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%' ============================ TorusDefine =============================%@AE@%%@NL@% %@AB@%' Define the attributes of a Torus based on information from the%@AE@%%@NL@% %@AB@%' user, the video configuration, and the current screen mode.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB TorusDefine STATIC%@NL@% SHARED VC AS Config, TOR AS TORUS, Available AS STRING%@NL@% %@NL@% %@AB@%' Constants for key codes and column positions%@AE@%%@NL@% CONST ENTER = 13, ESCAPE = 27%@NL@% CONST DOWNARROW = 80, UPARROW = 72, LEFTARROW = 75, RIGHTARROW = 77%@NL@% CONST COL1 = 20, COL2 = 50, ROW = 9%@NL@% %@NL@% %@AB@% ' Display key instructions%@AE@%%@NL@% LOCATE 1, COL1%@NL@% PRINT "UP .............. Move to next field"%@NL@% LOCATE 2, COL1%@NL@% PRINT "DOWN ........ Move to previous field"%@NL@% LOCATE 3, COL1%@NL@% PRINT "LEFT ......... Rotate field value up"%@NL@% LOCATE 4, COL1%@NL@% PRINT "RIGHT ...... Rotate field value down"%@NL@% LOCATE 5, COL1%@NL@% PRINT "ENTER .... Start with current values"%@NL@% LOCATE 6, COL1%@NL@% PRINT "ESCAPE .................. Quit Torus"%@NL@% %@NL@% %@AB@% ' Block cursor%@AE@%%@NL@% LOCATE ROW, COL1, 1, 1, 12%@NL@% %@AB@% ' Display fields%@AE@%%@NL@% LOCATE ROW, COL1: PRINT "Thickness";%@NL@% LOCATE ROW, COL2: PRINT USING "[ # ]"; TOR.Thick;%@NL@% %@NL@% LOCATE ROW + 2, COL1: PRINT "Panels per Section";%@NL@% LOCATE ROW + 2, COL2: PRINT USING "[ ## ]"; TOR.Panel;%@NL@% %@NL@% LOCATE ROW + 4, COL1: PRINT "Sections per Torus";%@NL@% LOCATE ROW + 4, COL2: PRINT USING "[ ## ]"; TOR.Sect;%@NL@% %@NL@% LOCATE ROW + 6, COL1: PRINT "Tilt around Horizontal Axis";%@NL@% LOCATE ROW + 6, COL2: PRINT USING "[ ### ]"; TOR.XDegree;%@NL@% %@NL@% LOCATE ROW + 8, COL1: PRINT "Tilt around Vertical Axis";%@NL@% LOCATE ROW + 8, COL2: PRINT USING "[ ### ]"; TOR.YDegree;%@NL@% %@NL@% LOCATE ROW + 10, COL1: PRINT "Tile Border";%@NL@% LOCATE ROW + 10, COL2: PRINT USING "[ & ] "; TOR.Bord;%@NL@% %@NL@% LOCATE ROW + 12, COL1: PRINT "Screen Mode";%@NL@% LOCATE ROW + 12, COL2: PRINT USING "[ ## ]"; VC.Scrn%@NL@% %@NL@% %@AB@% ' Skip field 10 if there's only one value%@AE@%%@NL@% IF LEN(Available$) = 1 THEN Fields = 10 ELSE Fields = 12%@NL@% %@NL@% %@AB@% ' Update field values and position based on keystrokes%@AE@%%@NL@% DO%@NL@% %@AB@% ' Put cursor on field%@AE@%%@NL@% LOCATE ROW + Fld, COL2 + 2%@NL@% %@AB@% ' Get a key and strip null off if it's an extended code%@AE@%%@NL@% DO%@NL@% K$ = INKEY$%@NL@% LOOP WHILE K$ = ""%@NL@% Ky = ASC(RIGHT$(K$, 1))%@NL@% %@NL@% SELECT CASE Ky%@NL@% CASE ESCAPE%@NL@% %@AB@% ' End program%@AE@%%@NL@% CLS : END%@NL@% CASE UPARROW, DOWNARROW%@NL@% %@AB@% ' Adjust field location%@AE@%%@NL@% IF Ky = DOWNARROW THEN Inc = 2 ELSE Inc = -2%@NL@% Fld = Rotated(0, Fields, Fld, Inc)%@NL@% CASE RIGHTARROW, LEFTARROW%@NL@% %@AB@% ' Adjust field%@AE@%%@NL@% IF Ky = RIGHTARROW THEN Inc = 1 ELSE Inc = -1%@NL@% SELECT CASE Fld%@NL@% CASE 0%@NL@% %@AB@% ' Thickness%@AE@%%@NL@% TOR.Thick = Rotated(1, 9, INT(TOR.Thick), Inc)%@NL@% PRINT USING "#"; TOR.Thick%@NL@% CASE 2%@NL@% %@AB@% ' Panels%@AE@%%@NL@% TOR.Panel = Rotated(6, 20, TOR.Panel, Inc)%@NL@% PRINT USING "##"; TOR.Panel%@NL@% CASE 4%@NL@% %@AB@% ' Sections%@AE@%%@NL@% TOR.Sect = Rotated(6, 20, TOR.Sect, Inc)%@NL@% PRINT USING "##"; TOR.Sect%@NL@% CASE 6%@NL@% %@AB@% ' Horizontal tilt%@AE@%%@NL@% TOR.XDegree = Rotated(0, 345, TOR.XDegree, (15 * Inc))%@NL@% PRINT USING "###"; TOR.XDegree%@NL@% CASE 8%@NL@% %@AB@% ' Vertical tilt%@AE@%%@NL@% TOR.YDegree = Rotated(0, 345, TOR.YDegree, (15 * Inc))%@NL@% PRINT USING "###"; TOR.YDegree%@NL@% CASE 10%@NL@% %@AB@% ' Border%@AE@%%@NL@% IF VC.Atribs > 2 THEN%@NL@% IF TOR.Bord = "YES" THEN%@NL@% TOR.Bord = "NO"%@NL@% ELSE%@NL@% TOR.Bord = "YES"%@NL@% END IF%@NL@% END IF%@NL@% PRINT TOR.Bord%@NL@% CASE 12%@NL@% %@AB@% ' Available screen modes%@AE@%%@NL@% I = INSTR(Available$, HEX$(VC.Scrn))%@NL@% I = Rotated(1, LEN(Available$), I, Inc)%@NL@% VC.Scrn = VAL("&h" + MID$(Available$, I, 1))%@NL@% PRINT USING "##"; VC.Scrn%@NL@% CASE ELSE%@NL@% END SELECT%@NL@% CASE ELSE%@NL@% END SELECT%@NL@% %@AB@% ' Set configuration data for graphics mode%@AE@%%@NL@% SetConfig VC.Scrn%@NL@% %@AB@% ' Draw Torus if ENTER%@AE@%%@NL@% LOOP UNTIL Ky = ENTER%@NL@% %@NL@% %@AB@% ' Remove cursor%@AE@%%@NL@% LOCATE 1, 1, 0%@NL@% %@NL@% %@AB@% ' Set different delays depending on mode%@AE@%%@NL@% SELECT CASE VC.Scrn%@NL@% CASE 1%@NL@% TOR.Delay = .3%@NL@% CASE 2, 3, 10, 11, 13%@NL@% TOR.Delay = 0%@NL@% CASE ELSE%@NL@% TOR.Delay = .05%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Get new random seed for this torus%@AE@%%@NL@% RANDOMIZE TIMER%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%' =========================== TorusDraw ================================%@AE@%%@NL@% %@AB@%' Draws each tile of the torus starting with the farthest and working%@AE@%%@NL@% %@AB@%' to the closest. Thus nearer tiles overwrite farther tiles to give%@AE@%%@NL@% %@AB@%' a three-dimensional effect. Notice that the index of the tile being%@AE@%%@NL@% %@AB@%' drawn is actually the index of an array of indexes. This is because%@AE@%%@NL@% %@AB@%' the array of tiles is not sorted, but the parallel array of indexes%@AE@%%@NL@% %@AB@%' is. See TorusSort for an explanation of how indexes are sorted.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB TorusDraw (T() AS Tile, Index() AS INTEGER)%@NL@% SHARED Max AS INTEGER%@NL@% %@NL@% FOR Til = 0 TO Max - 1%@NL@% TileDraw T(Index(Til))%@NL@% NEXT%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%' =========================== TorusRotate ==============================%@AE@%%@NL@% %@AB@%' Rotates the Torus. This can be done more successfully in some modes%@AE@%%@NL@% %@AB@%' than in others. There are three methods:%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' 1. Rotate the palette colors assigned to each attribute%@AE@%%@NL@% %@AB@%' 2. Draw, erase, and redraw the torus (two-color modes)%@AE@%%@NL@% %@AB@%' 3. Rotate between two palettes (CGA and MCGA screen 1)%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' Note that for EGA and VGA screen 2, methods 1 and 2 are both used.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB TorusRotate (First) STATIC%@NL@% SHARED VC AS Config, TOR AS TORUS, Pal() AS LONG, Max AS INTEGER%@NL@% SHARED T() AS Tile, Index() AS INTEGER, BestMode AS INTEGER%@NL@% DIM Temp AS LONG%@NL@% %@NL@% %@AB@% ' For EGA and higher rotate colors through palette%@AE@%%@NL@% IF VC.Colors THEN%@NL@% %@NL@% %@AB@% ' Argument determines whether to start at next color, first color,%@AE@%%@NL@% %@AB@% ' or random color%@AE@%%@NL@% SELECT CASE First%@NL@% CASE RNDM%@NL@% FirstClr = INT(RND * VC.Colors)%@NL@% CASE START%@NL@% FirstClr = 0%@NL@% CASE ELSE%@NL@% FirstClr = FirstClr - 1%@NL@% END SELECT%@NL@% %@NL@% %@AB@% ' Set last color to smaller of last possible color or last tile%@AE@%%@NL@% IF VC.Colors > Max - 1 THEN%@NL@% LastClr = Max - 1%@NL@% ELSE%@NL@% LastClr = VC.Colors - 1%@NL@% END IF%@NL@% %@NL@% %@AB@% ' If color is too low, rotate to end%@AE@%%@NL@% IF FirstClr < 0 OR FirstClr >= LastClr THEN FirstClr = LastClr%@NL@% %@NL@% %@AB@% ' Set last attribute%@AE@%%@NL@% IF VC.Atribs = 2 THEN%@NL@% %@AB@% ' Last for two-color modes%@AE@%%@NL@% LastAtr = VC.Atribs - 1%@NL@% ELSE%@NL@% %@AB@% ' Smaller of last color or next-to-last attribute%@AE@%%@NL@% IF LastClr < VC.Atribs - 2 THEN%@NL@% LastAtr = LastClr%@NL@% ELSE%@NL@% LastAtr = VC.Atribs - 2%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% %@AB@% ' Cycle through attributes, assigning colors%@AE@%%@NL@% Work = FirstClr%@NL@% FOR Atr = LastAtr TO 1 STEP -1%@NL@% PALETTE Atr, Pal(Work)%@NL@% Work = Work - 1%@NL@% IF Work < 0 THEN Work = LastClr%@NL@% NEXT%@NL@% %@NL@% END IF%@NL@% %@NL@% %@AB@% ' For two-color screens, the best we can do is erase and redraw the torus%@AE@%%@NL@% IF VC.Atribs = 2 THEN%@NL@% %@NL@% %@AB@% ' Set all tiles to color%@AE@%%@NL@% FOR I = 0 TO Max - 1%@NL@% T(I).TColor = Toggle%@NL@% NEXT%@NL@% %@AB@% ' Draw Torus%@AE@%%@NL@% TorusDraw T(), Index()%@NL@% %@AB@% ' Toggle between color and background%@AE@%%@NL@% Toggle = (Toggle + 1) MOD 2%@NL@% %@NL@% END IF%@NL@% %@NL@% %@AB@% ' For CGA or MCGA screen 1, toggle palettes using the COLOR statement%@AE@%%@NL@% %@AB@% ' (these modes do not allow the PALETTE statement)%@AE@%%@NL@% IF VC.Scrn = 1 AND (BestMode = CGA OR BestMode = MCGA) THEN%@NL@% COLOR , Toggle%@NL@% Toggle = (Toggle + 1) MOD 2%@NL@% EXIT SUB%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@AB@%' ============================ TorusSort ===============================%@AE@%%@NL@% %@AB@%' Sorts the tiles of the Torus according to their Z axis (distance%@AE@%%@NL@% %@AB@%' from the "front" of the screen). When the tiles are drawn, the%@AE@%%@NL@% %@AB@%' farthest will be drawn first, and nearer tiles will overwrite them%@AE@%%@NL@% %@AB@%' to give a three-dimensional effect.%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' To make sorting as fast as possible, the Quick Sort algorithm is%@AE@%%@NL@% %@AB@%' used. Also, the array of tiles is not actually sorted. Instead a%@AE@%%@NL@% %@AB@%' parallel array of tile indexes is sorted. This complicates things,%@AE@%%@NL@% %@AB@%' but makes the sort much faster, since two-byte integers are swapped%@AE@%%@NL@% %@AB@%' instead of 46-byte Tile variables.%@AE@%%@NL@% %@AB@%' ======================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% SUB TorusSort (Low, High)%@NL@% SHARED T() AS Tile, Index() AS INTEGER%@NL@% DIM Partition AS SINGLE%@NL@% %@NL@% IF Low < High THEN%@NL@% %@AB@% ' If only one, compare and swap if necessary%@AE@%%@NL@% %@AB@% ' The SUB procedure only stops recursing when it reaches this point%@AE@%%@NL@% IF High - Low = 1 THEN%@NL@% IF T(Index(Low)).z1 > T(Index(High)).z1 THEN%@NL@% CountTiles High, Low%@NL@% SWAP Index(Low), Index(High)%@NL@% END IF%@NL@% ELSE%@NL@% %@AB@% ' If more than one, separate into two random groups%@AE@%%@NL@% RandIndex = INT(RND * (High - Low + 1)) + Low%@NL@% CountTiles High, Low%@NL@% SWAP Index(High), Index(RandIndex%)%@NL@% Partition = T(Index(High)).z1%@NL@% %@AB@% ' Sort one group%@AE@%%@NL@% DO%@NL@% I = Low: J = High%@NL@% %@AB@% ' Find the largest%@AE@%%@NL@% DO WHILE (I < J) AND (T(Index(I)).z1 <= Partition)%@NL@% I = I + 1%@NL@% LOOP%@NL@% %@AB@% ' Find the smallest%@AE@%%@NL@% DO WHILE (J > I) AND (T(Index(J)).z1 >= Partition)%@NL@% J = J - 1%@NL@% LOOP%@NL@% %@AB@% ' Swap them if necessary%@AE@%%@NL@% IF I < J THEN%@NL@% CountTiles High, Low%@NL@% SWAP Index(I), Index(J)%@NL@% END IF%@NL@% LOOP WHILE I < J%@NL@% %@NL@% %@AB@% ' Now get the other group and recursively sort it%@AE@%%@NL@% CountTiles High, Low%@NL@% SWAP Index(I), Index(High)%@NL@% IF (I - Low) < (High - I) THEN%@NL@% TorusSort Low, I - 1%@NL@% TorusSort I + 1, High%@NL@% ELSE%@NL@% TorusSort I + 1, High%@NL@% TorusSort Low, I - 1%@NL@% END IF%@NL@% END IF%@NL@% END IF%@NL@% %@NL@% END SUB%@NL@% %@NL@% %@NL@% %@NL@% %@2@%%@AH@%UIASM.ASM%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\UIASM.ASM%@AE@%%@NL@% %@NL@% %@AB@%;-----------------------------------------------------------------------------%@AE@%%@NL@% %@AB@%;-----------------------------------------------------------------------------%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; UIASM.ASM%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; Copyright (C) 1989 Microsoft Corporation, All Rights Reserved%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%; GetCopyBox : Gets screen box info and places into string variable%@AE@%%@NL@% %@AB@%; PutCopyBox : Puts screen box info from string variable onto screen%@AE@%%@NL@% %@AB@%; AttrBox : Changes the color attributes of all characters within a box%@AE@%%@NL@% %@AB@%;%@AE@%%@NL@% %@AB@%;-----------------------------------------------------------------------------%@AE@%%@NL@% %@AB@%;-----------------------------------------------------------------------------%@AE@%%@NL@% %@NL@% %@AB@%;NOTE: For optimum speed, these routines write directly to screen memory%@AE@%%@NL@% %@AB@%; without waiting for re-trace. If "snow" is a problem, these routines%@AE@%%@NL@% %@AB@%; will need modification.%@AE@%%@NL@% %@NL@% .model medium%@NL@% %@NL@% extrn STRINGADDRESS:far %@AB@%;BASIC RTL entry point for string info%@AE@%%@NL@% %@NL@% .data%@NL@% %@NL@% attr db ? %@AB@%;destination attribute (AttrBox)%@AE@%%@NL@% x0 db ? %@AB@%;x coord of upper-left%@AE@%%@NL@% y0 db ? %@AB@%;y coord of upper-left%@AE@%%@NL@% x1 db ? %@AB@%;x coord of lower-right%@AE@%%@NL@% y1 db ? %@AB@%;y coord of lower-right%@AE@%%@NL@% bwidth db ? %@AB@%;box width%@AE@%%@NL@% height db ? %@AB@%;box height%@AE@%%@NL@% strdoff dw ? %@AB@%;string pointer offset%@AE@%%@NL@% strdseg dw ? %@AB@%;string pointer segment%@AE@%%@NL@% scrseg dw ? %@AB@%;screen segment%@AE@%%@NL@% movword dw ? %@AB@%;word count to move/change%@AE@%%@NL@% %@NL@% .code%@NL@% %@NL@% %@AB@%;---------------------------------------place segment of screen memory%@AE@%%@NL@% %@AB@%;---------------------------------------in SCRSEG%@AE@%%@NL@% get_scrseg proc%@NL@% %@NL@% push ax %@AB@%;save value of AX%@AE@%%@NL@% mov ah,0Fh%@NL@% int 10h %@AB@%;INT 10H fn. 0Fh - Get Video Mode%@AE@%%@NL@% mov dgroup:scrseg,0B800h %@AB@%;assume COLOR screen for now%@AE@%%@NL@% cmp al,07h %@AB@%;is it MONOCHROME mode?%@AE@%%@NL@% jne arnd1%@NL@% mov dgroup:scrseg,0B000h %@AB@%;yes, set for mono screen seg%@AE@%%@NL@% arnd1: pop ax %@AB@%;restore AX%@AE@%%@NL@% ret %@AB@%;and exit%@AE@%%@NL@% %@NL@% get_scrseg endp%@NL@% %@NL@% %@NL@% %@AB@%;----------------------------------------Given X and Y in AH and AL, find%@AE@%%@NL@% %@AB@%;----------------------------------------the offset into screen memory and%@AE@%%@NL@% %@AB@%;----------------------------------------return in AX%@AE@%%@NL@% get_memxy proc%@NL@% %@NL@% push dx %@AB@%;save DX%@AE@%%@NL@% push ax %@AB@%;save coords%@AE@%%@NL@% mov dl,160%@NL@% mul dl %@AB@%;multiply Y by 160%@AE@%%@NL@% pop dx %@AB@%;put coords in DX%@AE@%%@NL@% mov dl,dh%@NL@% mov dh,0%@NL@% add dl,dl %@AB@%;double X%@AE@%%@NL@% add ax,dx %@AB@%;and add to mult. result for final!%@AE@%%@NL@% pop dx %@AB@%;restore DX%@AE@%%@NL@% ret%@NL@% %@NL@% get_memxy endp%@NL@% %@NL@% %@NL@% %@AB@%;-----------------------------------------------------------------------------%@AE@%%@NL@% %@AB@%;----------------------------------------This is the routine that copies%@AE@%%@NL@% %@AB@%;----------------------------------------screen info to the string variable%@AE@%%@NL@% %@AB@%;-----------------------------------------------------------------------------%@AE@%%@NL@% public getcopybox%@NL@% getcopybox proc far%@NL@% %@NL@% push bp%@NL@% mov bp,sp%@NL@% push ds%@NL@% push es%@NL@% push si%@NL@% push di %@AB@%;preserve registers%@AE@%%@NL@% %@NL@% get_start:%@NL@% mov bx,[bp + 14] %@AB@%;get y0%@AE@%%@NL@% mov ax,[bx]%@NL@% mov y0,al%@NL@% mov bx,[bp + 12] %@AB@%;...x0%@AE@%%@NL@% mov ax,[bx]%@NL@% mov x0,al%@NL@% mov bx,[bp + 10] %@AB@%;...y1%@AE@%%@NL@% mov ax,[bx]%@NL@% mov y1,al%@NL@% mov bx,[bp + 8] %@AB@%;...x1%@AE@%%@NL@% mov ax,[bx]%@NL@% mov x1,al%@NL@% mov bx,[bp + 6] %@AB@%;...and the destination str desc.%@AE@%%@NL@% %@NL@% push bx%@NL@% call STRINGADDRESS %@AB@%;for both near and far string support%@AE@%%@NL@% mov strdoff, ax%@NL@% mov strdseg, dx%@NL@% %@NL@% dec x0 %@AB@%;subtract 1 from%@AE@%%@NL@% dec y0 %@AB@%;all coordinates%@AE@%%@NL@% dec x1 %@AB@%;to reflect BASIC's%@AE@%%@NL@% dec y1 %@AB@%;screen base of 1 (not 0)%@AE@%%@NL@% %@NL@% get_chkscr:%@NL@% call get_scrseg %@AB@%;set up screen segment%@AE@%%@NL@% %@NL@% get_setstr:%@NL@% mov al,x1%@NL@% sub al,x0 %@AB@%;find width of box%@AE@%%@NL@% mov bwidth,al %@AB@%;and save%@AE@%%@NL@% add al,1 %@AB@%;add one to width%@AE@%%@NL@% mov ah,0 %@AB@%;to find # words to move%@AE@%%@NL@% mov movword,ax %@AB@%;MovWord = (width+1)%@AE@%%@NL@% mov al,y1%@NL@% sub al,y0 %@AB@%;find height of box%@AE@%%@NL@% mov height,al %@AB@%;and save%@AE@%%@NL@% mov es,strdseg%@NL@% mov di,strdoff %@AB@%;string is the destination%@AE@%%@NL@% mov si,offset bwidth %@AB@%;point to width%@AE@%%@NL@% movsb %@AB@%;put width in string%@AE@%%@NL@% mov si,offset height%@NL@% movsb %@AB@%;and the height, too%@AE@%%@NL@% %@NL@% get_movstr:%@NL@% mov al,y0%@NL@% mov ah,x0 %@AB@%;put coords in AH and AL%@AE@%%@NL@% call get_memxy %@AB@%;and find offset into screen mem%@AE@%%@NL@% mov si,ax %@AB@%;this will be the source%@AE@%%@NL@% %@NL@% get_domove:%@NL@% mov cx,movword%@NL@% push ds%@NL@% mov ds,scrseg%@NL@% rep movsw %@AB@%;move a row into the string%@AE@%%@NL@% pop ds%@NL@% add si,160%@NL@% sub si,movword %@AB@%;Add 160-(movword*2) to si%@AE@%%@NL@% sub si,movword %@AB@%;to point to next row%@AE@%%@NL@% cmp height,0 %@AB@%;was that the last row?%@AE@%%@NL@% je get_done %@AB@%;yes, we're done%@AE@%%@NL@% dec height %@AB@%;decrement height%@AE@%%@NL@% jmp get_domove %@AB@%;and do another row%@AE@%%@NL@% %@NL@% get_done:%@NL@% pop di%@NL@% pop si%@NL@% pop es%@NL@% pop ds %@AB@%;restore registers%@AE@%%@NL@% pop bp%@NL@% ret 10 %@AB@%;there were 5 parameters%@AE@%%@NL@% %@NL@% getcopybox endp%@NL@% %@NL@% %@NL@% %@AB@%;-----------------------------------------------------------------------------%@AE@%%@NL@% %@AB@%;----------------------------------------This is the routine that copies the%@AE@%%@NL@% %@AB@%;----------------------------------------information stored in the string to%@AE@%%@NL@% %@AB@%;----------------------------------------the screen in the specified location%@AE@%%@NL@% %@AB@%;-----------------------------------------------------------------------------%@AE@%%@NL@% public putcopybox%@NL@% putcopybox proc far%@NL@% %@NL@% push bp%@NL@% mov bp,sp%@NL@% push ds%@NL@% push es%@NL@% push si%@NL@% push di %@AB@%;preserve registers%@AE@%%@NL@% %@NL@% %@NL@% put_start:%@NL@% mov bx,[bp + 10] %@AB@%;get y0%@AE@%%@NL@% mov ax,[bx]%@NL@% mov y0,al%@NL@% mov bx,[bp + 8] %@AB@%;...x0%@AE@%%@NL@% mov ax,[bx]%@NL@% mov x0,al%@NL@% mov bx,[bp + 6] %@AB@%;...and the destination string%@AE@%%@NL@% %@NL@% push bx%@NL@% call STRINGADDRESS %@AB@%;for both near and far string support%@AE@%%@NL@% mov strdoff, ax%@NL@% mov strdseg, dx%@NL@% %@NL@% dec x0 %@AB@%;subtract 1 from%@AE@%%@NL@% dec y0 %@AB@%;all coordinates%@AE@%%@NL@% %@NL@% put_chkscr:%@NL@% call get_scrseg %@AB@%;set up scrseg%@AE@%%@NL@% %@NL@% put_setstr:%@NL@% push ds%@NL@% pop es %@AB@%;equate ES to DS%@AE@%%@NL@% %@NL@% mov si,strdoff %@AB@%;point DS:SI to string mem%@AE@%%@NL@% push ds%@NL@% mov ds,strdseg%@NL@% mov di,offset bwidth%@NL@% movsb %@AB@%;get width%@AE@%%@NL@% mov di,offset height%@NL@% movsb %@AB@%;and height out of string%@AE@%%@NL@% pop ds%@NL@% %@NL@% mov al,bwidth%@NL@% add al,1%@NL@% mov ah,0%@NL@% mov movword,ax %@AB@%;set movword to (bwidth+1)%@AE@%%@NL@% %@NL@% mov ah,x0%@NL@% mov al,y0 %@AB@%;get coords%@AE@%%@NL@% call get_memxy %@AB@%;and find offset into screen mem%@AE@%%@NL@% mov di,ax%@NL@% mov es,scrseg %@AB@%;ES:DI -> screen mem (UL corner)%@AE@%%@NL@% %@NL@% put_domove:%@NL@% mov cx,movword%@NL@% push ds%@NL@% mov ds,strdseg%@NL@% rep movsw %@AB@%;move a row onto the screen%@AE@%%@NL@% pop ds%@NL@% add di,160%@NL@% sub di,movword %@AB@%;add 160-(movword*2) to DI%@AE@%%@NL@% sub di,movword %@AB@%;to point to next row on screen%@AE@%%@NL@% cmp height,0 %@AB@%;was that the last row?%@AE@%%@NL@% je put_done %@AB@%;yes, we're finished%@AE@%%@NL@% dec height%@NL@% jmp put_domove %@AB@%;no, decrement and do again%@AE@%%@NL@% %@NL@% put_done:%@NL@% pop di%@NL@% pop si%@NL@% pop es%@NL@% pop ds %@AB@%;restore registers%@AE@%%@NL@% pop bp%@NL@% ret 6 %@AB@%;pop off 3 parameters%@AE@%%@NL@% %@NL@% putcopybox endp%@NL@% %@NL@% %@AB@%;-----------------------------------------------------------------------------%@AE@%%@NL@% %@AB@%;----------------------------------------This is the routine that changes%@AE@%%@NL@% %@AB@%;----------------------------------------the colors of the box's characters%@AE@%%@NL@% %@AB@%;-----------------------------------------------------------------------------%@AE@%%@NL@% public attrbox%@NL@% attrbox proc far%@NL@% %@NL@% push bp%@NL@% mov bp, sp%@NL@% push ds%@NL@% push es%@NL@% push si%@NL@% push di %@AB@%;preserve registers%@AE@%%@NL@% %@NL@% atr_start:%@NL@% mov bx, [bp+14] %@AB@%;get y0%@AE@%%@NL@% mov ax, [bx]%@NL@% mov y0, al%@NL@% mov bx, [bp+12] %@AB@%;...x0%@AE@%%@NL@% mov ax, [bx]%@NL@% mov x0, al%@NL@% mov bx, [bp+10] %@AB@%;...y1%@AE@%%@NL@% mov ax, [bx]%@NL@% mov y1, al%@NL@% mov bx, [bp+8] %@AB@%;...x1%@AE@%%@NL@% mov ax, [bx]%@NL@% mov x1, al%@NL@% mov bx, [bp+6] %@AB@%;...and finally the new color value%@AE@%%@NL@% mov ax, [bx]%@NL@% mov attr, al%@NL@% %@NL@% dec y0 %@AB@%;subtract 1 from%@AE@%%@NL@% dec x0 %@AB@%;all coordinates%@AE@%%@NL@% dec y1 %@AB@%;to reflect BASIC's%@AE@%%@NL@% dec x1 %@AB@%;screen base of 1 (not 0)%@AE@%%@NL@% %@NL@% atr_chkscr:%@NL@% call get_scrseg %@AB@%;set up screen segment%@AE@%%@NL@% %@NL@% atr_setup:%@NL@% mov al, x1%@NL@% sub al, x0 %@AB@%;find width of box%@AE@%%@NL@% inc al%@NL@% xor ah, ah%@NL@% mov movword, ax %@AB@%;(width + 1 = movword)%@AE@%%@NL@% mov al, y1%@NL@% sub al, y0 %@AB@%;find height of box%@AE@%%@NL@% mov height, al %@AB@%;and save%@AE@%%@NL@% %@NL@% atr_chgclr:%@NL@% mov al, y0%@NL@% mov ah, x0 %@AB@%;put coords in AH and AL%@AE@%%@NL@% call get_memxy %@AB@%;find offset into screen memory%@AE@%%@NL@% mov di, ax %@AB@%;(which is our destination)%@AE@%%@NL@% mov es, scrseg%@NL@% mov al, attr %@AB@%;get the color value to store%@AE@%%@NL@% %@NL@% atr_doit:%@NL@% mov cx, movword%@NL@% atr_loop:%@NL@% inc di %@AB@%;skip the character value%@AE@%%@NL@% stosb %@AB@%;write new color value%@AE@%%@NL@% loop atr_loop %@AB@%;cx times%@AE@%%@NL@% add di, 160 %@AB@%;add 160-(movword*2) to di%@AE@%%@NL@% sub di, movword%@NL@% sub di, movword%@NL@% cmp height, 0 %@AB@%;was that the last row?%@AE@%%@NL@% je atr_done %@AB@%;yes, we be finished%@AE@%%@NL@% dec height %@AB@%;no, decrement height%@AE@%%@NL@% jmp atr_doit%@NL@% %@NL@% atr_done:%@NL@% pop di%@NL@% pop si%@NL@% pop es%@NL@% pop ds%@NL@% pop bp %@AB@%;restore registers%@AE@%%@NL@% ret 10 %@AB@%;pull off 5 paramters and return%@AE@%%@NL@% %@NL@% attrbox endp%@NL@% %@NL@% END%@NL@% %@NL@% %@NL@% %@2@%%@AH@%UIDEMO.BAS%@AE@%%@EH@%%@NL@% %@AS@%CD-ROM Disc Path: \SAMPCODE\BASIC\UIDEMO.BAS%@AE@%%@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' UIDEMO.BAS Copyright (c) 1989 Microsoft Corporation%@AE@%%@NL@% %@AB@%'%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' Decls, includes, and dimensions%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% DEFINT A-Z%@NL@% DECLARE SUB AboutDemo ()%@NL@% DECLARE SUB AboutUIP ()%@NL@% DECLARE SUB AboutMouse ()%@NL@% DECLARE SUB AboutAccess ()%@NL@% DECLARE SUB AboutQuick ()%@NL@% DECLARE SUB AboutWindows ()%@NL@% DECLARE SUB ColorDisplay ()%@NL@% DECLARE SUB DemoAlert ()%@NL@% DECLARE SUB DemoDialog ()%@NL@% DECLARE SUB DemoDialogEZ ()%@NL@% DECLARE SUB DemoFileNameListBox ()%@NL@% DECLARE SUB DemoListBox ()%@NL@% DECLARE SUB DemoWindow ()%@NL@% DECLARE SUB DemoScrollBar ()%@NL@% DECLARE SUB DemoResize ()%@NL@% DECLARE SUB MonoDisplay ()%@NL@% DECLARE SUB SetupDesktop ()%@NL@% DECLARE SUB SetupMenu ()%@NL@% DECLARE FUNCTION GetFileCount% (FileSpec$)%@NL@% %@NL@% %@AB@%'$INCLUDE: 'general.bi'%@AE@%%@NL@% %@AB@%'$INCLUDE: 'mouse.bi'%@AE@%%@NL@% %@AB@%'$INCLUDE: 'menu.bi'%@AE@%%@NL@% %@AB@%'$INCLUDE: 'window.bi'%@AE@%%@NL@% %@NL@% COMMON SHARED /uitools/ GloMenu AS MenuMiscType%@NL@% COMMON SHARED /uitools/ GloTitle() AS MenuTitleType%@NL@% COMMON SHARED /uitools/ GloItem() AS MenuItemType%@NL@% COMMON SHARED /uitools/ GloWindow() AS windowType%@NL@% COMMON SHARED /uitools/ GloButton() AS buttonType%@NL@% COMMON SHARED /uitools/ GloEdit() AS EditFieldType%@NL@% COMMON SHARED /uitools/ GloStorage AS WindowStorageType%@NL@% COMMON SHARED /uitools/ GloWindowStack() AS INTEGER%@NL@% COMMON SHARED /uitools/ GloBuffer$()%@NL@% %@NL@% DIM GloTitle(MAXMENU) AS MenuTitleType%@NL@% DIM GloItem(MAXMENU, MAXITEM) AS MenuItemType%@NL@% DIM GloWindow(MAXWINDOW) AS windowType%@NL@% DIM GloButton(MAXBUTTON) AS buttonType%@NL@% DIM GloEdit(MAXEDITFIELD) AS EditFieldType%@NL@% DIM GloWindowStack(MAXWINDOW) AS INTEGER%@NL@% DIM GloBuffer$(MAXWINDOW + 1, 2)%@NL@% %@NL@% DIM SHARED DisplayType AS INTEGER%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Initialize Demo%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% MenuInit%@NL@% WindowInit%@NL@% MouseShow%@NL@% MonoDisplay%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Show Opening alert window%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% %@NL@% a$ = "User Interface Toolbox Demo|"%@NL@% a$ = a$ + "for|"%@NL@% a$ = a$ + "Microsoft BASIC 7.0 Professional Development System|"%@NL@% a$ = a$ + "Copyright (c) 1989 Microsoft Corporation|"%@NL@% %@NL@% x = Alert(4, a$, 9, 10, 14, 70, "Color", "Monochrome", "")%@NL@% %@NL@% IF x = 1 THEN%@NL@% DisplayType = TRUE%@NL@% ColorDisplay%@NL@% END IF%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Main Loop : Stay in loop until DemoFinished set to TRUE%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% DemoFinished = FALSE%@NL@% %@NL@% WHILE NOT DemoFinished%@NL@% kbd$ = MenuInkey$%@NL@% WHILE MenuCheck(2)%@NL@% GOSUB MenuTrap%@NL@% WEND%@NL@% WEND%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' End Program%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% MouseHide%@NL@% COLOR 15, 0%@NL@% CLS%@NL@% END%@NL@% %@NL@% %@NL@% %@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@AB@%' If a menu event occured, call the proper demo, or if Exit, set demoFinished%@AE@%%@NL@% %@AB@%' ===========================================================================%@AE@%%@NL@% %@NL@% MenuTrap:%@NL@% menu = MenuCheck(0)%@NL@% item = MenuCheck(1)%@NL@% %@NL@% SELECT CASE menu%@NL@% CASE 1%@NL@% SELECT CASE item%@NL@% CASE 1: DemoAlert%@NL@% CASE 2: DemoDialogEZ%@NL@% CASE 3: DemoDialog%@NL@% CASE 4: DemoListBox%@NL@% CASE 5: DemoFileNameListBox%@NL@% CASE 6: DemoScrollBar%@NL@% CASE 7: DemoWindow%@NL@% CASE 8: DemoResize%@NL@% CASE 10: DemoFinished = TRUE%@NL@% END SELECT%@NL@% CASE 2%@NL@% SELECT CASE item%@NL@% CASE 1: ColorDisplay%@NL@% CASE 2: MonoDisplay%@NL@% %@NL@% END SELECT%@NL@% CASE 3%@NL@% SELECT CASE item%@NL@% CASE 1: AboutDemo%@NL@% CASE 2: AboutUIP%@NL@% CASE 3: AboutWindows%@NL@% CASE 4: AboutMouse%@NL@% CASE 5: AboutAccess%@NL@% CASE 6: AboutQuick%@NL@% END SELECT%@NL@% CASE ELSE%@NL@% END SELECT%@NL@% RETURN%@NL@% %@NL@% SUB AboutAccess%@NL@% a$ = " Access Keys||"%@NL@% a$ = a$ + "Access keys are the keys on the menu bar that are highlighted|"%@NL@% a$ = a$ + "when you press the Alt key. If you press a letter that is|"%@NL@% a$ = a$ + "highlighted in a menu title, that menu will be selected.||"%@NL@% a$ = a$ + "Once a pull-down menu is displayed, each menu item also has a|"%@NL@% a$ = a$ + "highlighted letter associated with each choice. Press the|"%@NL@% a$ = a$ + "letter that corresponds to the menu item you want to select.||"%@NL@% a$ = a$ + "If, after you press Alt, you change your mind, press the Alt|"%@NL@% a$ = a$ + "key again to cancel."%@NL@% %@NL@% junk = Alert(1, a$, 7, 9, 20, 69, "", "", "")%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB AboutDemo%@NL@% a$ = " About This Demo||"%@NL@% a$ = a$ + "Running this program provides a visual demonstration of most|"%@NL@% a$ = a$ + "of the features implemented in the new User Interface Toolbox|"%@NL@% a$ = a$ + "for the BASIC Compiler 7.0.||"%@NL@% a$ = a$ + "In addition to serving as a demo of toolbox features, the|"%@NL@% a$ = a$ + "source code that makes up this program can also serve as a|"%@NL@% a$ = a$ + "programming example of how to implement these features in|"%@NL@% a$ = a$ + "your programs. While the demo is relatively simple, it does|"%@NL@% a$ = a$ + "illustrate almost all the features available."%@NL@% %@NL@% junk = Alert(1, a$, 7, 9, 19, 69, "", "", "")%@NL@% END SUB%@NL@% %@NL@% SUB AboutMouse%@NL@% a$ = " Using the Mouse||"%@NL@% a$ = a$ + "Virtually all operations in the User Interface Toolbox can|"%@NL@% a$ = a$ + "be accomplished using the mouse. Move the mouse cursor to|"%@NL@% a$ = a$ + "whatever you want to select and press the left button.||"%@NL@% a$ = a$ + "In addition to being able to make a choice with a mouse,|"%@NL@% a$ = a$ + "you can also perform a number of operations on windows.|"%@NL@% a$ = a$ + "Using the mouse you can close, move, or resize windows|"%@NL@% a$ = a$ + "depending on the particular features of the window that is|"%@NL@% a$ = a$ + "active."%@NL@% %@NL@% junk = Alert(1, a$, 7, 9, 19, 69, "", "", "")%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB AboutQuick%@NL@% a$ = " Quick Keys||"%@NL@% a$ = a$ + "Quick keys are optional keys that you can define in addition|"%@NL@% a$ = a$ + "to the normal access keys that must be specified when you|"%@NL@% a$ = a$ + "set up the individual menu items.||"%@NL@% a$ = a$ + "Quick keys normally reduce selection of a menu item to one|"%@NL@% a$ = a$ + "keystroke. For example, this demo uses function keys F1 thru|"%@NL@% a$ = a$ + "F8 to select menu choices that demonstrate different features|"%@NL@% a$ = a$ + "of the User Interface Toolbox. Additionally, Ctrl-X is the|"%@NL@% a$ = a$ + "Quick key that exits this demonstration program."%@NL@% %@NL@% junk = Alert(1, a$, 7, 9, 19, 69, "", "", "")%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB AboutUIP%@NL@% a$ = " About the User Interface||"%@NL@% a$ = a$ + "The user interface provided with this toolbox is designed to|"%@NL@% a$ = a$ + "provide much the same functionality as that found in the QBX|"%@NL@% a$ = a$ + "programming environment. The menus, check boxes, option|"%@NL@% a$ = a$ + "buttons, and other interface features operate similarly to|"%@NL@% a$ = a$ + "their QBX counterparts. ||"%@NL@% a$ = a$ + "If you know how to navigate QBX, you know how to navigate|"%@NL@% a$ = a$ + "the interface provided by the User Interface Toolbox."%@NL@% %@NL@% junk = Alert(1, a$, 7, 9, 18, 69, "", "", "")%@NL@% END SUB%@NL@% %@NL@% SUB AboutWindows%@NL@% a$ = " About the Windows||"%@NL@% a$ = a$ + "Several border characters used by the windows in the User|"%@NL@% a$ = a$ + "Interface Toolbox have special significance. Any window that|"%@NL@% a$ = a$ + "has a '=' in the upper-left corner can be closed by selecting|"%@NL@% a$ = a$ + "that character with the mouse. Windows with the '░' character|"%@NL@% a$ = a$ + "across the window's top row can be moved around the screen by|"%@NL@% a$ = a$ + "selecting that area with the mouse. The '+' character in the|"%@NL@% a$ = a$ + "lower-right corner means that the window can be resized by|"%@NL@% a$ = a$ + "selecting the '+' character with the mouse.||"%@NL@% a$ = a$ + "Note that none of these features can be accessed without a|"%@NL@% a$ = a$ + "mouse. "%@NL@% %@NL@% junk = Alert(1, a$, 7, 9, 21, 69, "", "", "")%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB ColorDisplay%@NL@% DisplayType = TRUE%@NL@% MouseHide%@NL@% SetupMenu%@NL@% MenuSetState 2, 1, 2%@NL@% MenuSetState 2, 2, 1%@NL@% SetupDesktop%@NL@% MenuShow%@NL@% MouseShow%@NL@% END SUB%@NL@% %@NL@% SUB DemoAlert%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Simple little demo of how easy alerts are to use.%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% a$ = "|"%@NL@% a$ = a$ + "This is an Alert Box.| |"%@NL@% a$ = a$ + "It was created using a simple one|"%@NL@% a$ = a$ + "line command. Notice the buttons|"%@NL@% a$ = a$ + "below. They are user definable|"%@NL@% a$ = a$ + "yet their spacing is automatic."%@NL@% %@NL@% B$ = "You Selected OK"%@NL@% %@NL@% C$ = "You Selected Cancel"%@NL@% %@NL@% SELECT CASE Alert(4, a$, 6, 20, 15, 60, "OK", "Cancel", "")%@NL@% CASE 1%@NL@% x = Alert(4, B$, 10, 25, 12, 55, "OK", "", "")%@NL@% CASE 2%@NL@% x = Alert(4, C$, 10, 25, 12, 55, "OK", "", "")%@NL@% END SELECT%@NL@% %@NL@% END SUB%@NL@% %@NL@% SUB DemoDialog%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' This is about as complex as they get. As you can see it is still very%@AE@%%@NL@% %@AB@% ' simple - just a lot bigger. This sub exactly duplicates the%@AE@%%@NL@% %@AB@% ' functionality of the QuickBASIC Search-Change dialog box.%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Open Window, place a horizontal line on row 13%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% WindowOpen 1, 6, 11, 19, 67, 0, 7, 0, 7, 15, FALSE, FALSE, FALSE, TRUE, 1, ""%@NL@% %@NL@% WindowLine 13%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Print the text, and boxes for the edit fields%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% WindowLocate 2, 2%@NL@% WindowPrint 2, "Find What:"%@NL@% WindowBox 1, 14, 3, 56%@NL@% %@NL@% WindowLocate 5, 2%@NL@% WindowPrint 2, "Change To:"%@NL@% WindowBox 4, 14, 6, 56%@NL@% %@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Print the title of the window -- This overides the string in WindowOpen%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% WindowLocate 0, 26%@NL@% WindowPrint 1, " Change "%@NL@% %@NL@% WindowBox 8, 32, 12, 56%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Open Edit fields%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% search$ = ""%@NL@% replace$ = ""%@NL@% EditFieldOpen 1, search$, 2, 15, 0, 0, 40, 39%@NL@% %@NL@% EditFieldOpen 2, replace$, 5, 15, 0, 0, 40, 39%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Open all buttons%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% ButtonOpen 1, 1, "Match Upper/Lowercase", 9, 2, 0, 0, 2%@NL@% ButtonOpen 2, 1, "Whole Word", 10, 2, 0, 0, 2%@NL@% ButtonOpen 3, 1, "1. Active Window", 9, 34, 0, 0, 3%@NL@% ButtonOpen 4, 2, "2. Current Module", 10, 34, 0, 0, 3%@NL@% ButtonOpen 5, 1, "3. All Modules", 11, 34, 0, 0, 3%@NL@% ButtonOpen 6, 2, "Find and Verify", 14, 2, 0, 0, 1%@NL@% ButtonOpen 7, 1, "Change All", 14, 22, 0, 0, 1%@NL@% ButtonOpen 8, 1, "Cancel", 14, 38, 0, 0, 1%@NL@% ButtonOpen 9, 1, "Help", 14, 49, 0, 0, 1%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Set initial states to match initial button settings%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% MatchState = FALSE%@NL@% WordState = FALSE%@NL@% searchState = 2%@NL@% pushButton = 1%@NL@% currButton = 0%@NL@% currEditField = 1%@NL@% %@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@AB@% ' Do until exitFlag is set%@AE@%%@NL@% %@AB@% ' =======================================================================%@AE@%%@NL@% %@NL@% ExitFlag = FALSE%@NL@% WHILE NOT ExitFlag%@NL@% WindowDo currButton, currEditField%@NL@% SELECT CASE Dialog(0)%@NL@% CASE 0, 3, 4, 5, 20%@NL@% %@NL@% %@AB@% ' ==============================================================%@AE@%%@NL@% %@AB@% ' If edit field clicked, assign currEditField to Dialog(2)%@AE@%%@NL@% %@AB@% ' ==============================================================%@AE@%%@NL@% %@NL@% CASE 2%@NL@% currButton = 0%@NL@% currEditField = Dialog(2)%@NL@% %@NL@% %@AB@% ' ==============================================================%@AE@%%@NL@% %@AB@% ' If escape is hit, set pushbutton = 0 and exit flag%@AE@%%@NL@% %@AB@% ' ==============================================================%@AE@%%@NL@% %@NL@% CASE 9 '(Escape)%@NL@% pushButton = 3%@NL@% ExitFlag = TRUE%@NL@% %@NL@% %@AB@% ' ==============================================================%@AE@%%@NL@% %@AB@% ' If return is hit, perform action based on the current button%@AE@%%@NL@% %@AB@% ' Button 9 is the help button. In that case, show help, else just%@AE@%%@NL@% %@AB@% ' exit%@AE@%%@NL@% %@AB@% ' ==============================================================%@AE@%%@NL@% %@NL@% CASE 6%@NL@% SELECT CASE currButton%@NL@% CASE 9%@NL@% a$ = "Sample Help Window"%@NL@% ButtonSetState pushButton + 5, 1%@NL@% pushButton = 4%@NL@% ButtonSetState pushButton + 5, 2%@NL@% junk = Alert(4, a$, 7, 9, 19, 69, "", "", "")%@NL@% CASE ELSE%@NL@% ExitFlag = TRUE%@NL@% END SELECT%@NL@% %@NL@% %@NL@% %@AB@% ' ==============================================================%@AE@%%@NL@% %@AB@% ' A Button was pushed with mouse. Perform the desired action%@AE@%%@NL@% %@AB@% ' based on Button%@AE@%%@NL@% %@AB@% ' ==============================================================%@AE@%%@NL@% %@NL@% CASE 1%@NL@% currButton = Dialog(1)%@NL@% currEditField = 0%@NL@% SELECT CASE currButton%@NL@% CASE 1%@NL@% MatchState = NOT MatchState%@NL@% ButtonToggle 1%@NL@% CASE 2%@NL@% WordState = NOT WordState%@NL@% ButtonToggle 2%@NL@% CASE 3, 4, 5%@NL@% ButtonSetState searchState + 2, 1%@NL@% searchState = Dialog(1) - 2%@NL@% ButtonSetState searchState + 2, 2%@NL@% CASE 6, 7, 8%@NL@% pushButton = Dialog(1) - 5%@NL@% ExitFlag = TRUE%@NL@% CASE 9%@NL@% a$ = "Sample Help Window"%@NL@% ButtonSetState pushButton + 5, 1%@NL@% pushButton = Dialog(1) - 5%@NL@% ButtonSetState pushButton + 5, 2%@NL@% junk = Alert(4, a$, 7, 9, 19, 69, "", "", "")%@NL@% CASE ELSE%@NL@% END SELECT%@NL@% %@NL@% %@NL@% %@AB@% ' ==============================================================%@AE@%%@NL@% %@AB@% ' Tab was hit. Depending upon the current button, or current edit field,%@AE@%%@NL@% %@AB@% ' assign the new values to currButton, and currEditField%@AE@%%@NL@% %@AB@% ' ==============================================================%@AE@%%@NL@% %@NL@% CASE 7 'tab%@NL@% SELECT CASE currButton%@NL@% CASE 0%@NL@% SELECT CASE currEditField%@NL@% CASE 1%@NL@% currEditField = 2%@NL@% %@NL@% CASE ELSE%@NL@% currButton = 1%@NL@% currEditField = 0%@NL@% END SELECT%@NL@% CASE 1%@NL@% currButton = 2%@NL@% CASE 6, 7, 8%@NL@% currButton = currButton + 1%@NL@% ButtonSetState pushButton + 5, 1%@NL@% pushButton = currButton - 5%@NL@% ButtonSetState pushButton + 5, 2%@NL@% CASE 3, 4, 5%@NL@% currButton = 6%@NL@% CASE 2%@NL@% currButton = 2 + searchState%@NL@% CASE 9%@NL@% currButton = 0%@NL@% ButtonSetState pushButton + 5, 1%@NL@% pushButton = 1%@NL@% ButtonSetState pushButton + 5, 2%@NL@% currEditField = 1%@NL@% END SELECT%@NL@% %@NL@% %@NL@% %@AB@% ' ==============================================================%@AE@%%@NL@% %@AB@% ' Same for Back Tab, only reverse.%@AE@%%@NL@% %@AB@% ' ==============================================================%@AE@%%@NL@% %@NL@% CASE 8 'back tab%@NL@% SELECT CASE currButton%@NL@% CASE 0%@NL@% SELECT CASE currEditField%@NL@% CASE 1%@NL@% currButton = 9%@NL@% ButtonSetState pushButton + 5, 1%@NL@% pushButton = currButton -