Fred Buffington                Input for PBCC/QB              oasys@sbcglobal.net            06-14-02 (  :  )       PBCC,QB,PB             107  2790     SmpInput.bas----------------------------------------------------------�'Fred Buffington - http://thunder.prohosting.com/~oasys�'Here is a simple Text input routine that can be used in �'PBcc or QB and probably PBdos. � �'It includes a PBmain for testing purposes and to show  �'sample calling sequence. � � $COMPILE EXE � � DECLARE FUNCTION Linput(xpos%,ypos%,L%,df$) AS STRING �'------------------------------------------------ �'Linput input routine print brackets around input �'L% is length allow for the input routine �'xpos,ypos initial position on screen �'df$ is the default value �'------------------------------------------------ � FUNCTION PBMAIN() �   CONSOLE SCREEN 26,80 � �   dflt$="TEST" �   COLOR 15,1 �   CLS �   xvar$=linput(5,10,5,dflt$) � �   LOCATE 12,5:PRINT xvar$;"<here" 'test to show result �   WHILE INKEY$="":WEND � END FUNCTION � � FUNCTION Linput(x%,y%,L%,df$) AS STRING �   LOCAL del$,lft$,rit$,zend$,hom$ � �   del$=CHR$(0)+CHR$(83)  'delete key �   Lft$=CHR$(0)+CHR$(75)  'left arrow �   rit$=CHR$(0)+CHR$(77)  'right arrow �   zend$=CHR$(0)+CHR$(79) 'end key �   hom$=CHR$(0)+CHR$(71)  'home key �   position%=0 �'   LOCATE y%,x%-1:PRINT "[";SPACE$(L%);"]"; �'  above can be used to put brackets around the input �   var$=df$ �   LOCATE y%,x%:PRINT var$; �   LOCATE y%,x% �   DO � �       xinp$ = INKEY$ � �'checkmouse here � �       IF xinp$=zend$ THEN position%=l%-1 � �       IF xinp$=Hom$ THEN position%=0 � �       IF xinp$=lft$ THEN xinp$=CHR$(8) 'making 8 nondestructive � �       IF xinp$>CHR$(30) THEN �              IF position%+1>LEN(var$) THEN � �                  var$=var$+xinp$:position%=position%+1 �              ELSE �                  MID$(var$,position%+1,1)=xinp$:position%=position%+1 � �              END IF � �        END IF � �        IF xinp$=CHR$(8) THEN � �'if you want descructive backspace then set xinp$ = del$ and rem position%=position%-1 � �             position%=position%-1 � �             IF position%<0 THEN position%=0 � �        END IF � �        IF xinp$ = del$ THEN � �            IF position%>0 THEN � �               var$=MID$(var$,1,position%)+MID$(var$,position%+2) � �            ELSE � �                 IF LEN(var$)>1 THEN � �                    var$=MID$(var$,2):position%=0 � �                 ELSE �  �                    var$="":position%=0 � �                 END IF � �            END IF � �        END IF � �        IF xinp$=rit$ THEN position%=position%+1 � �        IF position%>=L% THEN position%=L%-1 � �        IF xinp$<>"" THEN LOCATE y%,x%:PRINT SPACE$(L%);:LOCATE y%,x%:PRINT var$;:LOCATE y%,x%+position%:CURSOR ON � �   LOOP UNTIL xinp$=CHR$(13) OR xinp$=CHR$(27) �   linput=var$ � END FUNCTION �PowerBASIC, Inc.               WINDOWS NT INFO                ftp.powerbasic.com             06-27-98 (00:00)       PBCC                   180  5382     NETINFO.BAS '==============================================================================�'�'  Network Info Utility for PB/CC 1.0�'  Copyright (c) 1998 by PowerBASIC, Inc.�'�'  Returns information about the current logged in user.�'�'  IMPORTANT:  This program only works in Windows NT!  The network API calls�'              used are not present in Windows 95 or 98.�'�'==============================================================================��$DIM ALL�$INCLUDE "WIN32API.INC"��'==============================================================================��FUNCTION WinErrMessage(BYVAL x AS LONG) AS STRING��  LOCAL buffer AS ASCIIZ * 64��  FormatMessage %FORMAT_MESSAGE_FROM_SYSTEM, BYVAL %NULL, x, %NULL, buffer, SIZEOF(buffer), BYVAL %NULL��  IF LEN(buffer) THEN�    FUNCTION = buffer�  ELSE�    FUNCTION = FORMAT$(x)�  END IF��END FUNCTION��FUNCTION StrToAnsi(BYVAL u AS LONG) AS STRING��  DIM Buffer AS STRING�  DIM x      AS STRING�  DIM l      AS LONG��  l = lstrlenW(BYVAL u)�  x = PEEK$(u, l * 2)��  Buffer = SPACE$(LEN(x) \ 2)��  WideCharToMultiByte %CP_ACP, _               ' code page�                      %NULL, _                 ' performance and mapping flags�                      BYVAL STRPTR(x), _       ' Unicode string to convert�                      LEN(x), _                ' len of Unicode string�                      BYVAL STRPTR(Buffer), _  ' buffer for ANSI string�                      LEN(Buffer), _           ' len of ANSI buffer�                      BYVAL %NULL, _           ' default for unmappable chars�                      BYVAL %NULL              ' default flag��  IF LEN(Buffer) = 0 THEN�    Buffer = "[none]"�  END IF��  FUNCTION = RTRIM$(Buffer)��END FUNCTION��FUNCTION StrToUnicode(BYVAL x AS STRING) AS STRING��  DIM Buffer AS STRING��  Buffer = SPACE$(LEN(x) * 2)��  MultiByteToWideChar %CP_ACP, _               ' code page�                      %NULL, _                 ' performance and mapping flags�                      BYVAL STRPTR(x), _       ' ANSI string to convert�                      LEN(x), _                ' len of ANSI string�                      BYVAL STRPTR(Buffer), _  ' buffer for Unicode string�                      LEN(Buffer)              ' len of Unicode buffer��  FUNCTION = Buffer��END FUNCTION��'==============================================================================��FUNCTION WinMain (BYVAL CurInst&, _�                  BYVAL PrvInst&, _�                  CmdLine AS ASCIIZ PTR, _�                  BYVAL CmdShow&) EXPORT AS LONG��  LOCAL u        AS ASCIIZ * 256�  LOCAL ni       AS USER_INFO_3 PTR�  LOCAL si       AS SERVER_INFO_102 PTR�  LOCAL wkui     AS WKSTA_USER_INFO_1 PTR�  LOCAL nRet     AS LONG�  LOCAL uW       AS ASCIIZ * 512�  LOCAL tmp      AS STRING��  GetUserName u, 256��  STDOUT "Network information for user " & CHR$(34) & u & CHR$(34)�  STDOUT "Copyright (c) 1998 by PowerBASIC, Inc."�  STDOUT ""��  nRet = NetWkstaUserGetInfo(BYVAL %NULL, 1, wkui)�  IF nRet THEN�    STDOUT "Error: " & WinErrMessage$(nRet)�    EXIT FUNCTION�  END IF��  STDOUT "  Logon Domain: " & StrToAnsi(@wkui.wkui_logon_domain)�  STDOUT "  Logon Server: \\" & StrToAnsi(@wkui.wkui_logon_server)��  nRet = NetWkstaGetInfo(BYVAL %NULL, 102, si)�  IF nRet THEN�    STDOUT ""�    STDOUT "Error: " & WinErrMessage$(nRet)�    EXIT FUNCTION�  END IF��  STDOUT "   System name: \\" & StrToAnsi(@si.sv_name)�  STDOUT "        Hidden: ";��  IF @si.sv_hidden = %SV_HIDDEN THEN�    STDOUT "Yes"�  ELSE�    STDOUT "No"�  END IF��  STDOUT "       Comment: " & StrToAnsi(@si.sv_comment)��  IF @si.sv_type THEN�    STDOUT "         Type: ";�    IF BIT(@si.sv_type, 1) THEN�      STDOUT "Workstation"�    ELSEIF BIT(@si.sv_type, 2) THEN�      STDOUT "Server"�    ELSEIF BIT(@si.sv_type, 3) THEN�      STDOUT "SQL Server"�    ELSEIF BIT(@si.sv_type, 4) THEN�      STDOUT "Primary Domain Controller (PDC)"�    ELSEIF BIT(@si.sv_type, 5) THEN�      STDOUT "Backup Domain Controller (BDC)"�    ELSEIF BIT(@si.sv_type, 6) THEN�      STDOUT "Time Server"�    ELSEIF BIT(@si.sv_type, 7) THEN�      STDOUT "Apple File Protocol Server"�    ELSEIF BIT(@si.sv_type, 8) THEN�      STDOUT "Novell Server"�    ELSEIF BIT(@si.sv_type, 9) THEN�      STDOUT "Domain Member"�    ELSEIF BIT(@si.sv_type, 15) THEN�      STDOUT "Windows NT"�    END IF�  END IF��  uW = StrToUnicode(u)�  nRet = NetUserGetInfo(BYVAL %NULL, uW, 3, ni)�  IF nRet THEN�    STDOUT ""�    STDOUT "Error: " & WinErrMessage$(nRet)�    EXIT FUNCTION�  END IF��  STDOUT ""�  STDOUT "  Account name: " & StrToAnsi(@ni.uName)�  STDOUT "     Full name: " & StrToAnsi(@ni.FullName)�  STDOUT "       Comment: " & StrToAnsi(@ni.Comment)��  SELECT CASE @ni.Privilege�    CASE %USER_PRIV_GUEST : tmp = "Guest"�    CASE %USER_PRIV_USER  : tmp = "User"�    CASE %USER_PRIV_ADMIN : tmp = "Administrator"�    CASE ELSE             : tmp = "Unknown"�  END SELECT��  STDOUT "     Privilege: " & tmp�  STDOUT "Home directory: " & StrToAnsi(@ni.HomeDir)�  STDOUT "   Script Path: " & StrToAnsi(@ni.ScriptPath)�  STDOUT "       Profile: " & StrToAnsi(@ni.Profile)�  STDOUT "  Workstations: " & StrToAnsi(@ni.Workstations)��  NetApiBufferFree ni�  NetApiBufferFree si�  NetApiBufferFree wkui��END FUNCTION�PowerBASIC, Inc.               WINDOWS ERROR MESSAGES         ftp.powerbasic.com             06-27-98 (00:00)       PBCC                   43   1456     WINERR.BAS  '==============================================================================�'�'  WINERR utility for PB/CC�'  Copyright (c) 1998 by PowerBASIC, Inc.  All Rights Reserved.�'�'  This command line utility will display the text for a given Windows error�'  code (see GetLastError() in your Win32 API documentation).�'�'==============================================================================��%NULL                       = 0�%FORMAT_MESSAGE_FROM_SYSTEM = &H1000��DECLARE FUNCTION FormatMessage LIB "KERNEL32.DLL" ALIAS "FormatMessageA" (BYVAL dwFlags AS LONG, lpSource AS ANY, BYVAL dwMessageId AS LONG, BYVAL dwLanguageId AS LONG, lpBuffer AS ASCIIZ, _�                                                                          BYVAL nSize AS LONG, Arguments AS LONG) AS LONG��FUNCTION WinErrMsg(BYVAL x AS LONG) AS STRING��  LOCAL buffer AS ASCIIZ * 64��  FormatMessage %FORMAT_MESSAGE_FROM_SYSTEM, BYVAL %NULL, x, %NULL, buffer, SIZEOF(buffer), BYVAL %NULL��  IF LEN(buffer) THEN�    FUNCTION = "Error " & FORMAT$(x) & " = " & buffer�  ELSE�    FUNCTION = "Unknown error code: " & FORMAT$(x)�  END IF��END FUNCTION��FUNCTION PbMain() AS LONG��  STDOUT "WINERR v1.0 - Windows Error Messages"�  STDOUT "Copyright (c) 1998 by PowerBASIC, Inc. All Rights Reserved."�  STDOUT ""��  IF LEN(COMMAND$) THEN�    STDOUT WinErrMsg( VAL(COMMAND$) )�  ELSE�    STDOUT "Usage:  WINERR error_code"�  END IF��END FUNCTION�PowerBASIC, Inc.               STRIP LEADING TABS FROM FILE   ftp.powerbasic.com             06-27-98 (00:00)       PBCC                   186  4278     DETAB.BAS   '=============================================================================�'�'  Strip leading tabs from a text file.�'  Copyright (c) 1998 by PowerBASIC, Inc.  All Rights Reserved.�'�'=============================================================================��'-----------------------------------------------------------------------------�'�FUNCTION Exist(BYVAL Filenam AS STRING) AS LONG��  FUNCTION = LEN(DIR$(Filenam)) > 0��END FUNCTION��'-----------------------------------------------------------------------------�' MakeBAK - Rename a file with a .BAK extension and return the new filename�'�' Filename = Name of the file to rename.�'�' Returns:�'   Name of file with .BAK extension.�'�FUNCTION MakeBAK(BYVAL Filename AS STRING) AS STRING��  DIM Bak AS STRING�  DIM Dot AS LONG��  Bak = Filename��  '***  Add BAK extension  ***��  Dot = INSTR(Bak, ".")�  IF Dot = 0 THEN�    Bak = Bak + ".BAK"�  ELSE�    Bak = LEFT$(Bak, Dot) + "BAK"�  END IF��  '***  If .BAK file already exists, kill it  ***��  IF Exist(Bak) THEN�    KILL Bak�  END IF��  '***  Rename file  ***��  NAME Filename AS Bak��  '*** Return the new file name ***��  FUNCTION = Bak��END FUNCTION��'----------------------------------------------------------------------------�' ArgC - Return the number of arguments passed in string of command�'        arguments (such as COMMAND$).�'�' Cmd  = COMMAND$, or string of command arguments�'�FUNCTION ArgC(BYVAL Cmd AS STRING) AS LONG��  DIM arg AS LONG�  DIM f   AS STRING�  DIM q   AS LONG��  DO WHILE LEN(cmd)�    INCR arg�    f = LEFT$(cmd, 1)�    IF ASC(f) = 34 THEN�      q = INSTR(MID$(cmd,2), CHR$(34))�      IF q THEN�        f = LEFT$(cmd, q+1)�      ELSE�        f = cmd�      END IF�    ELSE�      f = f + EXTRACT$(MID$(cmd,2), ANY CHR$(34)+" /")�    END IF�    cmd = LTRIM$(MID$(cmd, len(f)+1))�  LOOP��  FUNCTION = arg��END FUNCTION���'----------------------------------------------------------------------------�' ArgV - Return the specified command line argument passed in a string of�'        command arguments (such as COMMAND$).�'�' Which = Number of argument to return.�' Cmd   = COMMAND$, or string of command arguments�'�FUNCTION ArgV(BYVAL Which AS LONG, BYVAL Cmd AS STRING) AS STRING��  DIM arg AS LONG�  DIM f   AS STRING�  DIM q   AS LONG��  DO WHILE LEN(cmd)�    INCR arg�    f = LEFT$(cmd, 1)�    IF ASC(f) = 34 THEN�      q = INSTR(MID$(cmd,2), CHR$(34))�      IF q THEN�        f = LEFT$(cmd, q+1)�      ELSE�        f = cmd�      END IF�    ELSE�      f = f + EXTRACT$(MID$(cmd,2), ANY CHR$(34)+" /")�    END IF�    cmd = LTRIM$(MID$(cmd, len(f)+1))�    IF arg = which THEN�      EXIT DO�    ELSE�      f = ""�    END IF�  LOOP��  FUNCTION = f��END FUNCTION��'----------------------------------------------------------------------------��FUNCTION PbMain() AS LONG��  LOCAL Filename AS STRING�  LOCAL InFile   AS STRING�  LOCAL Buffer   AS STRING�  LOCAL Temp     AS STRING�  LOCAL Spaces   AS LONG�  LOCAL x        AS LONG��  STDOUT "DETAB v1.0 � Strip Leading Tabs from Text Files"�  STDOUT "Copyright (c) 1998 by PowerBASIC, Inc.  All Rights Reserved."�  STDOUT ""��  IF ArgC(COMMAND$) = 0 THEN�    STDOUT "Usage:  DETAB filename [spaces]"�    FUNCTION = 1�    EXIT FUNCTION�  END IF��  Filename = ArgV(1, COMMAND$)�  IF ArgC(COMMAND$) = 2 THEN�    Spaces = VAL( ArgV(2, COMMAND$) )�  ELSE�    Spaces = 2                     'default to two spaces�  END IF��  IF NOT Exist(Filename) THEN�    STDOUT "Error!  " + Filename + " does not exist."�    FUNCTION = 2�    EXIT FUNCTION�  END IF��  Infile = MakeBAK(Filename)    'back up the original file��  OPEN Infile FOR INPUT AS #1�    OPEN Filename FOR OUTPUT AS #2��      WHILE NOT EOF(1)��        LINE INPUT #1, Buffer�        Temp = ""��        FOR x = 1 TO LEN(Buffer)�          IF ASC(Buffer) <> 9 THEN  'if char is not a tab�            EXIT FOR                'then exit the loop�          END IF�          Temp = Temp + SPACE$(Spaces)�          Buffer = MID$(Buffer, 2)�        NEXT x��        PRINT #2, Temp + Buffer�      WEND��    CLOSE #2�  CLOSE #1��  STDOUT "Done!"�END FUNCTION�PowerBASIC, Inc.               TEXT FILE VIEWER FOR PB/CC     ftp.powerbasic.com             06-27-98 (00:00)       PBCC                   205  5647     PBLIST.BAS  '=============================================================================�'�'  Text File Viewer for PowerBASIC Console Compiler�'  Copyright (c) 1995-98 by PowerBASIC, Inc.  All Rights Reserved.�'�'  Supports long filenames and text files of unlimited size.�'�'=============================================================================��$REGISTER NONE�$INCLUDE "WIN32API.INC"�$INCLUDE "SCRNIO.INC"��'============================================================================��FUNCTION Exist(BYVAL Filenam AS STRING) AS LONG��  FUNCTION = LEN(DIR$(Filenam)) > 0��END FUNCTION��'============================================================================��FUNCTION FileDateTime(BYVAL Filenam AS STRING) AS STRING��  LOCAL fd    AS WIN32_FIND_DATA�  LOCAL fh    AS LONG�  LOCAL zText AS ASCIIZ * 256�  LOCAL st    AS SYSTEMTIME�  LOCAL Temp  AS STRING��  zText = Filenam��  ' -- Find the file�  fh = FindFirstFile(zText, fd)�  IF fh = %INVALID_HANDLE_VALUE THEN�    EXIT FUNCTION�  END IF�  FindClose fh��  ' -- Convert the file time from UTC to local time�  FileTimeToLocalFileTime fd.ftLastWriteTime, fd.ftLastWriteTime��  ' -- Convert the file time into a compatible system time�  FileTimeToSystemTime fd.ftLastWriteTime, st��  ' -- Create a date string using the local settings�  GetDateFormat %LOCALE_USER_DEFAULT, %DATE_SHORTDATE, st, BYVAL %NULL, zText, 256�  Temp = zText��  ' -- Create a time string using the local settings�  GetTimeFormat %LOCALE_USER_DEFAULT, %TIME_NOSECONDS, st, BYVAL %NULL, zText, 256��  ' -- Return the file date and time�  FUNCTION = Temp + " " + zText��END FUNCTION��'============================================================================��FUNCTION PbMain() EXPORT AS LONG��  LOCAL Arrows   AS STRING�  LOCAL CurX     AS LONG�  LOCAL CurY     AS LONG�  LOCAL FileDate AS STRING�  LOCAL FileName AS STRING�  LOCAL FileTime AS STRING�  LOCAL I        AS STRING�  LOCAL Last     AS LONG�  LOCAL Percent  AS LONG�  LOCAL Tmp      AS STRING�  LOCAL Y        AS LONG�  LOCAL hConOut  AS LONG�  LOCAL Rect     AS SMALL_RECT�  LOCAL Char     AS CHAR_INFO�  LOCAL Cord     AS COORD��  hConOut         = GETSTDOUT�  CurY            = 1�  CurX            = 1�  Last            = 0�  Arrows          = CHR$(24,25,26,27)�  Char.Ch         = ASC(" ")�  Char.Attributes = 7��  FileName = UCASE$(COMMAND$)��  PRINT "PBLIST v1.00 - Text file viewer for Win32"�  PRINT "Copyright (c) 1995-98 by PowerBASIC, Inc. All Rights Reserved."�  PRINT��  IF LEN(Filename) = 0 THEN�    PRINT "Usage: PBLIST filename"�    PRINT ""�    PRINT "Long filenames are supported."�    EXIT FUNCTION��  ELSEIF INSTR(FileName, ANY "?*") THEN�    PRINT "Error!  Wildcards not supported."�    EXIT FUNCTION��  ELSEIF NOT Exist(FileName) THEN�    PRINT Filename; " not found!"�    EXIT FUNCTION��  ELSE�    FileDate = FileDateTime(Filename)��  END IF��  DIM Text(1:35000) AS STRING   'maximum of 35,000 lines of text��  'Read the text file into memory�  OPEN FileName FOR INPUT AS #1�    WHILE NOT EOF(1)�      INCR Last�      LINE INPUT #1, Text(Last)�      IF Last = 35000 THEN�        EXIT DO�      END IF�    WEND�  CLOSE��  CURSOR OFF�  QPRINT SCREENY, 1, SPACE$(80), &H1F�  QPRINT SCREENY, 2, Filename + " - " + FileDate + "  �", &H1F�  QPRINT SCREENY, 47, " �  " + Arrows + " PgDn PgUp  �  Esc = Exit", &H1F��  DO��    BeginBuffer�      FOR y = 0 TO SCREENY - 2�        Tmp = LEFT$(MID$(Text(CurY + y), CurX, 80) + SPACE$(80), 80)�        QPRINT y + 1, 1, Tmp, &H07�      NEXT y�    EndBuffer��SkipWrite:�    Percent = (CurY * 100) \ (Last - 23)�    IF Percent < 0 THEN�      Percent = 0�    ELSEIF Percent > 100 THEN�      Percent = 100�    END IF�    QPRINT SCREENY, 42, FORMAT$(Percent, "###%"), &H1F��    I = WAITKEY$��    SELECT CASE I�      CASE CHR$(27)                       'ESC�        EXIT DO�      CASE CHR$(0, 72)                    'Up Arrow�        IF CurY > 1 THEN�          DECR CurY�          Rect.xLeft   = 0�          Rect.xTop    = 0�          Rect.xRight  = SCREENX - 1�          Rect.xBottom = SCREENY - 3�          SCROLL UP 1, 1, 1, SCREENY - 1, SCREENX�          QPRINT 1, 1, LEFT$(MID$(Text(CurY), CurX, 80) + SPACE$(80), 80), &H07�          GOTO SkipWrite�        END IF�      CASE CHR$(0, 80)                    'Down Arrow�        IF CurY < Last - 22 THEN�          INCR CurY�          Rect.xLeft   = 0�          Rect.xTop    = 1�          Rect.xRight  = SCREENX - 1�          Rect.xBottom = SCREENY - 2�          SCROLL DOWN 1, 1, 1, SCREENY - 1, SCREENX�          QPRINT SCREENY - 1, 1, LEFT$(MID$(Text(CurY + SCREENY - 2), CurX, 80) + SPACE$(80), 80), &H07�          GOTO SkipWrite�        END IF�      CASE CHR$(0, 75)                    'Left Arrow�        IF CurX > 1 THEN�          CurX = CurX - 4�        END IF�      CASE CHR$(0, 77)                    'Right Arrow�        CurX = CurX + 4�      CASE CHR$(0, 73)                    'PgUp�        CurY = CurY - (SCREENY - 2)�        IF CurY < 1 THEN�          CurY = 1�        END IF�      CASE CHR$(0, 81)                    'PgDn�        IF CurY + 23 <= Last THEN�          CurY = CurY + (SCREENY - 2)�        END IF�      CASE CHR$(0, 71)                    'Home�        CurY = 1�      CASE CHR$(0, 79)                    'End�        CurY = Last - (SCREENY - 3)�        IF CurY < 1 THEN�          CurY = 1�        END IF�    END SELECT��  LOOP��  QPRINT SCREENY, 1, SPACE$(80), &H07�  LOCATE SCREENY - 1, 1�  CURSOR ON, 1��END FUNCTION�PowerBASIC, Inc.               SOURCE CODE FORMATTER FOR PB/CCftp.powerbasic.com             06-27-98 (00:00)       PBCC                   489  14388    PBSF.BAS    '==============================================================================�'�'  Source code formatter for PB/CC�'  Copyright (c) 1998 by PowerBASIC, Inc.  All Rights Reserved.�'�'  Call from DOS prompt as:  PBSF filename.ext�'�'  PBSF renames your source code file to filename.BAK and reads that file�'  as if formats each line of code.  To restore the original source code,�'  just rename it back to its original filename.�'�'==============================================================================��%FALSE = 0�%TRUE  = NOT %FALSE��'-----------------------------------------------------------------------------��GLOBAL IndentStart AS LONG�GLOBAL IndentSize  AS LONG�GLOBAL KeywordCase AS LONG�GLOBAL Cmds        AS STRING��'-----------------------------------------------------------------------------��FUNCTION Exist(BYVAL Filenam AS STRING) AS LONG��  FUNCTION = LEN(DIR$(Filenam)) > 0��END FUNCTION��'-----------------------------------------------------------------------------�' MakeBAK - Rename a file with a .BAK extension and return the new filename�'�' Filename = Name of the file to rename.�'�' Returns:�'   Name of file with .BAK extension.�'�FUNCTION MakeBAK(BYVAL Filename AS STRING) AS STRING��  DIM Bak AS STRING�  DIM Dot AS LONG��  Bak = Filename��  '***  Add BAK extension  ***��  Dot = INSTR(Bak, ".")�  IF Dot = 0 THEN�    Bak = Bak + ".BAK"�  ELSE�    Bak = LEFT$(Bak, Dot) + "BAK"�  END IF��  '***  If .BAK file already exists, kill it  ***��  IF Exist(Bak) THEN�    KILL Bak�  END IF��  '***  Rename file  ***��  NAME Filename AS Bak��  '*** Return the new file name ***��  FUNCTION = Bak��END FUNCTION��'-----------------------------------------------------------------------------�' Parse the next word in a BASIC source code line�'�FUNCTION BasParse( Source AS STRING ) AS STRING��  LOCAL Char AS LONG�  LOCAL x    AS LONG�  LOCAL Temp AS STRING��  Char = ASC(Source)��  SELECT CASE Char�    CASE -1�      FUNCTION = ""�      Source = ""�      EXIT FUNCTION��    CASE 9, 32  'white space�      FOR x = 1 TO LEN(Source)�        Char = ASC(Source, x)�        IF Char <> 9 AND Char <> 32 THEN�          FUNCTION = LEFT$(Source, x)�          Source = MID$(Source, x+1)�          EXIT FUNCTION�        END IF�      NEXT��    CASE 39, 40, 41, 42, 43, 44, 45, 47, 58, 59, 60, 61, 62, 92, 94�      FUNCTION = CHR$(Char)�      IF LEN(Source) > 1 THEN�        Source = LTRIM$(MID$(Source, 2))�      ELSE�        Source = ""�      END IF�      EXIT FUNCTION��    CASE = 34�      FOR x = 2 TO LEN(Source)�        IF MID$(Source, x, 1) = CHR$(34) THEN�          EXIT FOR�        END IF�      NEXT x�      IF x >= LEN(Source) THEN�        FUNCTION = RTRIM$(Source)�        Source = ""�        EXIT FUNCTION�      ELSE�        FUNCTION = RTRIM$(LEFT$(Source, x))�        Source = LTRIM$(MID$(Source, x+1))�        EXIT FUNCTION�      END IF��  END SELECT��  Temp = EXTRACT$(Source, ANY CHR$(32,34,39,40,41,42,43,44,45,47,58,59,60,61,62,92,94))�  FUNCTION = Temp��  IF LEN(Temp) = LEN(Source) THEN�    Source = ""�  ELSE�    Source = LTRIM$(MID$(Source, LEN(Temp) + 1))�  END IF��END FUNCTION��'-----------------------------------------------------------------------------��FUNCTION FormatLine(BYVAL Source AS STRING) AS STRING��  LOCAL Original    AS STRING�  LOCAL Work        AS STRING�  LOCAL TempStart   AS LONG�  LOCAL KeyWord     AS STRING�  LOCAL Tmp         AS LONG�  LOCAL Temp        AS STRING�  LOCAL NewLine     AS STRING�  LOCAL TempLine    AS STRING�  LOCAL LastKeyWord AS STRING��  STATIC InComment AS LONG��  Original = TRIM$(Source, ANY CHR$(9,32))�  Work     = UCASE$(Original)�  TempStart = -1��  IF LEN(Work) = 0 THEN�    EXIT FUNCTION�  END IF��  KeyWord = UCASE$(EXTRACT$(Work, ANY " ,="))��  IF InComment = %TRUE THEN�    FUNCTION = Source�    EXIT FUNCTION��  ELSEIF UCASE$(LEFT$(Work, 5)) = "$IF 0" THEN�    InComment = %TRUE�    TempStart = 0�    GOTO ExtendLine��  ELSEIF KeyWord = "$ENDIF" THEN�    InComment = %FALSE�    TempStart = 0�    GOTO ExtendLine��  ELSEIF (ASC(Work) = 39) OR (UCASE$(LEFT$(Work, 3)) = "REM") THEN�    FUNCTION  = Source�    EXIT FUNCTION��  ELSEIF (ASC(Work) = 33) OR (UCASE$(LEFT$(Work, 3)) = "ASM") THEN�    FUNCTION  = Source                     'don't mess with ASM lines�    EXIT FUNCTION��  ELSEIF KeyWord = "DATA" THEN             'don't mess with DATA statements�    FUNCTION  = Source�    EXIT FUNCTION��  ELSEIF (ASC(Work) = 36) THEN             'meta-statement�    TempStart = 0�    GOTO ExtendLine��  END IF��  IF KeyWord = "IF" THEN�    Tmp = INSTR(UCASE$(Work), "THEN")�    IF (Tmp + 3) = LEN(Work) THEN�      TempStart = IndentStart�      IndentStart = IndentStart + IndentSize�      GOTO ExtendLine�    END IF�    Temp = LTRIM$(MID$(Work, Tmp+4))�    IF ASC(Temp) = 39 THEN�      TempStart = IndentStart�      IndentStart = IndentStart + IndentSize�      GOTO ExtendLine�    END IF�    GOTO ExtendLine�  END IF��  IF (KeyWord = "ELSE") OR (KeyWord = "ELSEIF") THEN�    Tmp = IndentStart - IndentSize�    IF Tmp< 0 THEN�      Tmp = 0�    END IF�    TempStart = Tmp�    GOTO ExtendLine�  END IF��  IF KeyWord = "END" THEN�    Temp = UCASE$(Work)�    IF (INSTR(Temp, "IF") = 5) OR (INSTR(Temp, "TYPE") = 5) THEN�      IndentStart = IndentStart - IndentSize�      GOTO ExtendLine�    ELSEIF INSTR(Temp, "SUB") = 5 THEN�      IndentStart = 0�    ELSEIF INSTR(Temp, "FUNCTION") = 5 THEN�      IndentStart = 0�    ELSEIF INSTR(Temp, "SELECT") = 5 THEN�      IndentStart = IndentStart - IndentSize�      IndentStart = IndentStart - IndentSize�      GOTO ExtendLine�    END IF�  END IF��  IF KeyWord = "SUB" THEN�    TempStart = 0�    IndentStart = IndentSize�    GOTO ExtendLine�  END IF��  IF (KeyWord = "FUNCTION") AND (INSTR(Work, "=") = 0) THEN�    TempStart = 0�    IndentStart = IndentSize�    GOTO ExtendLine�  END IF��  IF KeyWord = "TYPE" THEN�    TempStart = IndentStart�    IndentStart = IndentStart + IndentSize�    GOTO ExtendLine�  END IF��  IF KeyWord = "SELECT" THEN�    TempStart = IndentStart�    IndentStart = IndentStart + IndentSize�    IndentStart = IndentStart + IndentSize�    GOTO ExtendLine�  END IF��  IF KeyWord = "CASE" THEN�    Tmp = IndentStart - IndentSize�    IF Tmp< 0 THEN�      Tmp = 0�    END IF�    TempStart = Tmp�    GOTO ExtendLine�  END IF��  IF KeyWord = "FOR" THEN�    IF INSTR(Work, "NEXT") = 0 THEN�      TempStart = IndentStart�      IndentStart = IndentStart + IndentSize�      GOTO ExtendLine�    END IF��  ELSEIF KeyWord = "NEXT" THEN�    IndentStart = IndentStart - IndentSize�    GOTO ExtendLine��  END IF��  IF KeyWord = "WHILE" THEN�    IF INSTR(Work, "WEND") = 0 THEN�      TempStart = IndentStart�      IndentStart = IndentStart + IndentSize�      GOTO ExtendLine�    END IF��  ELSEIF KeyWord = "WEND" THEN�    IndentStart = IndentStart - IndentSize�    GOTO ExtendLine��  END IF��  IF KeyWord = "DO" THEN�    IF INSTR(Work, "LOOP") = 0 THEN�      TempStart = IndentStart�      IndentStart = IndentStart + IndentSize�      GOTO ExtendLine�    END IF��  ELSEIF KeyWord = "LOOP" THEN�    IndentStart = IndentStart - IndentSize�    GOTO ExtendLine��  END IF��ExtendLine:�  IF TempStart = -1 THEN�    NewLine = SPACE$(IndentStart)�  ELSE�    NewLine = SPACE$(TempStart)�  END IF��  TempLine = Original�  WHILE LEN(TempLine)�    KeyWord = BasParse( TempLine )��    IF KeyWordCase > 0 THEN�      IF INSTR(UCASE$(Cmds), UCASE$(" "+KeyWord+" ")) > 0 THEN�        IF     KeyWordCase = 1 THEN               ' upper case�          KeyWord = UCASE$(KeyWord)�        ELSEIF KeyWordCase = 2 THEN               ' lower case�          KeyWord = LCASE$(KeyWord)�        END IF�      END IF�    END IF��    IF KeyWord = "'" THEN�      NewLine$ = NewLine$ + KeyWord + TempLine$�      EXIT DO�    ELSEIF (KeyWord = ",") OR (KeyWord = ";") OR (KeyWord = ":") THEN�      NewLine$ = RTRIM$(NewLine$) + KeyWord + " "�    ELSEIF KeyWord = "-" THEN�      IF LastKeyWord = "(" THEN�        NewLine$ = NewLine$ + KeyWord + BasParse$( TempLine$ ) + " "�      ELSEIF (INSTR("+=/\<>*^-", LastKeyWord)) AND (INSTR(TempLine$, ANY "0123456789") < 0) THEN�        NewLine$ = NewLine$ + KeyWord + BasParse$( TempLine$ ) + " "�      ELSE�        NewLine$ = NewLine$ + KeyWord + " "�      END IF�    ELSEIF KeyWord = "(" THEN�      IF (INSTR("-+/\*^<>=", LastKeyWord)>0) OR (INSTR("ELSEIFANDXORMOD", LastKeyWord)>0) THEN�        NewLine$ = NewLine$ + KeyWord + " "�      ELSE�        NewLine$ = RTRIM$(NewLine$) + KeyWord + " "�      END IF�    ELSEIF KeyWord = ")" THEN�      IF INSTR("()", LastKeyWord) THEN�        NewLine$ = RTRIM$(NewLine$) + KeyWord + " "�      ELSEIF ASC(TempLine$) = 46 THEN�        NewLine$ = NewLine$ + KeyWord�      ELSE�        NewLine$ = NewLine$ + KeyWord + " "�      END IF�    ELSE�      NewLine$ = NewLine$ + KeyWord + " "�    END IF�    LastKeyWord = UCASE$(KeyWord)�  WEND��  FormatLine$ = RTRIM$(NewLine$)��END FUNCTION��'-----------------------------------------------------------------------------��FUNCTION PbMain() AS LONG��  LOCAL Temp      AS STRING�  LOCAL Percent   AS LONG�  LOCAL ErCode    AS LONG�  LOCAL InFile    AS STRING�  LOCAL OutFile   AS STRING�  LOCAL Length    AS LONG�  LOCAL BytesRead AS LONG��' PowerBASIC metastatements��  Cmds = ""�  Cmds = Cmds + " $ALIAS $CODE $COM $COM1 $COM2 $COMPILE $CPU $DEBUG $DIM"�  Cmds = Cmds + " $DYNAMIC $ELSE $ENDIF $ERROR $EVENT $FLOAT $HUGE $IF"�  Cmds = Cmds + " $INCLUDE $INLINE $LIB $LINK $LIST $OPTIMIZE $OPTION $REGISTER $SEGMENT"�  Cmds = Cmds + " $SOUND $STACK $STATIC $STRING"��' PowerBASIC supported statements and functions��  Cmds = Cmds + " ABS ABSOLUTE ACCESS ALIAS ALL AND ANY APPEND ARRAY AS ASC ASCEND ASCII ASCIIZ ASM AT ATN ATTRIB"�  Cmds = Cmds + " BASE BCD BEEP BIN$ BINARY BIT BITS BLOAD BSAVE BYTE BYVAL BUTTONS"�  Cmds = Cmds + " CALL CASE CBCD CBYT CCUR CDBL CDWD CEIL CEXT CFIX CHAIN CHDIR CHDRIVE CHR$ CINT CIRCLE CLEAR CLNG CLOSE CLS CODEPTR CODESEG COLLATE COLOR COM COMMAND$ COMMON CONSIN CONSOUT"�  Cmds = Cmds + " COS CQUD CSNG CSRLIN CURDIR$ CURSOR CURSORX CURSORY CVB CVBYT CVD CVDWD CVE CVF CVI CVL CVMD CVMS CVQ CVS CVWRD CWRD"�  Cmds = Cmds + " DATA DATE$ DECLARE DECR DEF DEFBCD DEFBYT DEFCUR DEFDBL DEFDWD DEFEXT DEFFIX DEFFLX DEFINT DEFLNG DEFQUD DEFSNG DEFSTR DEFWRD DELAY DELETE DESCEND DIM DIR$ DO DOUBLE DOWN DRAW DWORD DYNAMIC"�  Cmds = Cmds + " ELSE ELSEIF EMS END ENDMEM ENVIRON ENVIRON$ EOF EQV ERADR"�  Cmds = Cmds + " ERASE ERRCLEAR ERDEV ERDEV$ ERL ERR ERROR ERRTEST EVENT EXE EXECUTE"�  Cmds = Cmds + " EXIT EXP EXP10 EXP2 EXPORT EXTERNAL EXTRACT$"�  Cmds = Cmds + " FAR FIELD FILEATTR FILES FIX FIXDIGITS FLEXCHR$ FLUSH FORMAT$ FORMFEED FN FOR FRAC FRE FREEFILE FROM FUNCTION"�  Cmds = Cmds + " GET GET$ GETSTDERR GETSTDIN GETSTDOUT GLOBAL GO GOSUB GOTO"�  Cmds = Cmds + " HEX"�  Cmds = Cmds + " IF IMP IN INCR INKEY$ INLINE INP INPUT INPUT$ INSERT INSHIFT INSTAT INSTR INT INTEGER INTERRUPT IOCTL$ IS ISFALSE ISTRUE ITERATE"�  Cmds = Cmds + " KEY KILL"�  Cmds = Cmds + " LCASE$ LEFT LEFT$ LEN LET LINE LOC LOCAL LOCATE LOCK LOF LOG LOG10 LOG2 LONG LOOP LPOS LPRINT LSET LTRIM$"�  Cmds = Cmds + " MAKDWD MAKLNG MAKPTR MAP MAX MEMPACK MEMSET MID$ MIN MKB$ MKBYT$ MKD$ MKDIR MKDWD$ MKE$ MKF$ MKI$ MKL$ MKMD$ MKMS$ MKQ$ MKS$ MKWRD$ MOD MOUSE MOUSEBUTTONS MOUSESTAT MOUSEX MOUSEY MTIMER MULTIPLEX"�  Cmds = Cmds + " NAME NEXT NOT"�  Cmds = Cmds + " OCT$ OFF ON OPEN OPTION OR OUT"�  Cmds = Cmds + " PAGE PAINT PALETTE PARSE$ PARSECOUNT PCOPY PEEK PEEK$ PEEKI PEEKL PEN PLAY PMAP POINT POKE POKE$ POKEI POKEL POPUP POS PRESET PRINT PRIVATE PSET PTR PUBLIC PUT"�  Cmds = Cmds + " QUIET"�  Cmds = Cmds + " RANDOM RANDOMIZE READ REDIM REG REM REMOVE REPEAT REPLACE RESET RESTORE RESUME RETURN RIGHT RIGHT$ RMDIR RND ROTATE ROUND RSET RTRIM$ RUN"�  Cmds = Cmds + " SAVE SCAN SCREEN SCREENATTR SCREENX SCREENY SCROLL SEEK SEG SELECT SETMEM SGN SHARED SHELL SHIFT SIN SINGLE SLEEP SORT SOUND SPACE$ SPC SQR STATIC STDERR STDIN STDOUT STEP STICK STOP STR$ STDEOF STRIG"�  Cmds = Cmds + " STRING STRING$ STRPTR STRSEG STUFF SUB SWAP SYSTEM"�  Cmds = Cmds + " TAB TAGARRAY TALLY TAN THEN TIME$ TIMER TO TRIM$ TROFF TRON TYPE"�  Cmds = Cmds + " UBOUND UCASE UCASE$ UEVENT UNION UNIT UNLOCK UNTIL UP USING USING$ USR"�  Cmds = Cmds + " VAL VARPTR VARPTR VARSEG VERIFY VIEW VIRTUAL"�  Cmds = Cmds + " WAIT WAITKEY$ WAITSTAT WEND WHILE WIDTH WINDOW WITH WORD WRITE"�  Cmds = Cmds + " XOR"��  IndentStart = 0           'starting column for indenting�  IndentSize  = 2           'number of spaces to indent�  KeywordCase = 0           'don't change keyword case�              ' 1           'convert keywords to upper case�              ' 2           'convert keywords to lower case��  ON ERROR GOTO ErrorHandler��  CURSOR OFF��  PRINT "PB/CC Source Code Formatter v1.00"�  PRINT "Copyright (c) 1998 PowerBASIC, Inc.  All Rights Reserved."�  PRINT��  OutFile  = UCASE$(COMMAND$)��'***  Check for filename on command line  ***�  IF LEN(OutFile) = 0 THEN�    PRINT "Usage:  PBSF filename.ext"�    EXIT FUNCTION�  END IF��'***  Assume a .BAS extension  ***�  IF INSTR(OutFile, ".") = 0 THEN�    OutFile = OutFile + ".BAS"�  END IF��'***  Make sure it exists  ***�  IF NOT Exist(OutFile) THEN�    PRINT "File Not Found."�    BEEP�    EXIT FUNCTION�  END IF��'***  Backup original file  ***�  Infile = MakeBAK(Outfile)��'***  Open file and process it  ***�  OPEN InFile FOR INPUT AS #1�    OPEN OutFile FOR OUTPUT AS #2�      Length = LOF(1)�      WHILE NOT EOF(1)�        LINE INPUT# 1, Temp�        BytesRead = BytesRead + LEN(Temp) + 2�        Percent = (BytesRead * 100) \ Length�        LOCATE ,1�        PRINT FORMAT$(Percent);"% Done";�        Temp = FormatLine(Temp)�        PRINT# 2, Temp�      WEND�    CLOSE 2�  CLOSE 1��  PRINT�  CURSOR ON�  EXIT FUNCTION��ErrorHandler:�  BEEP��  ErCode  = ERR��  RESUME DisplayCode��DisplayCode:��  PRINT ""�  PRINT "Error"; ErCode�  PRINT ""�  PRINT "Your original source code is in "; Infile ; "."�  CURSOR ON��END FUNCTION�PowerBASIC, Inc.               COMMAND LINE .WAV FILE PLAYER  ftp.powerbasic.com             06-27-98 (00:00)       PBCC                   42   941      WAV.BAS     '==============================================================================�'�' WAV.EXE - Command line .WAV file player�' Copyright (c) 1998 by PowerBASIC, Inc.  All Rights Reserved.�'�'==============================================================================��$INCLUDE "WIN32API.INC"��FUNCTION PbMain() AS LONG��  DIM wav AS ASCIIZ * 256��  wav = COMMAND$��  STDOUT "WAV.EXE v1.0 - Command line .WAV file player"�  STDOUT "Copyright (c) 1998 by PowerBASIC, Inc."�  STDOUT ""��  IF LEN(wav) = 0 THEN�    STDOUT "Usage:  WAV filename.wav��    SndPlaySound BYVAL %NULL, %SND_SYNC  'stop anything currently playing��    FUNCTION = 1�    EXIT FUNCTION�  END IF��  IF INSTR(wav, ".") = 0 THEN�    wav = wav + ".WAV"�  END IF��  IF LEN(DIR$(wav)) THEN�    STDOUT "Playing " & wav�    SndPlaySound wav, %SND_SYNC�  ELSE�    STDOUT "File not found: " & wav�    FUNCTION = 1�  END IF��END FUNCTION��PowerBASIC, Inc.               SORT UTILITY FOR PB/CC         ftp.powerbasic.com             06-27-98 (00:00)       PBCC                   32   868      PBSORT.BAS  '==============================================================================�'�'  Sort utility for PowerBASIC Console Compiler�'  Copyright (c) 1998 by PowerBASIC, Inc. All Rights Reserved.�'�'  Like the DOS SORT.EXE utility, this program accepts text via STDIN,�'  sorts it (case insensitive) and writes the sorted text to STDOUT.�'�'  As a Win32 console application it supports long filenames and text�'  files are large as virtual memory (2 gigabytes maximum).�'�'==============================================================================��FUNCTION PbMain() AS LONG��  LOCAL count AS LONG�  LOCAL x     AS LONG��  DIM text(1 to 100000) AS STRING��  WHILE NOT STDEOF�    INCR count�    STDIN LINE text(count)�  WEND��  ARRAY SORT text(1) FOR count, COLLATE UCASE��  FOR x = 1 TO count�    STDOUT text(x)�  NEXT x��END FUNCTION�PowerBASIC, Inc.               SIMPLE GRAPHICS IN WINDOWS     ftp.powerbasic.com             06-27-98 (00:00)       PBCC                   112 7325     PBGR32.BAS  'For use with PowerBASIC Console Compiler�DEFINT A-Z:SHARED K,S,B&,Z&:V1 'Created by PostIt! 7.2�SUB V1:OPEN "O",1,"PBGR32.ZIP",4^6:Z&=5192:?STRING$(50,177);�U"%up()%9%%%R-%bE0LI5v1fy,(7%%8-%%%/%%%%lw%yjxy%SgfxK&z<>][]5wV-x�U"x0)S=*ypNfIoi-JvvR5E^q[2n)ZEaM1X(&:x#]Rs.pcdHTBN;d?),l/o8MF5m6j�U"CH[Vlg$nsVBJLdO4=r.i#2g+>C8<>nV>FD4':jX3)dFqfplU0m$&6%44GvtLD0L�U"S&gC5#K20N;8Pt+&B1j&BO:?0]1]1>M=DMu.B['Wi+HQuK9,r$4]<&e+T<A]rn[�U"A8gP4G<rI&8'0baL(0%%0:j/wu+^*[GpuB'vWqr]QZ-F%rf31PEAv\=[r_S_/=N�U"J&P_K^wpslDYW%m[VO2d)c#mnU3tMKDnr2%K]1#)&c'xWe7*^vTr]imPp0$EL>n�U"0e::wX?g$Y-'BRt):h)lr^G5HG2]P48a5ttLO.\NYHeWB1Amy*UQAVQRY6oe#Il�U"*fm2Z0iS,Gb^QUVmo)6ng-=SGx0Qm):0_/p)y=.f9d&ZC)I1X\a6]aH?;s%P,/k�U"=1s,fb:fWMI&FXZrPF$YfqX=NMjpG0P3;&M]2X%Iu_C.VRky;lK;4c+A\byEYRl�U"SI:mbZH1BscZF>I)8F<b6m#0[E*%t+JDk4M/[7as^cct,ZF8nB=,Zj'26'KV#id�U"\K%bpQMK&)8A)arKwJdtsiH93UZ&<5]1,r6'c8(Aix\o9N('o+gFNJ-kz#^/uRU�U"H71e=>KfW]?$.CQeHZQ(\TS;sY^eoxnlIn5CoX\ssf[#e*gC'QMk_)/1#l?INHO�U"8qpF>l#2Ec3)y<qZgZNb;_axO4V\PM,v]Q27Md^*4]0;^dO'aTW$i(NV-_djqFa�U"c-BlWA(LM9gN5mtg-ms2ed^&5J,AZf9,mO4;CqqzwiU,g)Bm%NPKgp&^0VS4^4A�U"Kr&=dDfy(D3s,\a-ATJ%k7)q.L)]f(WTW1pqfd1+A;,6gTor=.$LvlH//qim3PV�U"Ld&y=%tm>R=n'noKV+wV-A*ApRD<29gWn+/r&lstNG(jiWPTDy.NT4?\\<WF_NX�U"_Q+qUuVQbPb<kGElS8X>[A2+AST$aws*Ciuq>THAt]U/-2Muk>ts\ZnXw^C1SKR�U"_x)7V96C&hZA4.8AH%moR;.B\J=OAtrJqXHs5/Z9GDhjGHZ)it056r%,up(%)9%�U"%%%-%Q,FLIL(W0H:%5%%%%G%%/%%%%u%glwX%WSiqFqf^NAGxze%\nxo+N-e(C1�U"qkvc4T:eT/nlzT-YF^KKDPUYu-^&LV_SuAunr-_o]E:W-2<RAdf;#W>#7Pe,>vs�U"*n2Br$:DHH>^[Y4^5FlMR:uPHZVkfW_Dpmjof^h60m,d:kFu285>_M^lpWBgQ2$�U"mBZg28-,e%qL%wgm/'BIAl^mQ-B+m7$jL%-kK^IZq4ul&4[O7T*FcfSzP]e2NZB�U"$y[Giv9d+7R=Q5>C/_rXrHr%(>EPF%[n/Vr]^KGDb8dm(G$;K\u('CdJ%Ev4-c(�U"%NrqE(gg*YQgL(at#k6Nn((rwQ0,mag^sd8+/.9DGbdUaRL.8f_7Da^v3gEYMPd�U"5\(7%X??#FIJ'5b$Aw+s]p6J<lr5G\$XQPZkK-uxv9$&jI5mO?9k>9Z0s'idP^0�U"9BSCxFsYX$CdvdXf=Uj]<l^.pPg<b.hYG1DSFX8QDLO0vOWbnT_Pi_9SEKSVI=$�U"L9QX;2\lZxQo4--N3.JUUdA5_dsH)peQ32;La^'LGZT#HmaLbn-]pQHU1ta49wB�U"d9g)p-v*$7#F0fcGsFe.aVH:3OnlGYwK/=:^LJvoX56163YAbaIa8GH[;>+C]\x�U";[[>nEfSj*4YE38)lT-9Fi*[jpiCU]m\i1,X^X2gHW%*eh_Dzb2A?c<-i9TB2A?�U"3<%PAZH+5GGwU/Iri(8SP+LNA*?Z>iEtdfTe=.2vgq<WL?'EDw[U6^Rs>p<rXR$�U"6]Asgbg4rLC-pdYjW2;c.yg]1VzP/M,SoJq:6Js#>],LDcJ_YoJx1;poFNeHGoO�U"=L#bRK^0YeAseRJv)AhUiS)IlnuVpTeK]S,Vb0Y9IE&DKW$*_P?H%i$5l%5JE(;�U">[*[q4q.6VEoM&MUV8:4kEIG;]*ZgrdXEG0Ru:K8_Bf+#2e?*859d]SL0IdfkhO�U"KG%IA,pI'u9.yyv641fTH5c):%6hd;)b\k.O&%hr+Q.qa;5_IHD2oLlSO3H*;/=�U";:M?.L#\N/Xs53+d.$d/H]Vjnj\f;_vkbg\Z;;]YY8,=ks%BIGj?WR*_+NnbsAR�U"lHGlxur88h)XBAJon=R%Lv)5VsA3mXp((h.Bbkw_a]S*?s:5DgJh1C+\n*.Wsh5�U";OmS.(fbF&iJf6wXa<WJ*<0hdkh^*/g%9[7PA?[$5'H-fDO<FpxYM3#XcThoFXs�U"p>S-91qsbH>fl#V^o1c:6#k6V#xX&BU79vpk#]tMElP,bV9Bj<e3PS<WbRV'r5)�U"wouA-Ji02d'#s6O&6GCyXp;mAu-TR=e\r1W,BA5X6-=0ol]sr>fqeUViK'Uu,7K�U"pooX8$*NsX]vdLuz$THi%=\cuca3_^.11th]\k]=oF8s93N1k)r+Z][NB9ESKCf�U".v)Uqu/V#05L:B0SH,hc=-8;^hT^>XSRYFm]J6j'V+7^fCmZ9hVjH_,?IMxa3Se�U"hy:?Rl+V,^owVb7SWc?Fok=K8&-X(IkRk_HfhbVUsD,N:HMl?G8o9lOfxV\i2I-�U"5MAe$:^=wivTgFUjd+b1O4[SYfwj0VPl$K?pOUG+O3pZ3::Q5P$/hnPg*cEW]a-�U"[reu>1UpY<srv#<i=[U;UI\^77P:Ob&go-P\gHEK[A_g)[YtI#4]O1$_;8EQw0_�U"DVa+2kI46n8wUD06?6DxqrW]$#(dhu6VIF$3J\?De12'$xu[4N$%GNr5iYMFN0w�U"&r)Skbm5Pk_V>\[?L%ln1a%c51lL5$skLGa8JuQ^#jAswBajp.Co]*2rFa<X+Mc�U"]jR4Y=0JZL&ODU,MHQ_DekZuade5g2kxieVEop>o#E<>k[<b41JaTJ2VKuN_ZE4�U"ze4Ad;\RYI94&,<^/penLz_D9_OM>bUX(ECqCpUUI+C=B4vT#)_q#+W:\>;G2xC�U"4q&reb%];C;554Rz\\B&_:Tq8$jaNWrEP_Pxo(>ELu)7bd_/ymd>N[8^M]0Ug<d�U"CnAP(.A6LM&E8=NvIaoRZRNki:R6Tq9SHs9p::DRmcBO:qY&.:2aa3^b1sljr5A�U"8V>YVs7+v9?t9,b$s$)()z58BKv19V=IZmh1w9iL%sI(NMmGSGLKj\;mO?]#U$D�U"m1FsVUv8G6eb>=/Aa>&E?-4.XXJA$uzm)7#3.Pj0*Atc>+Yr;1r?T2bkPG(-J6+�U"sBHE2N2=n7:MJH.4nJwQ3Ee1_H?;8#\$WN?2cCVDKGxAXt-S7k[7m<cMNZx.-sq�U";N;yPttq%OKLu%:,b<*_Er.do3NCitz.B4UMYFdcAG.9nH9v#e&<(n+,X(dVp#u�U"Emi,0%-Q].Wa7M%U6G'[wUm_=S5%'^9B]6<b3?)#$0AKvD:gfmi'SsHhh>9V;<Y�U"3s_,7tmB[l\mZe_hXz5+?1R&yqNw7%o_AB>E\?]9L>5'lDo8AaLcY-N$&._qG:o�U")'o#1l[3MX-JHGNh(bRHzmtujNul:$gfhx,bCX<<Yfs>t+SC;]xsl9c(2Dq$NEI�U"+xZNK+n)w,3eRkFsj/7#aJ&^Damn&Ph<Tm:HV^%/.&s/gtkPMp<p-g<7;V2#4Bt�U"n,D0_7?R+tw+m;Ubb?.Z&;z7'.(QJE21w%ey&)_xZu,m/Kd$p6DL$W#-^^KV9op�U"VUE#mNax]Z+;RSy^OK]PTdA)KRPrcO7Nf2CLKz:bgk#N'cgO/z'oOH:R(j0UfbX�U"$],tArd3:VBeaHh>i'5F<R8>3e+a*ZBW=q^*Bgc>(APA9-17>lE&L>=4j-1<GA&�U"%93aRPtPoPjWn&GwT)Pb3E.AiQC4-iUx/kl3c*/E4aa4DY:[t_aS5IM&>9Hcio0�U"p^:\5brA'&9Dg2/Yc:4V]H'dc#G'jrUegfOgZpTU7Z,:rqqHef\To_W5g2\NrCe�U"LTRWU%N7O$%JCKw8KmNIwn$v8t^THUTdqTNjFbFH\P#uG#s:$0llk<bcO^>&4'u�U"94V]Tc,\]0wNmNK0UMotz7dl/XZ-:+ovs+5PEU3+l_,862PTZ<qsVa:J0+$:Rre�U"U&o'4QQv'+PTFqm43hoN7r\4BRMrE-]o6MpL/3ZuU$9V$]KYJJmS(pPj\I.)g#p�U"h67,jH=%CP^[DB<8Rk(xPdgAF2pNMg;t36%_ueW7'1\z,:\OI%<YrF;%.UX''y>�U"Dm(g7^2mEHtCi-0/?%071-<>;o%XU0i$OXon2T'jvYR)K5\Z.SUo^r56bznL8^O�U"o/TLRwus]u,?\=JLFtp4I&MB^rg+n2(^8-YA7$1ignL(5gs2De<Ay)sctS7o^10�U"\0ns2vGu2b^MeYNBW]HcFCvpB-Ca%XPe/Fex8S]PU3iB[2?EB7&:cU_%Fh1H9]x�U"ckqI;._lC8etRr8NEKH)lm1cVa0g/Ga#PHSB3H*Sc?cYVkwDG-HxSZg+,UwFL5f�U"2jE%Dl;PHpi$Y_9B2+hPVQ?[1iCqd6^lXp^K2SAJg[EFa-k<xYpEmg4ED=<g*Dk�U"01Ah/A?m(5ePpWfw?Xf(':DTj+LY?bdY%b=5<wZGqN?jN2)L8EKtp9N.IatB3ox�U"=>(%'u\&yyUI+u--gv,-6MwsI43m9=uEWj0,UW.Cm*G_D]*Z2EG\K]J<OWUpSSA�U"W*jj;PeRjPMyRsiQ;CgAd5^e1ptk;-tBr^^dOmL8$^MdsiKenvxj*JY4;QDF?qA�U"46#*aq-jj*GWhOK6rZj4V.Jq;'<,#clN+HVKWFa$Hh4IQXWqV'g9]<q=u;LCY<:�U"pW]m$RxoLqf?EJI<k)9$Wgs_?Io^'<,ITQV-RFet'7Lh27VBji)wdP#t6X/qcjA�U"KnsP<d9/jkw\8s5>A6Kn3?9V(%T%p+&O&)^&M/)+4Y5eaAY]9[L%hA(4Ay%1KO)�U"%#<%*_(%GxAnr(Cva%VGw:^[pCcmv.ucxI*i8^%(%052?C0YpOy4]b6%9U&)%8o�U"=9'7u0Y'7-'u98/T9f;OG2Efta[j&n%NES2S9.%'9&y+&M&Yj&-'xWeV*MXM,Mf�U"TRPNy:aZF+W4p.EkxNe=q9;O+E^Dn;Q2<)jZ%<gb9%7,T15A&]0vSn#<*oTnQ2d�U"ipM?pKZHPb0;7U*SPfvS>I<6m+$*Z>N1;%:4\\H>+%'U<3ZMfJL=XxQ\#(,$i;K�U"4NBo].:iTN5MFh=e*s\DIR&N,zTt^SwEUy(h4GT#/Y,+_rR(F]_1vOe/5=Ta'7I�U"YF/ti<GbvAcdXmTTOOvmOL]U?>glQOPSRgWOuXSG0Tt'dk]7WDwqnb=CDR=YmIQ�U"&2ka#UK0T42)iFUN;ujQgDZg2Qyu5W.oA7?OM\uM-2v-Ng,*rROlgI)'^TQ;&2K�U"Tbed,LZm3>-=J[U1OX286xE?,+jC]4+];F='GZG7+1^26'MXbmi2<=8.elb)r+O�U"XAIg?Q-fCRy;*Hcd9ui2d5Pca(b8fWrM%W78U;d<i1\),xeMt)l<6XO1Vn^wfu7�U"UgV6NiH,u(ES-DLx=njYAP%:_P?gUlclHT^gw,?Ln,OnGX9kw,(T*TNqOBcuX]W�U"YlnTlYYtJJSC]l5sN\)>so;d&'f9K0_LQ=^OJ1mf\PZu$=^;>-e,+XQk+.H*8(_�U"q.]$L&Pc8'3;)DP1qiDL--Hf*>?WRz=Jr9;Ov#blYLI7QN>;t?3EZaE5[>Hakg/�U"F,Fc6.MIw2u7j4?6c\73n;7?^E86)l*w_4)SYQufSa[PWif3+CRZ<i4<Z1ZS8_O�U";50ep(eTD*aVix*,iavYTY>N^Xh\HBc(Bg*MTH/>%E2OIOKj%p1;/.Qsid+D2]]�U"urmUME;du1J4dpqP3'%XZT%']*^U(?*NMgM8z+YXi4<)Olw.u+QqH+>k]D4f_dk�U"xbzutl/>T7R>G/YgB:Az$M9x9j1OuIqNnFyv.yTw=TNNN;9nBcD/z<wzNcT9rHS�U"(csN7om-C]vU'd=PK%ui.;p[0dSElKud_S-r.52lu(8?LeJal&r\_OzFji'pY<Z�U"q.8gMr_7l-g_<XOu%&MOk7P9V?St.4e7\80n7$.-ro6S6<Sv.,W-V.#9fNf,WSB�U"SMofD-Xe7xCbu3b3R03$C^i3JCr:_\'yr0(p%<gHVdrb-LnubGaGoccNnrdub,r�U"nBn2KsaL$rWw(KcTn4cc0bDNchMd'SNwx[Wwnn[9wRv><v_w#Tv9<CGRJu=&wVQ�U"\T%WU63Q/7Z/;W;V.I162J&2bY&59Z;&d;Z:WrYKZfhO-6Wi7jhB[L1Z_YF;HpR�U"M?i+mBxJ3(dkS<rs]4LJ+XF-JH<bi-w:JgpZM4cafw5m)Pj\,0wb*ST*OQfs'F:�U"R(*?Q%J*r*Tp<u_X8q#t'x&up%&'9%%9%%%R-%bE0LI5v1fy,(7%%8-%%%/%%%%�U"%%%%%&%%E%%%%%%%%%lwyj%xySg%fxup%&'9%%9%%%#-%QF'LILW&0H:5%%%%G%�U"%%/%%%%%%%%%%%%E%%%&T(%%%uglw%XWSi%qqup%*+%%%%%'%.'%?%7%%;8%%%%�U"%�END SUB�CLOSE:IF S=153AND B&=Z&THEN?" :) Ok!"ELSE?" :( Bad!�SUB U(A$):FOR A=1TO LEN(A$):C=ASC(MID$(A$,A))-37:IF C<0THEN C=91+C*32�IF K<4THEN K=C+243ELSE?#1,CHR$(C+(K MOD 3)*86);:K=K\3:B&=B&+1�S=(S+C)AND 255:NEXT:LOCATE,1:?STRING$(B&*50\Z&,219);:END SUB�Dave Navarro, Jr.              GDI TEST CODE                  dave@powerbasic.com            06-27-98 (00:00)       PBCC                   219  5714     GDCC.BAS    '�' GDI.BAS test code for PB/CC 1.0�' by Dave Navarro, Jr. (dave@powerbasic.com)�'�%CCWIN = 1��$INCLUDE "WIN32API.INC"  'you must remove the $IF %DEF() lines from WIN32API.INC��DEFSNG A-Z��FUNCTION FF(x AS SINGLE, y AS SINGLE)�  GLOBAL W AS SINGLE�  FUNCTION = 14 * EXP(-.04*W)*COS(.15*W)�END FUNCTION��SUB PLOT(BYVAL hWnd AS LONG)��  LOCAL LpPaint   AS PaintStruct�  LOCAL hDC       AS LONG�  LOCAL hMemDC    AS LONG�  LOCAL hBmp      AS LONG�  LOCAL hBrush    AS LONG�  LOCAL hPen      AS LONG�  LOCAL WinX      AS LONG�  LOCAL WinY      AS LONG�  LOCAL r         AS RECT�  LOCAL i         AS LONG�  LOCAL FL        AS LONG�  LOCAL yOfs      AS LONG��  STATIC PHI AS SINGLE��  GetClientRect hWnd, r�  WinX = r.nRight - r.nLeft�  WinY = r.nBottom - r.nTop��  hDC = BeginPaint(hWnd, LpPaint)�  hMemDC = CreateCompatibleDC(hDC)�  hBmp = CreateCompatibleBitmap(hDC, WinX, WinY)��  SelectObject hMemDC, hBmp��  hBrush = CreateSolidBrush(%BLACK)�  FillRect hMemDC, r, hBrush�  DeleteObject hBrush��  yOfs = WinY * .3��  hPen = CreatePen(%PS_SOLID, 2, %GREEN)�  SelectObject hMemDC, hPen��  RHO = 300 - ((WinX / 800) * 300)�  D = 2000��  THETA = .1�  S1 = SIN(THETA)�  C1 = COS(THETA)��  IF PHI THEN�    PHI = PHI+0.1�  ELSE�    PHI = 1.3�  END IF�  S2 = SIN(PHI)�  C2 = COS(PHI)��  DIM YMIN(0 to WinX), YMAX(0 to WinX)�  FOR I = 0 TO WinX : YMIN(I) = WinY \ 2 : NEXT I��  FOR X = 12 TO -12 STEP -.5�    FL = 0�    FOR Y = -12 TO 12 STEP .2�      W = X*X + Y*Y�      Z = FF(X, Y)��      XE = -X*S1 + Y*C1�      YE = -X*C1*C2 - Y*S1*C2 + Z*S2�      ZE = -X*S2*C1 - Y*S1*S2 - Z*S2 + RHO�      SX = D*XE/ZE + (WinX \ 2)�      SY = (-5*D*YE/ZE/12) + 120��      IF SX < 0 OR SX > WinX THEN OutOfRange�      IF FL = 0 THEN FL = 1 : F = 0 : GOTO OutOfRange�      DX = OLDX - SX : IF DX = 0 THEN DX = 1�      SL = (OLDY - SY) / DX�      YP = OLDY��      FOR XP = INT(OLDX) + 1 TO SX�        YP = YP + SL�        IF YP <= YMIN(XP) THEN�          YMIN(XP) = YP�          IF F = 0 THEN XX = XP: YY = YP : F = 1�          MoveToEx hMemDC, XX, YY+yOfs, BYVAL %NULL�          LineTo hMemDC, XP, YP+yOfs�          XX = XP�          YY = YP�        END IF�        IF YP >= YMAX(XP) THEN�          YMAX(XP) = YP�          IF F = 0 THEN XX = XP: YY = YP : F = 1�          MoveToEx hMemDC, XX, YY+yOfs, BYVAL %NULL�          LineTo hMemDC, XP, YP+yOfs�          XX = XP�          YY = YP�        END IF�        F = 0�      NEXT XP�OutOfRange:�      OLDX = SX : OLDY = SY�    NEXT Y�  NEXT X��  BitBlt hDC, r.nLeft, r.nTop, Winx, WinY, hMemDC, 0, 0, %SRCCOPY�  EndPaint hWndShow, LpPaint��  DeleteObject hPen��END SUB��FUNCTION WinMain (BYVAL hInstance     AS LONG, _�                  BYVAL hPrevInstance AS LONG, _�                  lpCmdLine           AS ASCIIZ PTR, _�                  BYVAL iCmdShow      AS LONG) AS LONG��  LOCAL Msg         AS tagMsg�  LOCAL wndclass    AS WndClassEx�  LOCAL szAppName   AS ASCIIZ * 80�  LOCAL hWnd        AS LONG��  szAppName              = "GDIWINDOW"��  wndclass.cbSize        = SIZEOF(WndClass)�  wndclass.style         = %CS_HREDRAW OR %CS_VREDRAW��  wndclass.lpfnWndProc   = CODEPTR( WndProc )��  wndclass.cbClsExtra    = 0�  wndclass.cbWndExtra    = 0�  wndclass.hInstance     = hInstance�  wndclass.hIcon         = %NULL�  wndclass.hCursor       = LoadCursor( %NULL, BYVAL %IDC_ARROW )�  wndclass.hbrBackground = GetStockObject( %BLACK_BRUSH )�  wndclass.lpszMenuName  = %NULL�  wndclass.lpszClassName = VARPTR( szAppName )�  wndclass.hIconSm       = LoadIcon( hInstance, BYVAL %IDI_APPLICATION )��  RegisterClassEx wndclass��  ' Create a window using the registered class�  hWnd = CreateWindow("GDIWINDOW", _             ' window class name�                      "PowerBASIC GDI Test", _   ' window caption�                      %WS_OVERLAPPEDWINDOW, _    ' window style�                      %CW_USEDEFAULT, _          ' initial x position�                      %CW_USEDEFAULT, _          ' initial y position�                      %CW_USEDEFAULT, _          ' initial x size�                      %CW_USEDEFAULT, _          ' initial y size�                      %NULL, _                   ' parent window handle�                      %NULL, _                   ' window menu handle�                      hInstance, _               ' program instance handle�                      BYVAL %NULL)               ' creation parameters��  ShowWindow hWnd, iCmdShow�  UpdateWindow hWnd��  WHILE GetMessage(Msg, %NULL, 0, 0)�    TranslateMessage Msg�    DispatchMessage Msg�  WEND��  FUNCTION = msg.wParam��END FUNCTION  ' WinMain��'------------------------------------------------------------------------------��FUNCTION WndProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _�                  BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG��  LOCAL hDC       AS LONG�  LOCAL LpPaint   AS PaintStruct�  LOCAL tRect     AS Rect��  STATIC First    AS LONG��  SELECT CASE wMsg��    CASE %WM_CREATE��    CASE %WM_LBUTTONDOWN�      InvalidateRect hWnd, BYVAL %NULL, %TRUE��    CASE %WM_ERASEBKGND�      IF First = 0 THEN�        First = 1�      ELSE�        FUNCTION = 1�        EXIT FUNCTION�      END IF��    CASE %WM_KEYDOWN�      InvalidateRect hWnd, BYVAL %NULL, %TRUE��    CASE %WM_PAINT�      PRINT "Plotting.....";�      Plot hWnd�      PRINT "Press a key"�      FUNCTION = 0�      EXIT FUNCTION��    CASE %WM_DESTROY�      PostQuitMessage 0�      FUNCTION = 0�      EXIT FUNCTION��  END SELECT��  FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam)��END FUNCTION�Dave Navarro, Jr.              MICROSOFT MBF SUPPORT          dave@powerbasic.com            06-29-98 (16:58)       PBCC                   157  5019     MBF.BAS     '*********** CVSMBF.ASM - PDQ replacement for BASIC's B$MCVS routine�'code by Ethan Winer using code derived from Cobb's Inside�'Assembler newsletter (after fixing the code to handle zero properly!)�'converted to PB/DLL 5.0 by Dave Navarro, Jr. (8/25/97)��FUNCTION CVMS (x AS STRING) EXPORT AS SINGLE��  LOCAL outp AS SINGLE��  ! mov EBX, x              ; EBX = string handle�  ! mov EBX, DWord Ptr [EBX] ; EBX = address of string data�  ! mov AX, Word Ptr [EBX]  ; grab the low word�  ! mov outp, AX            ; store it in the output��  ! mov AX, [EBX+2]         ; now grab the high word�  ! or  AH, AH              ; is the exponent zero?�  ! jz  notzero             ;��  ! sub AH, 2               ; fix the exponent�  ! rcl AL, 1               ; slide the sign bit into the carry flag�  ! rcr AX, 1               ; and then slide the sign and exponent into place�NotZero:�  ! mov outp[2], AX         ; store that in the output too��  FUNCTION = outp��END FUNCTION��'******** MKSMBF.ASM - PDQ replacement for BASIC's B$FMSF routine�'by Ethan Winer using code derived from Cobb's Inside Assembler newsletter�'(after fixing the code to handle zero properly!)�'converted to PB/DLL 5.0 by Dave Navarro, Jr. (8/25/97)��FUNCTION MKMS (BYVAL s AS SINGLE) EXPORT AS STRING��  LOCAL outp AS STRING PTR * 4��  ! mov AX, s[2]        ; convert the number to MBF in place on the stack�  ! rcl AX, 1           ; slide the sign bit into the carry flag�  ! rcr AL, 1           ; and then into the correct bit position for MBF��  ! or  AX, AX          ; is the exponent zero?�  ! je  itszero         ; yes, skip ahead�  ! add AH, 2           ; no, adjust the exponent bias�itszero:�  ! mov  s[2], AX       ; copy the adjusted value back onto the stack��  outp = VARPTR(s)      '�  FUNCTION = @outp      '��END FUNCTION��'******** CVDMBF.ASM - PDQ replacement for BASIC's B$FMSF routine�'by Ethan Winer using code derived from Cobb's Inside Assembler newsletter�'(after fixing the code to handle zero properly!)�'converted to PB/DLL 5.0 by Dave Navarro, Jr. (6/29/98)��FUNCTION CVMD(BYVAL x AS STRING) EXPORT AS SINGLE��  LOCAL outp AS SINGLE��  ! mov EBX, x              ; EBX = string handle�  ! mov EBX, DWORD PTR [EBX] ; EBX = address of string data��  ! mov  AX,[EBX+06]         ;load AX:DX:BX:DI with the four MBF words�  ! mov  DX,[EBX+04]�  ! mov  BX,[EBX+02]�  ! mov  DI,[EBX]��  ! mov  CX,3               ;the number of bits to shift��Do1:�  ! shr  AL,1               ;shift the mantissa right one place�  ! rcr  DX,1�  ! rcr  BX,1�  ! rcr  DI,1�  ! loop Do1��  ! or   AH,AH              ;is the exponent zero?�  ! jnz  F1                 ;no, continue�  ! mov  AL,AH              ;yes, assign all zeros�  ! mov  Outp,AX            ;store the lower three words here�  ! mov  Outp[02],AX        ;�  ! mov  Outp[04],AX      ;�  ! jmp  Short Zero         ;and skip ahead to assign the highest word�F1:�  ! mov  Outp, DI         ;store the lower three words�  ! mov  Outp[02],BX�  ! mov  Outp[04],DX��  ! mov  DL,AL              ;swap the sign and exponent bits�  ! mov  AL,AH�  ! sub  AH,AH�  ! add  AX,&H37E           ;adjust the exponent bias�  ! test DL,&H10            ;is the sign bit set?�  ! jz   F2                 ;no, skip ahead�  ! or   AH,8               ;yes, so set the IEEE sign bit too�F2:�  ! mov  CL,4�  ! shl  AX,CL�  ! and  DL,&H0F�  ! or   AL,DL��Zero:�  ! mov  Outp[06],AX      ;store the result��  FUNCTION = outp��END FUNCTION��'******** MKDMBF.ASM - PDQ replacement for BASIC's B$FMDF routine�'by Ethan Winer using code derived from Cobb's Inside Assembler newsletter�'(after fixing the code to handle zero properly!)�'converted to PB/DLL 5.0 by Dave Navarro, Jr. (6/29/98)��FUNCTION MKMD$(BYVAL d AS DOUBLE) EXPORT AS STRING��  LOCAL outp AS STRING PTR * 4��  ! mov  AX,Word Ptr d[6]       ;copy the high word into AX�  ! mov  DX,AX          ;keep a copy for later�  ! mov  CL,4           ;number of bits to shift�  ! shr  AX,CL          ;shift 'em good���  ! and  AX,&H7FF       ;mask off the sign bit�  ! jz   F3             ;if the exponent is zero skip over�  ! sub  AX,&H37E       ;adjust the exponent bias only if non-zero!��F3:�  ! mov  Byte Ptr d[7],AL       ;store just the exponent��  ! mov  AX,DX          ;load the copy of the high word into AX again�  ! mov  SI,Word Ptr d[0]       ;and then load the rest into DX:BX:SI�  ! mov  BX,Word Ptr d[2]�  ! mov  DX,Word Ptr d[4]�  ! mov  CX,3           ;the number of times to shift bits��F4:�  ! shl  SI,1           ;shift the mantissa left one place�  ! rcl  BX,1�  ! rcl  DX,1�  ! rcl  AL,1�  ! loop F4��  ! shl  AX,1           ;shift the sign bit into the Carry flag�  ! rcr  AL,1��  ! mov  Word Ptr d[0],SI       ;store the output back onto the stack�  ! mov  Word Ptr d[2],BX�  ! mov  Word Ptr d[4],DX�  ! mov  Byte Ptr d[6],AL��  outp = VARPTR(d)�  FUNCTION = @outp��END FUNCTION�Dave Navarro, Jr.              NETWORK INFO UTILITY           dave@powerbasic.com            06-29-98 (16:58)       PBCC                   181  5326     NETWORK.BAS '==============================================================================�'�'  Network Info Utility for PB/CC 1.0�'  Copyright (c) 1998 by PowerBASIC, Inc.�'�'  Returns information about the current logged in user.�'�'  IMPORTANT:  This program only works in Windows NT!  The network API calls�'              used are not present in Windows 95 or 98.�'�'==============================================================================��$DIM ALL�$INCLUDE "WIN32API.INC"��'==============================================================================��FUNCTION WinErrMessage(BYVAL x AS LONG) AS STRING��  LOCAL buffer AS ASCIIZ * 64��  FormatMessage %FORMAT_MESSAGE_FROM_SYSTEM, BYVAL %NULL, x, %NULL, buffer,�SIZEOF(buffer), BYVAL %NULL��  IF LEN(buffer) THEN�    FUNCTION = buffer�  ELSE�    FUNCTION = FORMAT$(x)�  END IF��END FUNCTION��FUNCTION StrToAnsi(BYVAL u AS LONG) AS STRING��  DIM Buffer AS STRING�  DIM x      AS STRING�  DIM l      AS LONG��  l = lstrlenW(BYVAL u)�  x = PEEK$(u, l * 2)��  Buffer = SPACE$(LEN(x) \ 2)��  WideCharToMultiByte %CP_ACP, _               ' code page�                      %NULL, _                 ' performance and mapping flags�                      BYVAL STRPTR(x), _       ' Unicode string to convert�                      LEN(x), _                ' len of Unicode string�                      BYVAL STRPTR(Buffer), _  ' buffer for ANSI string�                      LEN(Buffer), _           ' len of ANSI buffer�                      BYVAL %NULL, _           ' default for unmappable chars�                      BYVAL %NULL              ' default flag��  IF LEN(Buffer) = 0 THEN�    Buffer = "[none]"�  END IF��  FUNCTION = RTRIM$(Buffer)��END FUNCTION��FUNCTION StrToUnicode(BYVAL x AS STRING) AS STRING��  DIM Buffer AS STRING��  Buffer = SPACE$(LEN(x) * 2)��  MultiByteToWideChar %CP_ACP, _               ' code page�                      %NULL, _                 ' performance and mapping flags�                      BYVAL STRPTR(x), _       ' ANSI string to convert�                      LEN(x), _                ' len of ANSI string�                      BYVAL STRPTR(Buffer), _  ' buffer for Unicode string�                      LEN(Buffer)              ' len of Unicode buffer��  FUNCTION = Buffer��END FUNCTION��'==============================================================================��FUNCTION WinMain (BYVAL CurInst&, _�                  BYVAL PrvInst&, _�                  CmdLine AS ASCIIZ PTR, _�                  BYVAL CmdShow&) EXPORT AS LONG��  LOCAL u        AS ASCIIZ * 256�  LOCAL ni       AS USER_INFO_3 PTR�  LOCAL si       AS SERVER_INFO_102 PTR�  LOCAL wkui     AS WKSTA_USER_INFO_1 PTR�  LOCAL nRet     AS LONG�  LOCAL uW       AS ASCIIZ * 512�  LOCAL tmp      AS STRING��  GetUserName u, 256��  STDOUT "Network information for user " & CHR$(34) & u & CHR$(34)�  STDOUT "Copyright (c) 1998 by PowerBASIC, Inc."�  STDOUT ""��  nRet = NetWkstaUserGetInfo(BYVAL %NULL, 1, wkui)�  IF nRet THEN�    STDOUT "Error: " & WinErrMessage$(nRet)�    EXIT FUNCTION�  END IF��  STDOUT "  Logon Domain: " & StrToAnsi(@wkui.wkui_logon_domain)�  STDOUT "  Logon Server: \\" & StrToAnsi(@wkui.wkui_logon_server)��  nRet = NetWkstaGetInfo(BYVAL %NULL, 102, si)�  IF nRet THEN�    STDOUT ""�    STDOUT "Error: " & WinErrMessage$(nRet)�    EXIT FUNCTION�  END IF��  STDOUT "   System name: \\" & StrToAnsi(@si.sv_name)�  STDOUT "        Hidden: ";��  IF @si.sv_hidden = %SV_HIDDEN THEN�    STDOUT "Yes"�  ELSE�    STDOUT "No"�  END IF��  STDOUT "       Comment: " & StrToAnsi(@si.sv_comment)��  IF @si.sv_type THEN�    STDOUT "         Type: ";�    IF BIT(@si.sv_type, 1) THEN�      STDOUT "Workstation"�    ELSEIF BIT(@si.sv_type, 2) THEN�      STDOUT "Server"�    ELSEIF BIT(@si.sv_type, 3) THEN�      STDOUT "SQL Server"�    ELSEIF BIT(@si.sv_type, 4) THEN�      STDOUT "Primary Domain Controller (PDC)"�    ELSEIF BIT(@si.sv_type, 5) THEN�      STDOUT "Backup Domain Controller (BDC)"�    ELSEIF BIT(@si.sv_type, 6) THEN��      STDOUT "Time Server"�    ELSEIF BIT(@si.sv_type, 7) THEN�      STDOUT "Apple File Protocol Server"�    ELSEIF BIT(@si.sv_type, 8) THEN�      STDOUT "Novell Server"�    ELSEIF BIT(@si.sv_type, 9) THEN�      STDOUT "Domain Member"�    ELSEIF BIT(@si.sv_type, 15) THEN�      STDOUT "Windows NT"�    END IF�  END IF��  uW = StrToUnicode(u)�  nRet = NetUserGetInfo(BYVAL %NULL, uW, 3, ni)�  IF nRet THEN�    STDOUT ""�    STDOUT "Error: " & WinErrMessage$(nRet)�    EXIT FUNCTION�  END IF��  STDOUT ""�  STDOUT "  Account name: " & StrToAnsi(@ni.uName)�  STDOUT "     Full name: " & StrToAnsi(@ni.FullName)�  STDOUT "       Comment: " & StrToAnsi(@ni.Comment)��  SELECT CASE @ni.Privilege�    CASE %USER_PRIV_GUEST : tmp = "Guest"�    CASE %USER_PRIV_USER  : tmp = "User"�    CASE %USER_PRIV_ADMIN : tmp = "Administrator"�    CASE ELSE             : tmp = "Unknown"�  END SELECT��  STDOUT "     Privilege: " & tmp�  STDOUT "Home directory: " & StrToAnsi(@ni.HomeDir)�  STDOUT "   Script Path: " & StrToAnsi(@ni.ScriptPath)�  STDOUT "       Profile: " & StrToAnsi(@ni.Profile)��  NetApiBufferFree ni�  NetApiBufferFree si�  NetApiBufferFree wkui��END FUNCTION�Dave Navarro, Jr.              WINDOWS CGI EXAMPLE            dave@powerbasic.com            06-29-98 (16:58)       PBCC                   89   3022     WINCGI.BAS  '==============================================================================�'�'  WinCGI Example for PowerBASIC Console Compiler�'  Copyright (c) 1998 by PowerBASIC, Inc.�'�'  Uses the Windows API to retrieve the current local date and time and�'  display them using the preferred formats specified by the user and�'  country settings.�'�'  Prints an HTTP header for HTML so that it can be used on a web server such�'  as Personal Web Server in Win95/98 and Peer Web Services or IIS in WinNT.�'�'==============================================================================��$DIM ALL��$INCLUDE "WINCGI.INC"��'==============================================================================��%NULL                  = 0�%LOCALE_SLONGDATE      = &H20        '  long date format string�%LOCALE_STIMEFORMAT    = &H1003      '  time format string�%LOCALE_USER_DEFAULT   = &H0000�%DATE_SHORTDATE        = &H1         '  use short date picture�%DATE_LONGDATE         = &H2         '  use long date picture�%TIME_NOSECONDS        = &H2&        '  do not use seconds��TYPE SYSTEMTIME�  wYear AS INTEGER�  wMonth AS INTEGER�  wDayOfWeek AS INTEGER�  wDay AS INTEGER�  wHour AS INTEGER�  wMinute AS INTEGER�  wSecond AS INTEGER�  wMilliseconds AS INTEGER�END TYPE��DECLARE SUB GetLocalTime LIB "KERNEL32.DLL" ALIAS "GetLocalTime" (lpSystemTime AS SYSTEMTIME)�DECLARE FUNCTION GetDateFormat LIB "KERNEL32.DLL" ALIAS "GetDateFormatA" (BYVAL Locale AS LONG, BYVAL dwFlags AS LONG, lpDate AS SYSTEMTIME, lpFormat AS ASCIIZ, lpDateStr AS ASCIIZ, BYVAL cchDate AS LONG) AS LONG�DECLARE FUNCTION GetTimeFormat LIB "KERNEL32.DLL" ALIAS "GetTimeFormatA" (BYVAL Locale AS LONG, BYVAL dwFlags AS LONG, lpTime AS SYSTEMTIME, lpFormat AS ASCIIZ, lpTimeStr AS ASCIIZ, BYVAL cchTime AS LONG) AS LONG��'==============================================================================��FUNCTION PbMain ()��  LOCAL st AS SYSTEMTIME�  LOCAL d  AS ASCIIZ * 64�  LOCAL t  AS ASCIIZ * 64�  LOCAL s  AS ASCIIZ * 64�  LOCAL x  AS STRING�  LOCAL p  AS LONG�  LOCAL i  AS LONG��  DIM Param(1) AS STRING��  ' Get date and time�  GetLocalTime st��  GetDateFormat %LOCALE_USER_DEFAULT, %DATE_LONGDATE, st, BYVAL %NULL, d, 64�  GetDateFormat %LOCALE_USER_DEFAULT, %DATE_SHORTDATE, st, BYVAL %NULL, s, 64�  GetTimeFormat %LOCALE_USER_DEFAULT, %TIME_NOSECONDS, st, BYVAL %NULL, t, 64��  ' Read from STDIN�  x = ReadCGI��  ' Count and partse the parameters into an array�  p = ParseParams(x, Param())��  ' Create a web page�  WriteCGI "<HTML>"��  WriteCGI "<P>At the tone the time will be <B>" & t & ", " & d & " (" & s & ")</B>"��  WriteCGI "<P>QUERY_METHOD = " + Query_Method�  WriteCGI "<P>REQUEST_METHOD = " + Request_Method�  WriteCGI "<P>CONTENT_LENGTH = " + FORMAT$(Content_Length)�  WriteCGI "<P>Form Data = " + CHR$(34) + x + CHR$(34)��  IF p THEN�    FOR i = 1 TO p�      WriteCGI "<LI>" + DecodeCGI( Param(i) )�    NEXT i�  END IF��  WriteCGI "</HTML>"��END FUNCTION�Dave Navarro, Jr.              DELAY FOR PB/CC AND PB/DLL     dave@powerbasic.com            07-17-98 (16:27)       PBCC, PBDLL            21   588      DELAY.BAS   '===========================================================================�'�'  DELAY for PB/CC 1.0 and PB/DLL 5.0�'  Released to the public domain.�'  by Dave Navarro (dave@powerbasic.com)�'�'  Requires Sleep DECLARE from WIN32API.INC�'�'===========================================================================��'�'  Seconds - the number of seconds to delay execution.  Accepts floating�'            point so that you can specify 1.5 to delay for one and a half�'            seconds.�'��SUB Delay(BYVAL seconds AS SINGLE)��  Sleep CLNG(seconds * 1000)��END SUB�Dave Navarro, Jr.              SHELLEXECUTE VARIANT           dave@powerbasic.com            07-22-98 (15:01)       PBCC                   34   1034     SH.BAS      '===========================================================================�'�'  SH.BAS for PB/CC v1.0 or later�'  Donated to the public domain by Dave Navarro, Jr. (dave@powerbasic.com)�'�'  This utility will call ShellExecute in Windows with anything you pass on�'  the command line.  For example:�'�'     sh www.powerbasic.com�'�'  will launch your web browser and take you to the PowerBASIC web site.�'�'     sh myfile.doc�'�'  will launch Microsoft Word (or whatever program handles .DOC files).�'�'===========================================================================��%NULL          = 0�%SW_SHOWNORMAL = 1��DECLARE FUNCTION ShellExecute LIB "SHELL32.DLL" ALIAS "ShellExecuteA"�(BYVAL hwnd AS LONG, lpOperation AS ASCIIZ, lpFile AS ASCIIZ, lpParameters�AS ASCIIZ, lpDirectory AS ASCIIZ, BYVAL nShowCmd AS LONG) AS LONG��FUNCTION PbMain () AS LONG��  LOCAL zText AS ASCIIZ * 256��  zText = COMMAND$��  ShellExecute %NULL, "OPEN", zText, BYVAL %NULL, CURDIR$, %SW_SHOWNORMAL��END FUNCTION�Dave Navarro, Jr.              EXENAME FUNCTION               dave@powerbasic.com            08-05-98 (12:33)       PBDLL, PBCC            12   214      EXENAME.BAS FUNCTION ExeName() AS STRING��  LOCAL hModule AS LONG�  LOCAL buffer  AS ASCIIZ * 256��  hModule = GetModuleHandle(BYVAL 0&)��  GetModuleFileName hModule, Buffer, 256��  FUNCTION = Buffer��END FUNCTION�Don Schullian                  SET A FILE'S DATE & TIME       d83@ath.forthnet.gr            09-22-98 (15:03)       PBCC                   112  6447     SETDT.BAS   '  Here's a bit of a routine that may come in handy from time to time. It will�'allow you to set a file's time and date. Now-a-days there are, actually 3�'TIME:DATE stamps for each file but this routine only changes/sets the one that�'is visable to users. Modifying the function to make changes to the other two�'would be just a matter of which member name of tDTA that you choose to use.��'  Anyhow, I'm not sure I understand half of what I'm doing here so make SURE�'that the time and date info you send is valid or NULL if you don't wish to�'change that particular item. Also, if you're not going to send the date and�'time in DATE$ and TIME$ format then you'll have to modify appropriate lines in�'the function to accomodate your individual method.��' If, by chance you run into any 'anomolies' (read bugs) please give me a�'shout.��'=============================================================================�'========================  START CODE ========================================�'=============================================================================�$INCLUDE "WIN32API.INC"�  DECLARE FUNCTION fSetFileTD(BYVAL FileSpec AS STRING,BYVAL Dyte AS STRING, BYVAL Tyme AS STRING) AS LONG��FUNCTION PBmain () AS LONG��  LOCAL Dyte     AS STRING�  LOCAL FileSpec AS STRING�  LOCAL Tyme     AS STRING��  FileSpec = ""�  Dyte     = "04-04-1994"          ' mm-dd-yyyy�  Tyme     = "04:04:04"            ' hh:mm:ss��  IF ISTRUE fSetFileTD(FileSpec,Dyte,Tyme) THEN�      PRINT "Success"�    ELSE�      PRINT "Failed"�  END IF�  WAITKEY$��END FUNCTION�'=============================================================================�'======================   END TEST CODE  =====================================�'=============================================================================�$IF 0�    ----------------------------                      PowerBASIC/cc v1.0� ---|          DASoft          |------------------------------------------�    ----------------------------    Copyright 1998      DATE: 1998-09-22�    | FILE NAME   File-TD .bas |          by�    |                          |  Don Schullian, Jr.�    ----------------------------�  PURPOSE: Set a file's time and date�   PARAMS: FileSpec$ Drive:\Path\FileName.ext of file to be changed�           Dyte$     IF NOT NULL then "mm-dd-yyy" format�           Tyme$     IF NOT NULL then "hh:mm:ss"  format�   RETURN: 1 IF Successful�           NULL if failed� --------------------------------------------------------------------------�$ENDIF��FUNCTION fSetFileTD (BYVAL FileSpec AS STRING, _�                     BYVAL Dyte     AS STRING, _�                     BYVAL Tyme     AS STRING  ) AS LONG��  LOCAL zFileSpec   AS ASCIIz * 260                          ' zSTRING for Windows�  LOCAL  FileNbr    AS LONG                                  ' PBcc's file number�  LOCAL  FileHandle AS LONG                                  ' Windows' file handle�  LOCAL tDTA        AS WIN32_FIND_DATA                       ' The file's info�  LOCAL tST         AS SystemTime                            ' unpacked time:date info�                                                             '�  ON ERROR GOTO fSetFileTDoops                               ' set error trap�                                                             '�  zFileSpec  = FileSpec                                      ' to zSTRING�  FileHandle = FindFirstFile( zFileSpec, tDTA )              ' get file info�  IF FileHandle < 1 THEN EXIT FUNCTION                       ' oops! no file here�  FindClose FileHandle                                       ' close find routine�                                                             '�  FileNbr = FREEFILE                                         ' next PBcc file number�  OPEN FileSpec FOR BINARY AS FileNbr                        ' open the file�  FileHandle = FILEATTR(FileNbr,2)                           ' get Win's file handle�  IF ( LEN(Dyte) = 0 )   OR _                                ' if either date or time�     ( LEN(Tyme) = 0 ) THEN                                  '  is to stay the same then�    FileTimeToLocalFileTime tDTA.ftLastWriteTime, _          '  convert info into local time�                            tDTA.ftLastWriteTime             '  and then into system time�    FileTimeToSystemTime    tDTA.ftLastWriteTime, tST        '�  END IF                                                     '�  IF LEN(Dyte) > 0 THEN                                      ' if we're setting the date�    tST.wYear      = VAL(MID$(Dyte,7))                       '  set members with values�    tST.wMonth     = VAL(MID$(Dyte,1))                       '�    tST.wDay       = VAL(MID$(Dyte,4))                       '�    tST.wDayOfWeek = 0                                       '  (not necessary)�  END IF                                                     '�  IF LEN(Tyme) > 0 THEN                                      ' if we're setting the file time�    tST.wHour         = VAL(MID$(Tyme,1))                    '  set members with values�    tST.wMinute       = VAL(MID$(Tyme,3))                    '�    tST.wSecond       = VAL(MID$(Tyme,7))                    '�    tST.wMilliSeconds = 0                                    '  (really!)�  END IF                                                     '�  SystemTimeToFileTime tST, tDTA.ftLastWriteTime             ' convert to local file time�  LocalFileTimeToFileTime tDTA.ftLastWriteTime, _            ' convert to system file time�                          tDTA.ftLastWriteTime               '�                                                             '�  FUNCTION = SetFileTime(FileHandle,tDTA.ftCreationTime  , _ ' set/make changes &�                                    tDTA.ftLastAccessTime, _ ' RETURN ZERO or 1�                                    tDTA.ftLastWriteTime   ) '�                                                             '�  fSetFileTDexit:                                            ' We're outt'a here�    IF FILEATTR(FileNbr,0) THEN CLOSE #FileNbr               '  if the file is actually open�    EXIT FUNCTION                                            '  bye!�                                                             '�  fSetFileTDoops:                                            ' OOPS!�    RESUME fSetFileTDexit                                    '��END FUNCTION�Don Schullian                  PBCC: X-TREE LIST              d83@ath.forthnet.gr            10-26-98 (08:11)       PBCC                   378  23059    FDIRTREE.BAS$IF 0�    ----------------------------                      PowerBASIC/cc v1.0� ---|          DASoft          |------------------------------------------�    ----------------------------    Public Domain       DATE: 1998-10-25�    | FILE NAME   fDirTree.bas |       code by�    | DIRECTORY   NB1cc        |  Don Schullian, Jr�    ----------------------------  www.DASoftVSS.com��  PURPOSE: CREATE & maintain X-Tree list for a given drive�   PARMAS: Tree$() the array to hold the items�           Item&   the element number TO be worked�           Indent& either 1 OR 2 spaces indentation for each level�           Drive$  the drive letter TO be X-Treed "C:\Whatever Is Fine"�  RETURNS: SEE: individual functions� -------------------------------------------------------------------------�  Hi,��  There are 4 functions in this set that you'll require and one that is for�  the exclusive use of fDirTree:��    fDirTree       - creates the working string elements for the list�                       RETURN: the number of items in the list�    fDirTreePath   - create a full path given an element number�                       RETURN: the full path name eg: "C:\MyDirectory\Data\"�    fDirTreeFind   - find the element number given a full path�                       RETURN: the element number for a path�     DirTreeExpand - expands and collapses the individual subs�                       sets bytes 1 and 4 for each element�     DirTreeGet    - this is a 'local' sub and can only be called by fDirTree��  PBMAIN is used as the menu function and shows how the tree can be displayed�  and manipulated. It is meant as a guide and not a final product. In fact, it's�  kind'a rough but it works (most of the time;) and it _IS_ test code.��  The following code will build an X-tree list FOR a given drive. The current�  drive is set to 'C' so if you don't want to do 'C' then change it in the�  call to fDirTree.��  Use this code as you will but I'd like to hear from you pro or con.��  C'ya,��  Don�    d83@DASoftVSS.com��$ENDIF��$INCLUDE "WIN32API.INC"��  TYPE DirTreeTYPE�    Visible  AS BYTE     ' T/F if the item is visible�    Level    AS BYTE     ' depth of directory 0 = root 1 = directory 2+ = sub dir�    Offset   AS BYTE     ' offsett to start of actual directory string�    Expanded AS BYTE     ' T/F if item is expanded�  END TYPE��  DECLARE FUNCTION fDirTree       (Tree() AS STRING,BYVAL Drive AS STRING,BYVAL Indent AS LONG) AS LONG�  DECLARE FUNCTION fDirTreePath   (Tree() AS STRING,BYVAL Item AS LONG) AS STRING�  DECLARE      SUB  DirTreeExpand (Tree() AS STRING,BYVAL Item AS LONG,BYVAL LastItem AS LONG)�  DECLARE FUNCTION fDirTreeFind   (Tree() AS STRING,BYVAL Path AS STRING) AS LONG�  DECLARE      SUB  DirTreeGet    (Tree() AS STRING,tDT() AS DirTreeTYPE,DirCount AS LONG,MaxDirs AS LONG)�'�'----------------------------------------------------------------------------------------�'------------  START OF TEST CODE  ------------------------------------------------------�'----------------------------------------------------------------------------------------�'�FUNCTION PBMAIN ()��  LOCAL Button  AS LONG�  LOCAL Display AS STRING * 36�  LOCAL FoS     AS LONG�  LOCAL Item    AS LONG�  LOCAL Last    AS LONG�  LOCAL LastDir AS LONG�  LOCAL LoS     AS LONG�  LOCAL OldFoS  AS LONG�  LOCAL Row     AS LONG�  LOCAL Temp    AS STRING * 39��  DIM Tree (100) AS STRING                                      ' our list of dirs�  LastDir = fDirTree(Tree(),"C",2)                              ' you set the drive here�  DIM Menu(LastDir) AS LONG                                     ' create a pointer array�                                                                '  for visible items�  COLOR 15, 0                                                   ' build the display screen�  LOCATE  1,  9 : PRINT "Click here to move list.";             '�  LOCATE 13, 42 : PRINT "Click out here to end";                '�  LOCATE 25,  9 : PRINT "Click here to move list.";             '�  COLOR 1, 15                                                   '�  LOCATE 2, 1                                                   '�  PRINT CHR$(218) + STRING$(36,196) + CHR$(191)                 '�  FOR Row = 1 TO 21                                             '�    PRINT CHR$(179) & SPACE$(36) & CHR$(179)                    '�  NEXT                                                          '�  PRINT CHR$(192) + STRING$(36,196) + CHR$(217)                 '�                                                                '�  MOUSE 3, UP                                                   ' ready the mouse�  MOUSE ON                                                      ' let the rodent run!�  FoS  = 1                                                      ' first item # visable�  LoS  = 1                                                      ' Last possible first item�  DO                                                            ' menu loop�    FoS = MIN(LoS,MAX(1,FoS))                                   '  keep FoS within bounds�    IF Last = 0 THEN                                            '  if we need to recount�      FOR Item = 1 TO LastDir                                   '   visible items�        IF ASC(Tree(Item)) THEN                                 '�          INCR Last                                             '�          Menu(Last) = Item                                     '�        END IF                                                  '�      NEXT                                                      '�      LoS    = MAX(1,Last - 20)                                 '   reset last-first item�      FoS    = MIN(FoS,LoS)                                     '   keep FoS in bounds�      OldFoS = 0                                                '   force a reprint�    END IF                                                      '�    IF FoS <> OldFoS THEN                                       '  if we need to reprint�      Item = FoS                                                '   1st visible item�      FOR Row = 3 TO 23                                         '   21 rows all tolled�        IF Item =< Last THEN                                    '    if still in the list�            Display = MID$(Tree(Menu(Item)),5)                  '     show only 'tree' stuff�          ELSE                                                  '    else�            Display = ""                                        '     clear the line�        END IF                                                  '�        INCR Item                                               '    next item #�        LOCATE Row, 2                                           '    print the stuff�        PRINT Display                                           '�      NEXT                                                      '�      INPUT FLUSH                                               '   clear mouse�    END IF                                                      '�    Button = ASC(WAITKEY$,4)                                    '   get rodent stuff�    IF Button < 1 THEN ITERATE                                  '   hay! no keyboard here!�    IF MOUSEY < 3 THEN                                          '   scroll down�        IF Button = 2 THEN FoS = FoS + 20 ELSE INCR FoS         '�      ELSEIF MOUSEY > 23 THEN                                   '   scroll up�        IF Button = 2 THEN FoS = FoS - 20 ELSE DECR FoS         '�      ELSEIF MOUSEX > 40 THEN                                   '   all done!�        EXIT LOOP                                               '�      ELSEIF MOUSEX < 40 THEN                                   '   expand/collapse item�        Item = Menu( MOUSEY + Fos - 3 )                         '    get item number�        Temp = fDirTreePath(Tree(),Item)                        '    get whole path�        LOCATE 1, 41 : PRINT Temp;                              '    display most of it�        Last = fDirTreeFind(Tree(),Temp)                        '    test fDirTreeFind�        LOCATE 2, 41 : PRINT Last, Item                         '    the nbrs should be equal�        DirTreeExpand Tree(), Item, LastDir                     '    call routine�        Last = 0                                                '    force recount�    END IF                                                      '�  LOOP                                                          '�  MOUSE OFF                                                     ' bye Mick�  COLOR 7, 0                                                    '�  CLS                                                           '��END FUNCTION�'�'----------------------------------------------------------------------------------------�'------------   END OF TEST CODE  -------------------------------------------------------�'----------------------------------------------------------------------------------------�'�FUNCTION fDirTree (      Tree() AS STRING, _�                   BYVAL Drive  AS STRING, _�                   BYVAL Indent AS LONG    ) AS LONG��  DIM EndLevel  AS STRING�  DIM L         AS LONG�  DIM LastDir   AS LONG�  DIM NextLevel AS LONG�  DIM NoKids    AS STRING�  DIM P         AS LONG�  DIM Spacer    AS STRING�  DIM Spcr      AS STRING�  DIM WithKids  AS STRING�  DIM X         AS LONG��  X = UBOUND(Tree(1))                                           '�  DIM tDT(X) AS DirTreeTYPE                                     '�                                                                '�  tDT (1).Level    = 0                                          'starting level�  tDT (1).Visible  = 1                                          'always visable�  tDT (1).Offset   = 5                                          '�  tDT (1).Expanded = 1                                          ' always expanded�  Tree(1)          = UCASE$(RIGHT$(Drive,1)) + ":\"             'root directory�  LastDir          = 1                                          'gotta start somewhere�  Indent           = MAX(2,MIN(1,Indent))                       '1 or 2 no less, no more�  WithKids         = LEFT$(CHR$(043,196),Indent)                'plus sign�  NoKids           = LEFT$(CHR$(195,196),Indent)                'left bottom corner�  Spacer           = LEFT$(CHR$(179,032),Indent)                'vertical line�  EndLevel         = LEFT$(CHR$(192,196),Indent)                'left cross member�                                                                '�  DirTreeGet Tree(), tDT(), LastDir, X                          'load the directories�  ARRAY SORT Tree(1) FOR LastDir, COLLATE UCASE, TAGARRAY tDT() 'sort the whole thing�                                                                '�  FOR X = LastDir TO 2 STEP -1                                  'add tree stuff�    Spcr = REPEAT$(tDT(X).Level,Spacer)                         ' create spacer to length�    P    = ( ( tDT(X).Level - 1 ) * Indent ) + 1                ' where to put other goodies�    NextLevel = tDT(X+1).Level                                  ' level of next dir item�    SELECT CASE tDT(X).Level                                    ' put other goodies�      CASE = NextLevel                                          '�        MID$(Spcr,P,Indent) = NoKids                            '  no sub dirs under here�      CASE > NextLevel                                          '�        MID$(Spcr,P,Indent) = EndLevel                          '  no sub dirs this level�      CASE ELSE                                                 '�        MID$(Spcr,P,Indent) = WithKids                          '  this one has sub dirs�        NextLevel = LastDir                                     '  set flag to last dir item�        FOR L = X+1 TO LastDir                                  '  check if this is last sub�          IF tDT(L).Level = tDT(X).Level THEN EXIT SELECT       '   another sub in this level�          IF tDT(L).Level < tDT(X).Level THEN                   '   last sub in this level�            NextLevel = L - 1                                   '�            EXIT FOR                                            '�          END IF                                                '�        NEXT                                                    '�        FOR L = X + 1 TO NextLevel                              '  replace all vert lines down�          ASC(Tree(L),P+4) = 32                                 '         to next prev level�        NEXT                                                    '�    END SELECT                                                  '�    tDT(X).Visible = CBYT(tDT(X).Level = 1 )                    '�    tDT(X).Offset  = LEN(Spcr) + 5                              '�    Tree(X)        = PARSE$(Tree(X),"\",tDT(X).Level+1)         ' cut out last dir item�    Tree(X)        = tDT(X) & Spcr & Tree(X)                    ' create dir item package�  NEXT                                                          '�  Tree(1) = tDT(1) & Tree(1)                                    '�                                                                '�  FUNCTION = LastDir                                            'RETURN item count��END FUNCTION�'�'----------------------------------------------------------------------------------------�'�FUNCTION fDirTreeFind( Tree() AS STRING,BYVAL Path AS STRING ) AS LONG��  LOCAL tDT      AS DirTreeTYPE�  LOCAL  Delim   AS STRING�  LOCAL  Found   AS LONG�  LOCAL  LastDir AS LONG�  LOCAL  Pce     AS LONG�  LOCAL  Pieces  AS LONG�  LOCAL  Start   AS LONG�  LOCAL  SubDir  AS STRING��  LastDir = UBOUND(Tree(1))                                     'end of the road�  Delim   = CHR$(92)                                            'lookin' for "\"�  Path    = RTRIM$(Path,ANY CHR$(32,92))                        'trim things down to size�  Path    = UCASE$(Path)                                        'ucase it�  Pieces  = PARSECOUNT(Path,Delim)                              'number of depths�  Start   = 2                                                   'start here (assume drive ok)�                                                                '�  IF Pieces < 2 THEN EXIT FUNCTION                              ' oops! drive only�                                                                '�  FOR Pce = 2 TO Pieces                                         ' start lookin'�    SubDir   = PARSE$(Path,Delim,Pce)                           '  cut out this directory�    LSET tDT = Tree(Start)                                      '  load goodies�    ARRAY SCAN Tree(Start), FROM tDT.Offset TO 256, _           '  find a match�                              COLLATE UCASE, = SubDir, TO Found '�    IF Found = 0 THEN EXIT FUNCTION                             '  nope... no match, bye!�    Start = Start + Found - 1                                   '  new element number�    IF Pce = Pieces THEN EXIT FOR                               '  all done!�    DO                                                          '  look for next level�      INCR Start                                                '   start with next item�      IF Start => LastDir THEN EXIT FUNCTION                    '   past the end of the array�      SELECT CASE ASC(Tree(Start),2)                            '   next element's level�        CASE < tDT.Level : EXIT FUNCTION                        '    went back up a level�        CASE > tDT.Level : EXIT LOOP                            '    went down a level�      END SELECT                                                '�    LOOP                                                        '�  NEXT                                                          '�                                                                '�  FUNCTION = Start                                              'RETURN element number��END FUNCTION�'�'----------------------------------------------------------------------------------------�'�FUNCTION fDirTreePath (Tree() AS STRING,BYVAL Item AS LONG) AS STRING��  LOCAL tDT  AS DirTreeTYPE�  LOCAL Ofs  AS LONG�  LOCAL Path AS STRING��  LSET tDT = Tree(Item)                                         ' get the goodies�  IF tDT.Level > 0 THEN                                         ' if not root directory�    Path = MID$(Tree(Item),tDT.Offset) & "\"                    ' start building path�    WHILE tDT.Level > 1                                         ' while a sub dir�      DECR Item                                                 '  previous item #�      IF ASC(Tree(Item),2) < tDT.Level THEN                     '  if not next level up�        Ofs  = ASC(Tree(Item),3)                                '  offset to path info�        Path = MID$(Tree(Item),Ofs) & "\" & Path                '  add new dir to Path�        DECR tDT.Level                                          '  previous level�      END IF                                                    '�    WEND                                                        '�  END IF                                                        '�                                                                '�  FUNCTION = MID$(Tree(1),5) & Path                             ' add the root & RETURN��END FUNCTION�'�'----------------------------------------------------------------------------------------�'�SUB DirTreeExpand ( Tree() AS STRING, BYVAL Item AS LONG, BYVAL LastItem AS LONG )��  LOCAL tDT       AS DirTreeTYPE�  LOCAL  NextItem AS LONG�  LOCAL  P        AS LONG��  IF ( Item = 1        )   OR _                                 'can't do anything with these 2�     ( Item = LastItem ) THEN EXIT SUB                          '�                                                                '�  LSET tDT = Tree(Item)                                         'load the starting goodies�  NextItem = (Item + 1)                                         '�  IF ASC(Tree(NextItem),2) =< tDT.Level THEN EXIT SUB           'this sub has no kid!�  P = INSTR(Tree(Item),ANY CHR$(43,195,192))                    'position of + or corner�                                                                '�  BIT TOGGLE tDT.Expanded, 0                                    'switch the expanded state�  ASC(Tree(Item),4) = tDT.Expanded                              'set expanded state�                                                                '�  IF ISTRUE tDT.Expanded THEN                                   'expand�      IF ASC(Tree(NextItem),P) = 32 THEN                        ' last item of level�          ASC(Tree(Item),P) = 192                               '  put the bottom left corner�        ELSE                                                    ' else�          ASC(Tree(Item),P) = 195                               '  put the left cross�      END IF                                                    '�      INCR tDT.Level                                            ' testing for next level�      FOR Item = NextItem TO LastItem                           ' start testing�        SELECT CASE ASC(Tree(Item),2)                           '�          CASE < tDT.Level : EXIT FOR                           '  all done�          CASE = tDT.Level : ASC(Tree(Item),1) = 1              '  set 'seen' flag�        END SELECT                                              '�      NEXT                                                      '�    ELSE                                                        'collapse�      ASC(Tree(Item),P) = 43                                    ' put the + sign again�      FOR Item = NextItem TO LastItem                           ' start testing�        SELECT CASE ASC(Tree(Item),2)                           '  test level of this sub�          CASE = tDT.Level                                      '   we're all done�            EXIT FOR                                            '�          CASE > tDT.Level                                      '�            ASC(Tree(Item),1) = 0                               '   reset 'seen' flag�            IF ASC(Tree(Item),4) THEN                           '   if this sub is expanded�               DirTreeExpand Tree(), Item, LastItem             '    then collapse it�            END IF                                              '�        END SELECT                                              '�      NEXT                                                      '�  END IF                                                        '��END SUB�'�'----------------------------------------------------------------------------------------�'�SUB DirTreeGet (Tree()  AS STRING     , _�                tDT ()  AS DirTreeTYPE, _�                LastDir AS LONG       , _�                MaxDirs AS LONG         )��  LOCAL tDTA   AS WIN32_FIND_DATA�  LOCAL  Hndl  AS LONG�  LOCAL  Level AS LONG�  LOCAL  Mom   AS LONG�  LOCAL zPath  AS ASCIIZ * 256��  zPath   = Tree(LastDir) & "*.*"                               ' new directory mask�  Hndl    = FindFirstFile( zPath, tDTA )                        ' object handle�  IF ISFALSE Hndl THEN EXIT SUB                                 ' nothing this directory�                                                                ' -----------------------�  Mom   = LastDir                                               ' incoming directory item�  Level = tDT(LastDir).Level + 1                                ' this level�                                                                '�  DO                                                            '�    IF ISFALSE BIT(tDTA.dwFileAttributes, 4) THEN ITERATE       ' if it's not a directory�    IF ASC(tDTA.cFileName) = 46              THEN ITERATE       ' if it's ".." or "."�    '-----------------------------------------------------------'�    INCR LastDir                                                ' next array element�    IF LastDir > MaxDirs THEN                                   ' if past end of array�      MaxDirs = MaxDirs + 50                                    '  add 50 new elements�      REDIM PRESERVE Tree (MaxDirs)                             '�      REDIM PRESERVE tDT  (MaxDirs)                             '�    END IF                                                      '�    tDT (LastDir).Level = Level                                 ' store the depth level�    Tree(LastDir)       = Tree(Mom) & tDTA.cFileName & "\"      ' store d:\path\path�    DirTreeGet Tree(), tDT(), LastDir, MaxDirs                  ' see if there are any kids�    '-----------------------------------------------------------'�  LOOP UNTIL ISFALSE FindNextFile(Hndl,tDTA)                    ' get next item�                                                                '�  FindClose Hndl                                                ' close object��END SUB�Don Schullian                  HUFFMAN COMPRESSION FOR PB/CC  d83@ath.forthnet.gr            10-30-98 (08:11)       PBCC                   335  20215    HUFMN-CC.BAS$if 0�    ��������������������������ķ                        PowerBASIC v3.20� ��Ĵ          DASoft          �����������������������������������������ķ� �  ��������������������������Ķ    Copyright 1997    � DATE: 1998-10-29 �ķ� �  � FILE NAME   hufmn-cc.bas �          by          ������������������ � �� �  � LIBRARY                  �  Don Schullian, Jr.                     � �� �  ��������������������������ͼ                                         � �� �                                                                       � �� �      The following code and notes are passed into PUBLIC DOMAIN.      � �� �                                                                       � �� � Honorable mention of my name is requested if any of this file is used � �� �  in another publication, recreated for mass consumption or teaching.  � �� �                                                                       � �� �����������������������������������������������������������������������ͼ ��   �����������������������������������������������������������������������ͼ�� After much searching and testing these HUFFMAN string (de)compression� functions are about the smallest, fastest I can come up with. I've done� away with the "hashing" functions the routines I've found used and just� created the bit masks mathmatically. They work the same and look the same� so "if it looks like a duck and quacks like a duck then....".�� Anyhow, what Huffman compression does is counts all the incidences of byte� values used in a string (file), then stores the used vales in an array and� sorts that array in decending order. (highest count first) Then each� character is assigned a bit mask. The bit masks are then layed into a buffer� and viola! compressed data. Maybe! There is an outside chance that the data� won't comperss because there are too many varied and oft used odd-ball� characters but... this would be rare for text in a single language.�� So lets take "PETER PIPER PICKED A PECK OF PICKLED PEPPERS." as a test� string. After the count, sort and bit map create you get a set of arrays� that look like this��   "P"  CharVal(01) = 80  : Count%(01) =  9  : BitCode??(1) =     "00"�   "E"  CharVal(02) = 69  : Count%(02) =  8  : BitCode??(2) =    "010"�   " "  CharVal(02) = 32  : Count%(02) =  7  : BitCode??(2) =    "011"�   "C"  CharVal(02) = 67  : Count%(02) =  3  : BitCode??(2) =   "1000"�   "R"  CharVal(02) = 82  : Count%(02) =  3  : BitCode??(2) =   "1001"�   "I"  CharVal(02) = 73  : Count%(02) =  3  : BitCode??(2) =   "1010"�   "K"  CharVal(02) = 75  : Count%(02) =  3  : BitCode??(2) =   "1011"�   "D"  CharVal(02) = 68  : Count%(02) =  2  : BitCode??(2) =  "11000"�   "F"  CharVal(02) = 70  : Count%(02) =  1  : BitCode??(2) =  "11001"�   "A"  CharVal(02) = 65  : Count%(02) =  1  : BitCode??(2) =  "11010"�   "."  CharVal(02) = 46  : Count%(02) =  1  : BitCode??(2) =  "11011"�   "O"  CharVal(02) = 79  : Count%(02) =  1  : BitCode??(2) = "111000"�   "L"  CharVal(02) = 76  : Count%(02) =  1  : BitCode??(2) = "111001"�   "S"  CharVal(02) = 83  : Count%(02) =  1  : BitCode??(2) = "111010"�   "T"  CharVal(02) = 84  : Count%(02) =  1  : BitCode??(2) = "111011"��  Packed up, "PETER" looks like this "000101110110101001" and takes up�  18 bits or 2.25 bytes vs the original 5 bytes.��  Unpacking requires that you keep thinking in BITS left to right (that's�  backwards to the computer remember). When you read in the first bit and�  it is OFF then you're dealing with either the first, second or third�  character in the list ("P", "E" or " " ). If the next bit is, again�  OFF then the coded letter is "P" and so on for the next two bits if�  it is ON.��  If that frist bit is ON then you have to keep checking until you get an�  OFF bit and adding 4 for each ON bit you encounter. When you hit the OFF�  bit the next two bits add to your counter to determine which character�  in the list you're to use.�         ������� + 4�         ������� + 4�         ������� + 4�         ������������� skip this bit�         ������� + 2�         ������� + 1�  "T" = "111011"�                 total = 15  so CharVal?(15) = 84��  Here's the whole word "PETER" layed out with count and logic.��   ��������������������� the first bit is OFF so�   ���������������������   the next bit is OFF too so ============ "P"�   ��������������������� the first bits OFF so�   ���������������������   the next bit is ON so at least 2�   ���������������������   the next bit is OFF so it's a 2 ======= "E"�   ��������������������� the first bit is ON so at least 4�   ���������������������   the next bit is ON so +4 for  8�   ���������������������   the next bit is ON so +4 for 12�   ���������������������   this bit is OFF so end of 4's�   ���������������������     this bit is ON so   +2 for 14�   ���������������������     this bit is ON so   +1 for 15 ======= "T"�   ��������������������� the first bits OFF so�   ���������������������   the next bit is ON so at least 2�   ���������������������   the next bit is OFF so it's a 2 ======= "E"�   ��������������������� this first bit is ON so at least 4�   ���������������������   the next bit is OFF so end of 4's�   ���������������������   this bit is OFF so add 0�   ���������������������   this bit is ON so +1 for 5 ============ "R"�   000101110110101001���  Credit is due to that unknown individual who provided the HUFFMAN.TIP�  file that came with one of the earlier versions of PowerBASIC. From his�  or her notes I was able to decifer the coding system and create these�  functions. And so I now pass them onto you for your use.��  HAND,��  Don Schullian�  d83@DASoftVSS.com�$endif��DECLARE FUNCTION fHuffPack   (O AS STRING) AS STRING�DECLARE FUNCTION fHuffUnPack (P AS STRING) AS STRING��FUNCTION PBmain ()��  LOCAL Orig   AS STRING�  LOCAL Packed AS STRING�  LOCAL UnPked AS STRING��  CLS�  Orig = "PETER PIPER PICKED A PECK OF PICKLED PEPPERS."��  Packed = fHuffPack( Orig )�  PRINT FORMAT$( LEN(Orig  ), "Len = ## : >>" ); Orig  ; "<<"�  PRINT FORMAT$( LEN(Packed), "Len = ## : >>" ); Packed; "<<"��  PRINT STRING$(79,45)��  UnPked = fHuffUnPack( Packed )�  PRINT "Orig: >>"; Orig  ; "<<"�  PRINT "UnPk: >>"; UnPked; "<<"�  WaitKey$��END FUNCTION��'=========================================================================�'==  fHuffPack( InString )�'==�'==   PARAMS: InString = the data to be packed�'==  RETURNS: Packed data string�'==                  2 bytes   = original length�'==                  1 byte    = number of unique characters�'==                  x bytes   = unique characters�'==                  remainder = encoded data�'==           NULL if packed version of InString would exceed the�'==                 string size limitations set with STRING�'=========================================================================��FUNCTION fHuffPack( InString AS STRING ) AS STRING��  DIM   Count  (256) AS LONG                             ' count of all chars�  DIM   CharVal(256) AS LONG                             ' assigned values�  DIM   BitCode(256) AS LONG                             ' bit values�  LOCAL Packed       AS STRING                           ' working string buffer�  LOCAL InLen        AS LONG                             ' length of incoming�  LOCAL CharCount    AS LONG                             ' # of used chars�  LOCAL I_ptr        AS BYTE PTR                         ' ptr to incoming�  LOCAL P_ptr        AS BYTE PTR                         ' ptr to working buffer�  LOCAL BitBuf       AS LONG                             ' working buffer of bits�  LOCAL BitCount     AS LONG                             ' current bit position�  LOCAL X            AS LONG                             ' loop counter�  LOCAL B            AS LONG                             ' counter�  LOCAL F            AS LONG                             ' counter�  LOCAL P            AS LONG                             ' counter�  LOCAL S            AS LONG                             ' counter�                                                         '�  I_ptr  = STRPTR( InString )                            ' set incoming pointer�  InLen = LEN( InString )                                ' set incoming length�                                                         '�  FOR X = 1 TO InLen                                     ' count each char in�    INCR Count(@I_ptr)                                   '  the incoming string�    INCR I_ptr                                           '�  NEXT                                                   '�  I_ptr = I_ptr - InLen                                  ' reset pointer to start�                                                         '�  FOR X = 1 TO 256                                       ' assign and count the #�    IF Count(X) > 0 THEN                                 '  of used characters�      INCR CharCount                                     '�      CharVal(X) = X                                     '�    END IF                                               '�  NEXT                                                   '�                                                         ' gets the char values in�  ARRAY SORT Count(), TAGARRAY CharVal(), DESCEND        ' highest first order�  ARRAY INSERT CharVal(0)                                ' (1) is now highest�                                                         '�  BitCode(2) = 2                                         ' create a set of bit�  BitCode(3) = 3                                         ' values�  F          = 8                                         '  1 =    "00"�  FOR X = 4 TO CharCount                                 '  2 =   "010"�    BitCode(X) = F + B                                   '  3 =   "011"�    IF B < 3 THEN                                        '  4 =  "1000"�        INCR B                                           '  5 =  "1001"�      ELSE                                               '  6 =  "1010"�        B = F                                            '  7 =  "1011"�        SHIFT LEFT F, 1                                  '  8 = "11000"�        F = ( F OR B )                                   ' 12 = "111000"�        B = 0                                            '�    END IF                                               '�  NEXT                                                   '�                                                         '�  B = CharCount + 3                                      ' count number of bytes�  FOR X = 1 TO InLen                                     ' required to hold the�    ARRAY SCAN CharVal(1), = @I_ptr, TO P                ' 3 byte header +�    INCR I_ptr                                           ' number of characters +�    SELECT CASE P                                        ' the packed data�      CASE 1    : BitCount = BitCount + 2                '  (see list above for�      CASE 2, 3 : BitCount = BitCount + 3                '     bit counts)�      CASE ELSE : BitCount = BitCount + (P \ 4) + 3      '�    END SELECT                                           '�    IF BitCount => 32000 THEN                            ' lay off 4000 bytes�      B = B + 4000                                       '�      BitCount = BitCount - 32000                        '�    END IF                                               '�  NEXT                                                   '�  IF BitCount > 0 THEN                                   ' clean-up leftover�    BitCount = BitCount + 7                              '  bits + whatever is�    B = B + ( BitCount \ 8 )                             '  needed to get a full�  END IF                                                 '  bit�  I_ptr = I_ptr - InLen                                  ' reset incoming pointer�  Packed = STRING$( B, 0 )                               ' create working buffer�  MID$( Packed, 1, 2 ) = MKI$(InLen)                     ' put len of original�  P_ptr  = STRPTR( Packed ) + 2                          ' set the working pointer�  @P_ptr = CharCount                                     ' byte 3 = # of chars�  FOR X = 1 TO CharCount                                 ' bytes 4 -> are the�    INCR P_ptr                                           '  char values that�    @P_ptr = CharVal(X)                                  '  correspond to the bit�  NEXT                                                   '  codes�                                                         '�  BitCount = 0                                           ' start processing bytes�  FOR X = 1 TO InLen                                     '�    ARRAY SCAN CharVal(1), = @I_ptr, TO P                ' find array pos of next�    INCR I_ptr                                           '   char / bump pointer�    SELECT CASE P                                        ' set # of bits required�      CASE 1    : S = 2                                  '  to hold the bit-code�      CASE 2, 3 : S = 3                                  '�      CASE ELSE : S = (P \ 4) + 3                        '�    END SELECT                                           '�    SHIFT LEFT BitBuf, S                                 ' shift buffer # new bits�    BitBuf = ( BitBuf OR BitCode(P) )                    ' OR new bits into buffer�    BitCount = BitCount + S                              ' incr bit counter�    IF BitCount => 16 THEN GOSUB fHuffPack1              ' if the buffer is full�  NEXT                                                   '�  IF BitCount > 0 THEN                                   ' clean-up leftover bits�    IF BitCount > 8 THEN GOSUB fHuffPack1                '   more than 1 byte�    IF BitCount > 0 THEN                                 '   still not done�      SHIFT LEFT BitBuf, 8 - BitCount                    '   move bits to left�      INCR P_ptr                                         '   next/last pos in buf�      @P_ptr = ( BitBuf AND 255 )                        '   put it there, dude!�    END IF                                               '�  END IF                                                 '�                                                         '�  FUNCTION = Packed                                      ' RETURN packed data�  EXIT FUNCTION                                          '�  '======================================================'========================�  fHuffPack1:                                            ' remove full bytes from�    DO                                                   '  the bit buffer and put�      BitCount = BitCount - 8                            '  them in the work buf�      ROTATE RIGHT BitBuf, BitCount                      ' move the left most�      INCR P_ptr                                         '  bit to the right�      @P_ptr = ( BitBuf AND 255 )                        '  stuff it into the�      SHIFT RIGHT BitBuf, 8                              ' strip right most bits�      ROTATE LEFT BitBuf, BitCount + 8                   ' move bits back in order�    LOOP UNTIL BitCount < 8                              '�  RETURN                                                 '�                                                         '�END FUNCTION��'=========================================================================�'==  fHuffUnPack( Packed )�'==�'==   PARAMS: Packed�'==             SEE: fHuffPack for header details�'==  RETURNS: Unpacked data�'==     NOTE: There is NO error checking etc. as it is assumed that what�'==           you send in Packed was created with fHuffPack�'=========================================================================��FUNCTION fHuffUnPack( Packed AS STRING ) AS STRING��  DIM   CharVal(256) AS LONG                             ' char values from�  LOCAL UnPacked     AS STRING                           ' working buffer�  LOCAL InLen        AS LONG                             ' length of incoming�  LOCAL OutLen       AS LONG                             ' final length of out�  LOCAL I_ptr        AS BYTE PTR                         ' pointer to incoming�  LOCAL O_ptr        AS BYTE PTR                         ' pointer to outgoing�  LOCAL BitBuf       AS LONG                             ' buffer to work bits�  LOCAL FirstBit     AS LONG                             ' current bit position�  LOCAL S            AS LONG                             ' counter�  LOCAL P            AS LONG                             ' counter�                                                         '�  OutLen   = CVI( Packed )                               ' final returned len�  UnPacked = STRING$( OutLen + 4,0 )                     ' create working  buf�  O_ptr    = STRPTR( UnPacked )                          ' set working  ptr�  I_ptr    = STRPTR( Packed   ) + 2                      ' set incoming  ptr�  S        = @I_ptr                                      ' # of chars used�  InLen    = LEN( Packed ) - ( S + 2 )                   ' # of packed bytes�  FirstBit = -1                                          ' starts down here�                                                         '�  FOR P = 1 TO S                                         ' load char values�    INCR I_ptr                                           '  into array�    CharVal(P) = @I_ptr                                  '�  NEXT                                                   '�                                                         '�  DO                                                     ' start processing�    WHILE ( FirstBit < 15 ) AND ( InLen > 0 )            '  if bit buffer empty�      DECR InLen                                         '  knock off a byte�      INCR I_ptr                                         '  next byte in incoming�      FirstBit = FirstBit + 8                            '  loading 8 bits�      SHIFT LEFT BitBuf, 8                               '  make room in bit buf�      BitBuf = ( BitBuf OR @I_ptr )                      '  stuff new byte�    WEND                                                 '�    IF BIT( BitBuf, FirstBit ) = 0 THEN                  ' if the bit is 0�        DECR FirstBit                                    '  next bit position�        IF BIT(BitBuf,FirstBit) = 0 THEN                 '  if still 0 then�            P = 1                                        '   this is code "00"�          ELSE                                           '  the bit is ON�            DECR FirstBit                                '   next bit position�            P = 2 + BIT(BitBuf,FirstBit)                 '   "01" or "11"�        END IF                                           '�      ELSE                                               ' else the bit is 1�        P = 0                                            '  clear code value�        DO                                               '  check next bits�          P = P + 4                                      '   each ON = 4�          DECR FirstBit                                  '�        LOOP UNTIL BIT(BitBuf,FirstBit) = 0              '  until we hit an OFF�        FOR S = 2 TO 1 STEP -1                           '  skip next bit then�          DECR FirstBit                                  '�          IF BIT(BitBuf,FirstBit) THEN P = P + S         '   add 2 and/or 1�        NEXT                                             '�    END IF                                               '�    DECR FirstBit                                        ' next bit position�    @O_ptr = CharVal(P)                                  ' set the decoded char�    INCR O_ptr                                           ' move working buf ptr�  LOOP UNTIL ( InLen = 0 ) AND ( FirstBit < 0 )          ' got to get them all�                                                         '�  FUNCTION = LEFT$( UnPacked, OutLen )                   ' RETURN truncated�                                                         '�END FUNCTION�Eustace Frilingos/Don SchullianDAY COUNTER FOR PBCC           d83@ath.forthnet.gr            11-04-98 (07:03)       PBCC                   229  10747    DATES-CC.BAS$if 0��  These routines are Y5M compliant!��  This code was reworked from code I was given by Eustice Frilingos so most of�  the credit goes to him. All I did was convert it into PB code to take�  advantage of the goodies found therein.��  These two functions pack the three date elements (Y,M,D) into a long integer�  by counting the number of days since 1-1-0001 then unpacking that number into�  the three date elements. The last possible date is in the year 5.8M so it's�  safe to say that the Y2K thingie isn't a problem!��  The fly in the ointment is that somewhere in the 12th century 11 days were�  cut or added to the calendar (don't remember which) so if you're an historian�  you'll need to modify the routines to work around that little chronological�  blip. The reason I've not messed with it is two fold:�    1) I don't plan on going back that far�    2) that 11 day blip is ONLY good in so many countries.�  Other countries and/or religious and/or ethnic groups did things differently�  so the whole sheebang gets totally mind boggling if one wants to make this�  routine work 100% for all conditions.��  The benefits of storing dates in this manner are many fold and not limited to�  the list below:�    1) DayOfTheWeek = (Days MOD 7) ' Sunday = 0 and Saturday = 6�    2) The system is country independent�    3) ToDay +  7 = SameDay_NextWeek�       ToDay + 28 = SameDay_NextMonth (4 weeks)�    4) Validation of an incoming date is fast and quick using the same�       two routines and comparing the returned Y,M,D with what was�       sent. (You need to build such a checking routine)��  fYMD2Days&  returns the number of days since 1-1-0001�  fDays2YMD&  returns the year, month, day and day of the week for a day number�  fJulianDay& returns the day number in a given year�  fLeapYear&  returns 0 or 1 if the year is, in fact, a leap year.��  There's one more 'trick' you can use. If you're only going to be dealing with�  this code in a business situation and won't have to worry about archaic dates�  then you can store only the LOW WORD and add/subtract the HI WORD�  automatically. This will cut your storage space in half. Your first�  acceptable date would be 1-1-1877 and run through 6-6-2056. You'll add or�  subtract &hA748B from the incoming/outgoing day counts and store returned�  value in a WORD.�    (NOTE: Remove the REMed values in fYMD2Days and fDays2YMD)��  Hope these routines help you out.��  d83)��$endif��DECLARE FUNCTION fLEAPYEAR  (BYVAL Year AS LONG) AS LONG�DECLARE FUNCTION fYMD2Days  (BYVAL Year AS LONG,BYVAL Month AS LONG,BYVAL Day AS LONG) AS LONG�DECLARE FUNCTION fJulianDay (BYVAL Year AS LONG,BYVAL Month AS LONG,BYVAL Day AS LONG) AS LONG�DECLARE FUNCTION fDays2YMD  (BYVAL Days AS LONG,SEG Year AS LONG,SEG Month AS LONG,SEG Day AS LONG) AS LONG��'---------------------------------------------------------�'------- start of test code ------------------------------�'---------------------------------------------------------��%QualityCheck = 0��FUNCTION PBmain ()��  LOCAL Y1  AS LONG�  LOCAL M1  AS LONG�  LOCAL D1  AS LONG�  LOCAL Y2  AS LONG�  LOCAL M2  AS LONG�  LOCAL D2  AS LONG�  LOCAL Dz1 AS LONG�  LOCAL DoM AS LONG�  LOCAL T1  AS SINGLE��  fDays2YMD 2147483647, Y1, M1, D1�  PRINT "These routines are Y5M compliant!"�  PRINT "The last date serviced is ";�  PRINT FORMAT$(Y1,"#,###,###\-");�  PRINT FORMAT$(M1,"00\-");�  PRINT FORMAT$(D1,"00")��  T1 = TIMER�  FOR Y1 = 1 TO 4000�$if %QualityCheck�    IF (Y1 MOD 100 ) = 0 THEN PRINT Y1�$endif�    DoM = &h3DFF7F9F�    IF fLeapYear(Y1) THEN BIT SET DoM, 5�    FOR M1 = 1 TO 12�      FOR D1 = 1 TO (DoM AND 31)�        Dz1 = fYMD2Days(Y1,M1,D1)�        fDays2YMD Dz1, Y2, M2, D2�$if %QualityCheck�        IF INSTAT THEN GOTO BailOut�        IF (Y1 <> Y2) OR (M1 <> M2) OR (D1 <> D2) THEN�          PRINT "ERROR"�          PRINT Dz1�          PRINT Y1, M1, D1�          PRINT Y2, M2, D2�          GOTO BailOut�        END IF�$endif�      NEXT�      SHIFT RIGHT DoM, 5�      IF DoM = 0 THEN DoM = &h3FEFFBFF�    NEXT�  NEXT�  T1 = TIMER - T1��  BailOut:�    PRINT STRING$(79,45)�    PRINT FORMAT$(Dz1, "Checked #,###,###,### days in " );�    PRINT FORMAT$(T1, "###.#### seconds")�    PRINT "<<DONE>>";�    INPUT FLUSH�    WAITKEY$��END FUNCTION�'---------------------------------------------------------�'------- end of test code --------------------------------�'---------------------------------------------------------��FUNCTION fDays2YMD (BYVAL Days  AS LONG, _�                      SEG Year  AS LONG, _�                      SEG Month AS LONG, _�                      SEG Day   AS LONG  ) AS LONG��  LOCAL D   AS LONG�  LOCAL DoM AS LONG��  Year  = 1                                              'load/reset outgoing params�  Month = 1                                              '�  Day   = Days -1  ' + &hA748B                           'unREM if using WORDs�                                                         '�  IF Day > 146096 THEN                                   'check for Epochs (400years)�    Year = Year + (Day \ 146097) * 400                   '�    Day  = (Day MOD 146097)                              ' take what's left�  END IF                                                 '�  IF Day > 36523 THEN                                    'check for centuries (100years)�    D = (Day \ 36524)                                    ' number of centuries�    IF D < 4 THEN                                        '  we're working�        Year = Year + (D * 100)                          '�        Day  = (Day MOD 36524)                           '�      ELSE                                               '  we're on an even number of days�        Year = Year + 300                                '�        Day  = 36524                                     '   reset day count�    END IF                                               '�  END IF                                                 '�  IF Day > 1460 THEN                                     'check olympiads (4years)�    Year = Year + (Day \ 1461) * 4                       '�    Day  = (Day MOD 1461)                                '�  END IF                                                 '�  IF Day > 364 THEN                                      'check years�    D = (Day \ 365)                                      ' number of years�    IF D < 4 THEN                                        '  we're working�        Year = Year + D                                  '�        Day  = (Day MOD 365)                             '�      ELSE                                               '  we're on an even number of days�        Year = Year + 3                                  '�        Day  = 365                                       '  reset day count�    END IF                                               '�  END IF                                                 '�  INCR Day                                               ' put back lost day�                                                         '�  IF Day > 31 THEN                                       'compute month number (Month = 1 now)�    DoM = &h3DFF7F9F                                     ' binary days of the months�    IF Day > 58 AND fLeapYear(Year) THEN BIT SET DoM, 5  ' it's leap year so Feb gains a day�    DO                                                   ' start checking�      D = (DoM AND 31)                                   '  strip off day count for the month�      IF D => Day THEN EXIT LOOP                         '  we have a winner!�      Day = Day - D                                      '  reduce days left by day count�      INCR Month                                         '  add a month�      SHIFT RIGHT DoM, 5                                 '  shift day count into position�      IF DoM = 0 THEN DoM = &h3FEFFBFF                   '  July is next so load last 6 months�    LOOP                                                 '�  END IF                                                 '�                                                         '�  FUNCTION = (Days MOD 7)                                'RETURN day of the week��END FUNCTION��FUNCTION fYMD2Days (BYVAL Year  AS LONG, _�                    BYVAL Month AS LONG, _�                    BYVAL Day   AS LONG  ) AS LONG��  DIM DoM AS LONG��  IF Month > 1 THEN Day = fJulianDay(Year,Month,Day)     'compute Julian day�  DECR Year                                              'don't count 'this year'�  Day = Day + (Year * 365) + _                           ' add full years�              (Year \   4) - _                           ' add a day for each olympiad�              (Year \ 100) + _                           ' subtract a day for each century�              (Year \ 400)                               ' add a day for each epoch�                                                         '�  FUNCTION = Day ' - &hA748B                             'RETURN day count�                                                         '  unREM to use WORDs�END FUNCTION��FUNCTION fJulianDay (BYVAL Year  AS LONG, _�                     BYVAL Month AS LONG, _�                     BYVAL Day   AS LONG  ) AS LONG��  DIM DoM AS LONG��  IF Month > 1 THEN                                      'if still Jan then nothing to do�    DoM = &h3DFF7F9F                                     ' load in days of the months Jan - Jun�    IF Month > 2 AND fLeapYear(Year) THEN BIT SET DoM, 5 ' check for leap year & add 1 to Feb�    DO                                                   ' start counting�      Day = Day + (DoM AND 31)                           '  strip off day of the month�      IF Month = 2 THEN EXIT LOOP                        '  end of search�      DECR Month                                         '  subtract a month�      SHIFT RIGHT DoM, 5                                 '  shift day count into position�      IF DoM = 0 THEN DoM = &h3FEFFBFF                   '  July is next so load last 6 months�    LOOP                                                 '�  END IF                                                 '�                                                         '�  FUNCTION = Day                                         'RETURN Day number for the year��END FUNCTION��FUNCTION fLeapYear (BYVAL Year AS LONG) AS LONG��  IF ( ( Year MOD   4 ) = 0 ) AND _                      'a leap year�     ( ( Year MOD 100 ) > 0 )  OR _                      'not a century�     ( ( Year MOD 400 ) = 0 ) THEN FUNCTION = 1          'or it _is_ an Epoc��END FUNCTION�Greg Turgeon                   GENERATES 32-BIT CRC           gturgeon@compuserve.com        03-19-99 (23:35)       PBCC                   149  4064     CRC32_CC.BAS$IF 0�+--------------------------------------------------------------------------+�| WESTFORD CUSTOM PC/FX         -*-   CRC32_CC.BAS  -*-            3/19/99 |�| gturgeon@compuserve.com |------------------------------------------------+�| 978-692-8163 |----------+�+--------------+�   �   This file contains the following routines:��         SUB CRC32Init()   �         SUB BuildCRC32TABLE()�         SUB CRC32(BYVAL pBuffer???, BYVAL BuffLen&)�         FUNCTION CRC32Retrieve???()�   �   The CRC function employs the CCITT-32 polynomial 0EDB88320h and �   therefore generates the same CRC values as do PKZIP and ARJ.��   The code requires PBCC.EXE to compile. This file can be simply �   $INCLUDEd at the top of the main module file for any PBCC project.��   To use:��   The first call to CRC32Init() initializes the required table of values.�   It also initializes CRC_CURRENT???, which should not be manipulated �   directly by the application. Subsequent calls to CRC32Init() �   reinitialize CRC_CURRENT???.��   The primary CRC process is executed in the subroutine �   CRC32(BYVAL pBuffer???, BYVAL BuffLen&), which accepts a pointer to �   the target data and long integer specifying data length.��   The function CRC32Retrieve???() returns the current CRC value �   (properly normalized) but does not clear or reinitialize the current �   value. Reinitializing is accomplished only through CRC32Init().��$ENDIF���DEFLNG A-Z�'============�$IF NOT %DEF(%NULL)�   %NULL = 0�$ENDIF��GLOBAL CRC32TABLE???(), pTABLE???, CRC_CURRENT???��DECLARE SUB CRC32Init()�DECLARE SUB BuildCRC32TABLE()�DECLARE SUB CRC32(BYVAL pBuffer???, BYVAL BuffLen&)�DECLARE FUNCTION CRC32Retrieve???��'====================�SUB CRC32Init()�if pTABLE??? = %NULL then�   redim CRC32TABLE???(255)�   call BuildCRC32TABLE�   pTABLE??? = varptr(CRC32TABLE???(0))�end if�CRC_CURRENT??? = &h0ffffffff�END SUB��'====================�FUNCTION CRC32Retrieve???�function = NOT CRC_CURRENT???�END FUNCTION���'=========================�SUB CRC32(BYVAL pBuffer???, BYVAL BuffLen&)��!  push     ebx�!  push     esi�!  push     edi��!  mov      edx, CRC_CURRENT???     ;edx holds current CRC throughout�!  mov      ecx, BuffLen&�!  test     ecx, ecx�!  jz       short CRCDone�!  mov      edi, pTABLE???�!  mov      esi, pBuffer???�!  inc      ecx                  ;add 1�!  shr      ecx, 1               ; \2�!  jc       short CRCTop         ;if originally even number of bytes to process��!  mov      al, byte ptr [esi]   ;do odd byte here�!  inc      esi�!  xor      ebx, ebx�!  mov      bl, dl�!  xor      bl, al�!  shr      edx, 8�!  xor      edx, [edi + 4 * ebx]�!  dec      ecx�!  jz       short CRCDone�CRCTop:�!  mov      ax, [esi]            ;al = [byte ptr esi]�!  xor      ebx, ebx�!  mov      bl, dl�!  xor      bl, al�!  shr      edx, 8�!  xor      edx, [edi + 4 * ebx]��!  mov      al, ah               ;al = [byte ptr esi+1]�!  xor      ebx, ebx�!  mov      bl, dl�!  xor      bl, al�!  shr      edx, 8�!  xor      edx, [edi + 4 * ebx]��!  inc      esi�!  inc      esi�!  dec      ecx�!  jz       short CRCDone�!  jmp      short CRCTop�CRCDone:�!  mov      CRC_CURRENT???, edx�!  pop      edi�!  pop      esi�!  pop      ebx�END SUB���'=========================�SUB BuildCRC32TABLE()�'-- Builds necessary table of dword values�'-- The table itself is never altered and thus�'--  must be constructed only once�REGISTER b&, value???�LOCAL    CRC32Polynomial???, a&�LOCAL ppoly AS DWORD PTR, parray AS DWORD PTR��CRC32Polynomial??? = &hEDB88320�ppoly = varptr(CRC32Polynomial???)��parray = varptr(CRC32TABLE???(0))��for a& = 0 to 255�   value??? = a&�   for b& = 8 to 1 step -1�      if istrue(value??? AND 1) then�         value??? = (value??? \ 2) XOR CRC32Polynomial???�      else�         shift right value???, 1�      end if�   next b&�   @parray[a&] = value???     '-- CRC32TABLE???(a&) = value???�next a&�END SUB��'-- END CRC32_CC.BAS�Jeroen van Rijn                AUTOMATE LAST UPDATE OF WEBPAGEsolstice@xs4all.nl             04-11-99 (21:14)       PBCC                   84  5460     UPDATED.BAS ' Automatically update the last line on webpage that tells the user�' when it was last updated... for PB/CC 1.0�DEFINT A-Z:DIM SHARED K,S,B&,Z&:V1 'Created by PostIt! 7.2�SUB V1:OPEN "O",1,"UPDATED.ZIP",4^6:Z&=3732:?STRING$(50,177);�U"%up()%9%'%#-%:w8ZKRR-2TQ'7%%Z*%%%0%I%%D?M30C4J3S10bB&yT,=Se58Ll�U"[DjkDaQu=+e5EJem]M(V<f5,D-P;Mt:rDw_BPqRi8hKs':w,*nFH:)G_Ui0BUdW�U"RVS?5?&-%6BdIz_5:]1?/\MCi8GLX2<m.oCUmq?GvLNKqNV(R6'AA]3%AW[^dB0�U"53f%Lx])biRacTB+c.VIv0akV(1A$'I&$t%JQZUb3;=Vp6\ygf;ALn*V<iMbvq=�U"gY>K9)Nw)Q9=;e&DB35S#fzdN0;1qn+#%AkGI+4LmR,L)PWO0kU$zMe$*pj=^sn�U"D\+p43BEho^x6:NL$+1]YTKj\b:/-Cov-Kj'jN%21W67W/hE_0BN3nx,;lWF$;m�U"+QD9.[s*Z5e6Yb/NTA+WajBL-#721zv.59dn_^zd>Z^k\YdDa<e(%=vS&>T4[Nc�U"Th\r1Xoj?iq(2ctlNG7),DUmMa472M[jtYdiC$0O?RY>paB-hoMOm%.;aK;+z\u�U"CuDAi)qD3?5ABS+:*%9HrB#X<s0IyCR7GFlO2$,,F2GsA&8dY)OGpbwK?nu+pew�U"gK2oduS%hDC:v#X.LxZ5m.Sb')SkfEkfZV]%-^]HzXv:$17<O8%%4\)B6vD<,L=�U"HUxMoYXeFtV&?:.&N[G'9<Zx]_W%5fS(YOdNxhvri+>c*sk,S#T6Jb9Ry.,Z%EQ�U"KL\?ph)3R5_<aJuMWck.2]*PuylDq8^>En;YLYhs+VeR/AuBx?3M%(up(%)9%'#�U"%-%hDuZKLL'S)r[%%%a%%%%0#%%%DM?30CD43S2M56L^063RU11SFI-W:oJL+UU�U"p%Qzeqg1ly7AP&(x[q7JbL4>.'&ysBQV(vlL&6J$$3%DiM4,AIW>daBiNkq%rdZ�U"6IDrO&[I*/4v;AjopLW>XYT#&=hS\V#UK.%23>\CPM2q(cU(ip+SR3L'X*.ZlJ3�U"8ehMb4Zh?gW_rZN/s0Hpg+m7Y>uh_\n)nU?<fWh4DA-G>Upm$8N[M*M%%up(%)9�U"%'%%-%y_=UK:RwoGZ[&%%w%'%%0#%%%DM?30CD43S8;2>>v*6]#FF5wU8D_ZU)m�U"N73[M%&t3dXJTl)7M)xmG/8;A(yPYQn\+80XzfR?A)7[nD+_$<t5q>L%c[#u-ak�U"/g(MWxdN_Ywm;zq/$^]$uLhe<18(C'4=.'PP5]#rUh<j7f?Zsayd\Ux.SkxChl+�U"DQHSB'_m_pC64B_8XW.'qM'6K$zSkT:tYgWn_,#3AOZ$nWUlV:'O)VZ6oEQgb)X�U"/%N/pP*3-9,Lg*[D)bt02t)j9]9lW,F3pj?;*Y#A4rKpbo&jgs-:5t#Z7PC,HY$�U"T+=[%mCCLaEW5IFMUAQ,&a]xZ/^hPP.?p5?q,rLMaqkLM4rC%-Y:S>)XeDD(LHa�U"%ocSrZuTSoOgCCWs7^c0/oR7FrQ#QaB1o8b]-iKVaisB9)HDqh3WVf>AGRk[q[7�U"JZ,-\+HuWMat+aI7-i]xIIj#$+QM96aV<IsMYE*xl(9o8x-#CYNIEAi&_6Fx)H+�U"'8OM:Q\9.wE*e,t4$>,jG4'$knn7kmin^%Tup(%)9%'%%-%($4WK0Ep$zh#(%%s�U"%,%%0#%%%DM?30C)43Su7gw>y*6>9lF9xR:Ps%[a^B,w%.M=$KmD7SD1u/<I+,R�U"k=2$O;g*aq8[W?/GeA<eY$rDc0^890lLV/<<8C:lpc]8EjCO9b1VLY3t;tMh&8C�U"3;N,q5>_F>JhpcP6_?Ib1?,ibal:$UT7?>Ud^25T$hmnR%#hbAMj?a]WFB?PHuO�U"dc0]Gt,l+Dt'9ddk^C[YrIALNDqQ+kwgp1l;Q:qdXVNGA1kVuBxJ_d\zPg;DM^\�U"scQ/ucIA=vv?6P.<2o%d1+2h$^jfNf<;;mm^.wFuP2$7ti+EcAc_H9,QHr=C^]\�U"9t>I<t\B/1;%HH^^=bEATH'Rj(<Mv]W1q9%$8VapL8fc]):[9fBxjWwQC+WlYZ<�U"7wQDKgY%%<?zMf*4H.s%0?C+HTx:q(O)[EsrI<pbV&$rIu=$avf_XLnRyY/'(lj�U"#FcX%RpL(2#N^T>cpuv'm1\.t6e41L:_>$,pw0pmv1-U)HjI=6xtcDr0SxL?s>Y�U"ZP?WFM:A_X>gyRyF++1]sQ<O].)&Dz=1TsL?dWo,*=egS=R21;eLP(>3PKg'aiP�U"eE1<ASG>m8=PK$]qM%J\X09S[^#ASqMvo1[x0gc\nCXY],MGIk*(crk=5BoakM4�U"AjvO6[l%iIF;W09m'1?dQQT[E:aS-8m&5N]F((KOjSY44[vT-,BFk%m56?r\lqX�U"V5^$:h66^k)aN7XZccX?Q70$_T><gurK]7FdF9n/pWnM?r\Gn_jJO,7]]_$FI9S�U"sT+(E%2:Zia1PWO;*SH>Ig[C>e^VNaK?jGCVtx_>['ZHKCLWH6=xd36jHgrtVU5�U"s2mt5.Y:m6W34c(qqAL;2jiFY[c3MgXon>sS8^R1Z'SmsPG98qsY[D]&JW6^l(H�U"iphHo0^&ZbZI=q'1J?^*%'G$p7\&/H-qpB(plyBq;\hWF4U1EFb,H?WIE;i-2QX�U"b^Tb:9g'P$Gk9(Ksqtd=UQw^SYE[RmZ8tS\hF4exVNFjxK_bunb4pJXh4\9R<N]�U"K>TSaQz0r,Kca9d;jOBE$NOi3YVue#j$9-mG752n-1iT'qhrvvqdWq[j>CO93^i�U"bJLa2M+4k&.Xdp8NrxI<c2Oc)v6$tM9D68)J.HQ/7yz\OxaFIU+B]me9Z.cTr1#�U"KKt[kC%<SFaZ1HtFSBrHAXr4K3UG$=9Xz4m_*sN&u%p()9%%'%-R%w2W.KY&6+9�U"B&%(%o(%%%/%%L%D?3M0C43LSA2TLw,>j.U9LlK[d+H(Tjyv*+44aYuY%;#1uEs�U"&bKj;KUI-XM\;v,6wv1g6K'8\U.ht#KGb?K,,$B<5D4:5AWgRF/yk>hk+#D'<(0�U":j%HDZ)Mnp$w%fm(2rP,Do*9:NY*%s'#KA;PDP,D:531<?&<mFPoPTCBl)*iI>i�U"=0e;(a^KJG\5h1Lzy1(EJ(66BbWsvI>1X\),6?LnCM9as/u\\F_rQZW_0r)9Dw+�U"'5y%'S9[YC;i>v^#G9rHvmurD^jIH,$2UMXx9P&1nH+i#_];MSO4xW1QV%amla8�U"]1kW#MY^$bg1N%L%eZ+n_9m+M0B8Ntc<$A+B$sb_&[5:kWi&5*R<vDgncH?:-S6�U"rc)jGV)7R3rk3bd/S/dCZ96M_?<AlTF.*UwL):nLmA>'\^7kN79_,)z76l;.HeJ�U"$Idnm?FfSuEtg(#2slr]k;Hts([eQEO(AwI/Ge/'5u2fG2sMx'R*kugDhc<Rf')�U"PP^Z=f'wdpT&+R?N_(#92R8LT)_uh;U,PU&R2U(3nUXZMyMxViNNBUtB\xf$s0H�U"ePTdbG-h3kP%MD*M?'hHI\ik[a>.vj,%up()%9%'%R-%GxeZK$v2J4G'7%%p)%%�U"%0%I%%D?M30C4J3S3>_2LyT,9UU58L\qDJUR30HRSnj'I7[p='Tm';P_/DXETk)�U"b\%VKp]]lnIBnJ<[mD1+gafBG;k#XzMQ3ddKn?SxD/7)P)qx(vJ/t(i,sBGTK)?�U"fKfae7.1[&bwg?aE+5+M7-joM7(OKh=>%TsTsrr%/D5J*eU.-,)]SQc/PA:]^P_�U"1SjGUFZU6-t3'?4Pdzn^PcK5DCwBx^w-d4MBpD5cmx_vJ_;tP:L0YfKvVVtX<2Y�U"ve*CAA)jeYDP5,(i)CVMbBPX+zDd$U1(4,te)\[<9DcxfiU7JHmBb]7eRA5;/7:�U"n9rgg\)\GoE_s'3Y>?e]4nUfQ;w6:1RK?I/.%EM)c+<OuMSg6+0e*$_'l+.*T,+�U"J[<)0CD,-$maP%L830H*r9RY%%B?vXNC?.YDe.pZpS5PC)=HO8>=s64'oj>BNLW�U"lt%U3OYFxSyvak2=^tL,#*<$-Aw9mSICMv>#4/jb<waXqN^]u%EO1,Dh;X<i6XY�U"vF6vdl;b#XCD+;\I)QGq^sOLJwf6#n<jddCk)JE0\&zRcs)1*0rVI&<.d'&RLbK�U"I^(BlE]AFqGjPED;XKv7.uVus+hYrfHnq2kji2pE?\sZ<QU13dP1o((7TSV'v[t�U"9z>mT$7*$x%JH%WkjPd;mSfY%CYF[T'T3h&$-(ca'r*qfcb8]^ptDuD=fQ/8;?U�U"M/dJk$<FEj]A_Ed'__Yss:5V\1AYmg56m5ka(f-p;+%nRMKKNMq#IP5uEZe<-$4�U"'Ct=gqq$b:&XS%P/NoRUDI<ln&tGbPd\gY8W3fDaF6T&X;KC#aKN%&up&%'9%9%�U"%'%-I%:wZaKRR2'TQ'%+%Z*%%%0%%%%%%%%%%%E%%%%%#%%%DM?30CD43S1)0Bu�U"p%&'9%%9%'%I-%hu/ZKL'2S)r%7%%a%%%%0%%%%%%%%%%%%E%%%%z'%%MD?302C�U"43S2256u%p&'9%%9%'%%-%y_=UK:RwoGZ[&%%w%'%%0%%%%%%%%%%%%E%%%%F(%�U"L%D?3M0C43LS82>%up&'%9%9%%'%-%4(4WK60p$z&h(%%&s,%%%0%%%%%%%%%%%�U"E%7%%N)I%%D?M30C4&3Sug%wup&%'9%9%%'%-R%w2W.KY&6+9B&%(%o(%%%/%%%�U"%%%%%%%%E#%%%f#-%%DM?30CD43SA&2up&%'9%9%%'%-O%GxZUK$vJ)4G'%+%p)�U"%%%0%%%%%%%%%%%E#%%%W#/%%DM?30CD43S3)>2up%*+%%%%%+%%+%z&%%%N2%%�U"%%%�END SUB�CLOSE:IF S=250AND B&=Z&THEN?" :) Ok!"ELSE?" :( Bad!�SUB U(A$):FOR A=1TO LEN(A$):C=ASC(MID$(A$,A))-37:IF C<0THEN C=91+C*32�IF K<4THEN K=C+243ELSE?#1,CHR$(C+(K MOD 3)*86);:K=K\3:B&=B&+1�S=(S+C)AND 255:NEXT:LOCATE,1:?STRING$(B&*50\Z&,219);:END SUB�Dave Navarro, Jr.              UCASE/LCASE FOR PBDLL/PBCC     dave@powerbasic.com            06-01-99 (15:43)       PBCC, PBDLL            14   616      CASE.BAS    DECLARE FUNCTION CharUpperBuff LIB "USER32.DLL" ALIAS "CharUpperBuffA" (lpsz AS ASCIIZ, BYVAL cchLength AS LONG) AS LONG�DECLARE FUNCTION CharLowerBuff LIB "USER32.DLL" ALIAS "CharLowerBuffA" (lpsz AS ASCIIZ, BYVAL cchLength AS LONG) AS LONG��' Convert a string to upper case using Windows international support�'�FUNCTION UcaseI$(BYVAL temp AS STRING) AS STRING�  CharUpperBuff BYVAL STRPTR(temp), LEN(temp)�END FUNCTION��' Convert a string to lower case using Windows international support�'�FUNCTION LcaseI$(BYVAL temp AS STRING) AS STRING�  CharLowerBuff BYVAL STRPTR(temp), LEN(temp)�END FUNCTION�Dave Navarro, Jr.              32-BIT CRC CODE FOR PBDLL/PBCC dave@powerbasic.com            06-01-99 (15:43)       PBCC, PBDLL            98   5237     CRC32.BAS   '==============================================================================�'�'  32-bit CRC code for PB/DLL and PB/CC�'  Copyright (c) 1998 PowerBASIC, Inc.�'�'  Calculates a 32-bit CRC compatible with PKZIP and ZMODEM.�'�'==============================================================================��FUNCTION Crc32(BYVAL Address AS DWORD, _�               BYVAL Length AS LONG, _�               BYVAL Seed AS LONG) AS LONG��  ! mov     ESI,Address             ; address in ESI�  ! mov     EDX,Seed                ; put seed in EDX�  ! mov     ECX,Length              ; length in ECX�  ! jecxz   CrcDone                 ;�  ! xor     EBX, EBX                ; clear EBX�CRCLoop:�  ! lodsb                           ; get next byte from data block�  ! movzx   EBX,DX                  ; put low word of CRC in BX�  ! xor     BL,AL                   ; xor byte with BL�  ! shr     EDX,8                   ; clear high 8 bits of EDX�  ! shl     EBX,2                   ; multiply BX * 4�  ! xor     EDX, CS:CrcTable[EBX]   ;�  ! loop    CRCLoop                 ; loop until ecx=0�CrcDone:�  ! mov     FUNCTION, EDX           ;��  EXIT FUNCTION��CrcTable:�  ! DD &H000000000&, &H077073096&, &H0EE0E612C&, &H0990951BA&�  ! DD &H0076DC419&, &H0706AF48F&, &H0E963A535&, &H09E6495A3&�  ! DD &H00EDB8832&, &H079DCB8A4&, &H0E0D5E91E&, &H097D2D988&�  ! DD &H009B64C2B&, &H07EB17CBD&, &H0E7B82D07&, &H090BF1D91&�  ! DD &H01DB71064&, &H06AB020F2&, &H0F3B97148&, &H084BE41DE&�  ! DD &H01ADAD47D&, &H06DDDE4EB&, &H0F4D4B551&, &H083D385C7&�  ! DD &H0136C9856&, &H0646BA8C0&, &H0FD62F97A&, &H08A65C9EC&�  ! DD &H014015C4F&, &H063066CD9&, &H0FA0F3D63&, &H08D080DF5&�  ! DD &H03B6E20C8&, &H04C69105E&, &H0D56041E4&, &H0A2677172&�  ! DD &H03C03E4D1&, &H04B04D447&, &H0D20D85FD&, &H0A50AB56B&�  ! DD &H035B5A8FA&, &H042B2986C&, &H0DBBBC9D6&, &H0ACBCF940&�  ! DD &H032D86CE3&, &H045DF5C75&, &H0DCD60DCF&, &H0ABD13D59&�  ! DD &H026D930AC&, &H051DE003A&, &H0C8D75180&, &H0BFD06116&�  ! DD &H021B4F4B5&, &H056B3C423&, &H0CFBA9599&, &H0B8BDA50F&�  ! DD &H02802B89E&, &H05F058808&, &H0C60CD9B2&, &H0B10BE924&�  ! DD &H02F6F7C87&, &H058684C11&, &H0C1611DAB&, &H0B6662D3D&�  ! DD &H076DC4190&, &H001DB7106&, &H098D220BC&, &H0EFD5102A&�  ! DD &H071B18589&, &H006B6B51F&, &H09FBFE4A5&, &H0E8B8D433&�  ! DD &H07807C9A2&, &H00F00F934&, &H09609A88E&, &H0E10E9818&�  ! DD &H07F6A0DBB&, &H0086D3D2D&, &H091646C97&, &H0E6635C01&�  ! DD &H06B6B51F4&, &H01C6C6162&, &H0856530D8&, &H0F262004E&�  ! DD &H06C0695ED&, &H01B01A57B&, &H08208F4C1&, &H0F50FC457&�  ! DD &H065B0D9C6&, &H012B7E950&, &H08BBEB8EA&, &H0FCB9887C&�  ! DD &H062DD1DDF&, &H015DA2D49&, &H08CD37CF3&, &H0FBD44C65&�  ! DD &H04DB26158&, &H03AB551CE&, &H0A3BC0074&, &H0D4BB30E2&�  ! DD &H04ADFA541&, &H03DD895D7&, &H0A4D1C46D&, &H0D3D6F4FB&�  ! DD &H04369E96A&, &H0346ED9FC&, &H0AD678846&, &H0DA60B8D0&�  ! DD &H044042D73&, &H033031DE5&, &H0AA0A4C5F&, &H0DD0D7CC9&�  ! DD &H05005713C&, &H0270241AA&, &H0BE0B1010&, &H0C90C2086&�  ! DD &H05768B525&, &H0206F85B3&, &H0B966D409&, &H0CE61E49F&�  ! DD &H05EDEF90E&, &H029D9C998&, &H0B0D09822&, &H0C7D7A8B4&�  ! DD &H059B33D17&, &H02EB40D81&, &H0B7BD5C3B&, &H0C0BA6CAD&�  ! DD &H0EDB88320&, &H09ABFB3B6&, &H003B6E20C&, &H074B1D29A&�  ! DD &H0EAD54739&, &H09DD277AF&, &H004DB2615&, &H073DC1683&�  ! DD &H0E3630B12&, &H094643B84&, &H00D6D6A3E&, &H07A6A5AA8&�  ! DD &H0E40ECF0B&, &H09309FF9D&, &H00A00AE27&, &H07D079EB1&�  ! DD &H0F00F9344&, &H08708A3D2&, &H01E01F268&, &H06906C2FE&�  ! DD &H0F762575D&, &H0806567CB&, &H0196C3671&, &H06E6B06E7&�  ! DD &H0FED41B76&, &H089D32BE0&, &H010DA7A5A&, &H067DD4ACC&�  ! DD &H0F9B9DF6F&, &H08EBEEFF9&, &H017B7BE43&, &H060B08ED5&�  ! DD &H0D6D6A3E8&, &H0A1D1937E&, &H038D8C2C4&, &H04FDFF252&�  ! DD &H0D1BB67F1&, &H0A6BC5767&, &H03FB506DD&, &H048B2364B&�  ! DD &H0D80D2BDA&, &H0AF0A1B4C&, &H036034AF6&, &H041047A60&�  ! DD &H0DF60EFC3&, &H0A867DF55&, &H0316E8EEF&, &H04669BE79&�  ! DD &H0CB61B38C&, &H0BC66831A&, &H0256FD2A0&, &H05268E236&�  ! DD &H0CC0C7795&, &H0BB0B4703&, &H0220216B9&, &H05505262F&�  ! DD &H0C5BA3BBE&, &H0B2BD0B28&, &H02BB45A92&, &H05CB36A04&�  ! DD &H0C2D7FFA7&, &H0B5D0CF31&, &H02CD99E8B&, &H05BDEAE1D&�  ! DD &H09B64C2B0&, &H0EC63F226&, &H0756AA39C&, &H0026D930A&�  ! DD &H09C0906A9&, &H0EB0E363F&, &H072076785&, &H005005713&�  ! DD &H095BF4A82&, &H0E2B87A14&, &H07BB12BAE&, &H00CB61B38&�  ! DD &H092D28E9B&, &H0E5D5BE0D&, &H07CDCEFB7&, &H00BDBDF21&�  ! DD &H086D3D2D4&, &H0F1D4E242&, &H068DDB3F8&, &H01FDA836E&�  ! DD &H081BE16CD&, &H0F6B9265B&, &H06FB077E1&, &H018B74777&�  ! DD &H088085AE6&, &H0FF0F6A70&, &H066063BCA&, &H011010B5C&�  ! DD &H08F659EFF&, &H0F862AE69&, &H0616BFFD3&, &H0166CCF45&�  ! DD &H0A00AE278&, &H0D70DD2EE&, &H04E048354&, &H03903B3C2&�  ! DD &H0A7672661&, &H0D06016F7&, &H04969474D&, &H03E6E77DB&�  ! DD &H0AED16A4A&, &H0D9D65ADC&, &H040DF0B66&, &H037D83BF0&�  ! DD &H0A9BCAE53&, &H0DEBB9EC5&, &H047B2CF7F&, &H030B5FFE9&�  ! DD &H0BDBDF21C&, &H0CABAC28A&, &H053B39330&, &H024B4A3A6&�  ! DD &H0BAD03605&, &H0CDD70693&, &H054DE5729&, &H023D967BF&�  ! DD &H0B3667A2E&, &H0C4614AB8&, &H05D681B02&, &H02A6F2B94&�  ! DD &H0B40BBE37&, &H0C30C8EA1&, &H05A05DF1B&, &H02D02EF8D&��END FUNCTION�Dave Navarro, Jr.              DISPLAY MONTH AND DAY NAMES    dave@powerbasic.com            06-01-99 (15:43)       PBCC                   27   584      MONTH.BAS   'Display month and day names from Windows international settings:���$INCLUDE "WIN32API.INC"��GLOBAL i AS LONG�GLOBAL s AS STRING��FUNCTION EnumCalendarProc(c AS ASCIIZ) AS LONG�  s = c�END FUNCTION��FUNCTION PbMain() AS LONG��  PRINT "Month names"�  FOR i = 0 TO 11�    EnumCalendarInfo CODEPTR(EnumCalendarProc), %LOCALE_SYSTEM_DEFAULT, 1, %CAL_SMONTHNAME1 + i�    PRINT "  "; s�  NEXT��  PRINT "Day names"�  FOR i = 0 TO 6�    EnumCalendarInfo CODEPTR(EnumCalendarProc), %LOCALE_SYSTEM_DEFAULT, 1, %CAL_SDAYNAME1 + i�    PRINT "  ";s�  NEXT��END FUNCTION�Dave Navarro, Jr.              WHOIS V1.0 - GET DOMAIN INFO   dave@powerbasic.com            06-01-99 (15:43)       PBCC                   59   1586     WHOIS.BAS   '==============================================================================�'�'  WHOIS v1.0 - Get domain information�'  Copyright (c) 1999 PowerBASIC, Inc. All Rights Reserved.�'�'  RFC 954 (www.cis.ohio-state.edu/htbin/rfc/rfc954.html)�'�'------------------------------------------------------------------------------�'�'  Server                 Domain suffix�'  ---------------------  -----------------------------------------------------�'  rs.internic.net        com, net, org�'  whois.nic.uk           co.uk, org.uk, net.uk, ltd.uk, plc.uk�'  whois.nic.gov          gov�'  whois.nic.mil          mil�'�'  whois.ripe.net         IP addresses�'�'==============================================================================��$database = "rs.internic.net"�%port     = 43��'------------------------------------------------------------------------------��FUNCTION PbMain() AS LONG��  LOCAL buffer AS STRING��  buffer = COMMAND$��  IF LEN(buffer) = 0 THEN�    STDOUT "WHOIS v1.0 - Internic Domain Lookup Utility"�    STDOUT "Copyright (c) 1999 PowerBASIC, Inc."�    STDOUT ""�    STDOUT "Usage: whois name"�    STDOUT ""�    STDOUT "Examp: whois powerbasic.com"�    EXIT FUNCTION�  END IF��  ' Connect to server (timeout after 3 minutes)�  TCP OPEN PORT %port AT $database AS #1 TIMEOUT 180��  IF ERR THEN�    STDERR "Error connecting to " & $database�    EXIT FUNCTION�  ELSE�    TCP PRINT #1, buffer�  END IF��  DO�     TCP RECV #1, 4096, buffer�     STDOUT buffer;�  LOOP WHILE LEN(buffer)��  TCP CLOSE #1��END FUNCTION�Don Schullian                  MENU ROUTINES FOR PB/CC        d83@DASoftVSS.com              05-30-99 (08:10)       PBCC                   251 16478    FMENUS.BAS  ' Menu Routines for PB/CC v1.0�DEFINT A-Z:DIM SHARED K,S,B&,Z&:V1 'Created by PostIt! 7.2�SUB V1:OPEN "O",1,"FMENUS.ZIP",4^6:Z&=12068:?STRING$(50,177);�U"%up()%9%'%%-%kr07Kx=60:]67%%fe%%%.%I%%5<24=DSh10B^k*vBTp[bw6aXv�U"Do)I8QJkc\^s_lzLC8[QJVp#L1sM7ijj$2PJAE[cGCUI3#lQwjV,.5DsMrT8LWU�U"4vp<S:69Rr>1pR2,OI6sTZaTJ>eL)h^KooSBRgH5EJhi9V\l^'UBDGYacvV?dKd�U"qo=w3hkN-mvDHmy,r*HA[iTdS\pDNuJ[q_2HrbJda$%Dw%Th41['sF1$JRuL*:3�U"G3zTxb50^^G'Xdaa6W/mm0W2.<bI)58%dV4VXMtr#2H8C:$U[<03c'8>t]cDr'[�U".y/_PX3P,ZkMMTWP7IXU,dJh&i0*e*CyA31I.QLOQX[CP%mqo[\.NI;pNuIL?07�U"O,PT2m\f(lbiFA_>6Ga<p'mXJ5sd,w$/$kHKM?cLT%jiC07j7jk<VivTk;eAV>I�U"4_bBDgS/1Hsb_Sq+5T2EU5aVL#mWJBe[3vH,juD^p'SZs\wISYwo5sD[kLKISvD�U"a'(frTg,V$s\BMy0>#qlQ(?V/&JD_h6\8Q3\AC3Q,-9#]bLb0jg7CQ\iQF5Wd==�U"jF;ljg22bQd0H8EnpH1Ymxgt*i.I1#W/g^r_f7*V;iKlN3DD1w3I<+W*ztO^E(y�U"he&)9gw;#dgw<B6f:-<gh:=fRUYknLR]1#llw2eY0NP+nNG\G7:RxEip'H5W%IA�U"S_\2upq#JAtr;=v(\(u:K:n/\rI<;LY4>_=2a90pucmAs<j5Nxu?lS9Yf\Yj/pC�U"QVZ*1]4Kdi4u=c$LUr?3h1pKhr<,>$0z)V_g+i:cUjq?2Be_i^3p\sF]M=<jmr6�U"rq4rtZQ^M[M)1MyqGHi]IANZReurAM4F((kRZIE3[N,KFsQ(D-pYq/oXZV'/BWp�U"9uq;#IKi:Ko8t6GGi5CTd5:FK$P310:JWq9sF<Lcfa6(;0i[)\=\<fd#$dDv^G+�U"U.xsJ1w7Nv82C=;Qg\KTqN3)FMHE_r57uBQ'B$vP6S-UH]HqypeRIx)W$YV#dAA�U"vl\3pCq*iUJ.$CiHo,qiaK>0,F[+G$*X;S9/4Ayx*^rXmt&WIU:Voaj\tG?KjL+�U"\ZJqku\7q=C.qh,?MYP,Kn/Gjn5j$9TZKSiGXqYMa?FALYtkviK?ABlXg2N&D>p�U"5/x:Xf:Cv0.=lx[aoN_B02(UykG9B\;Z'?+Cojk&k1kKU)*:k<3)TJ/Qu\)AQAL�U"oO'7F,^_M;'2CIH$5=#ApE9D<Jkf65ARmb8V&)Pt]h(=b<F1kC%bT%QJz>FS:5$�U"/?kZH%WrBPWA[>X&,ZZ#/2r>J<R/GJQ)r+3(-_aAls]u)Aa,JChawXxJ6#69E[j�U",)]BK80U>*(d/_VhG(6?h3g'kpRqSd1$DFmd/ek:hVS,rrEmPvHeRs.D=s7FurP�U"UH2eo9aG_ETDS(4_pFn^nfvm:lFsAl(0:ModN%2D+Xj]t1W([TroFz*v+,4=#jG�U"b7HS*QC/V3%A1D(QC/sMy5m6tv]haAFF%&/]Wb^ts=i=$.PDm\j=]Y)Tr,:Z43P�U"d_R6Dc^F&Iax*[z=DqeR,)):o)ejl?.,_()s214r?515?#aRlPWE<**&ZB'lZM*�U"XQ[^a/6oU=Jb#e9Pi3HwR/q1]C*FuFFM#7UJ)'sK3'S2>grh#+Xw-:X,):+nCx)�U"(-6*meMQHe2[Ypb98fs<)ZdW8:QpI*+$VD[J)_3?<$r%D#,Jk:X7dT?Oe^e6gL;�U"DsEU+,,R(QLKd(1w9Xqg0u'34*TyM[u=\sT=>_s:_xCZ.b;EqpaLlYTq3PD&7;I�U",5V+B]49RiJWSGIj44/xVKx(V*RCXZXj[\1E4oAe[D&lQfpf?Kk9qP\ZG5GL635�U"YZ.<d6m6)Ev#RDfwq)N[[9OmJ^bv;Y:?b$M*#$5_k*Kl\41oS7>91Mjppfjn/s3�U"#[AFY;U)iJ'TK7/',:pH6Cb#%Avl&kiu?[xosfvd-M3pGTQgBt6_Q/uQ7\e2[&?�U"y#g5X,>LD&9H\>SuS02m_&o$P7_/Vr6J'7j>d=k,(mVUUln<ZG]$(yN7s9J[T[X�U";p<0Ih3i-^a%ph2Y<9o$CG.J6]+rkC'u'mGe-s5p<rR)lPIChYq1>ikYF'URd4D�U"7V:]Ed+60:6uU;nr^wEjkH.YS'2%cxto<z;.qT.=r^K04WPi(G1I<rCy*wegfE?�U"xY(bmcwc&>;j.nQm/dHmBFL#Jyj?[7Y:)jwFD4PP<_4BEqjM)3lwX$C28dT;uh6�U"4Ye]+uJi6'U2D_,=oPJN(#=u#\]N>KYUSUpYIuaQ4Ze8qHCI4%Ug90V+#79>/vu�U"1JAaB\I(7UJKC*EH[<,z'DFX/>t^uzZS^xfYH)(i/.3p9S3[.ModDl-IaX0vNI_�U"V^R7*FMN,]>O3R3DZAiEW3]B-/FNQH?dZ.1u[s%(nBv?&4vl#k]B-&6Mscj\>XW�U"A_LkS=hL$\Ve?59eDjHGAKH-C;SK)(vFRS-y?w>/w]%>>8]B*NCYULRDBf[?1XO�U"ZZ(JY?y22%H\<3[B&I32b8__mT2$&prRC\ee=t:U.N^:94)jp_#<+2)0wrVK%d(�U"3aCFSBO#_p+M(0XiGa^$h]D,-#Kixy;Lo5qXnuol/Z79+/f\$72#me[XSVgQ;gU�U"K&.oh(IDbtA[JU,3BYdm.E'*M0A&&&STdR'in%XeovD^OW-)_13T&ZhPY02jK<^�U"TGknG]8IlN#%eS_/;S0gQP\A22L[6EDdRN^N_<tVX)L1cg*VpLNATZ*iAY3bxEU�U"NZITBD8v#7H^[+Qq-[)IHu8\=4gKb)o&Ii)oem$eJ-j>bXDhvL0h$o8OOEf7N6,�U":oY.2WwBOgU[Vn3o1C1E/Xugtxq,M5Aw^9qAb$ArIt=VOx0oboMr?.\1^&PDn[5�U"e,qpTs0lHB[Nyt/N_'XcY\v3W7%/3839s3Rd9BACZ]FS,jYJ,E:%WLj[aLx2T$y�U"g(bJ+I^B#1J:^Os;>IL4Nd8gfd)4kH44X^0bQb6B(N93_+RVg3?GZIBlAJDu?.Q�U"<)q\jnAj2;zFf^j'+zb^x7&BRuP3wZhnZc\,ezk\7]2XkV\Ya&]Uq-nEf'7N?AY�U"4SdHU[QX+;$LEg'1a2'C\P0Z2-&35'LjnY4Z:&=Eo(<q:==d7hiJNZy?.rPq(:O�U"Z6H\lRvvdh8\O0+HZHbk$F3e?u&ZqiSGbJ'(K[8FGY7RP(ru8?IF'/jq;U,GiA?�U"sSC/Zkw2&hq74wBjB>=pt81YxIa=qe2v/oXHeJXb4h7J1]4E3HQ)pCsUI2x1,m4�U";,jx4g$-&^*ts<jkTn>3MxH8sJOp'tM+>)*4g=#IFTmcr<KoC3m.FsNe,Z&ve0D�U"m.GQ>z/pFoeqcCEf62xsqacf;Lr88QD^FiWD\eC;uv$4SVbI)ctT\AUTev1i(-;�U"%Vfp6Jc2Z<=9nHxBB2nlPmoq#j/M6+d_-Yr:3Vu.hb3i$H=)[b/;ek?T5Odp7$N�U"r]f<MD]caM8q&;Vq-z<Pabw/gV^se>_h[BmvjvW;j;m'u?-xkwgl#o(jd$AhmkF�U"qX>?_EAk9bb=P\Stcv[*MAe6C9YB6.,JakN_(d&u6k+-C.OLXD(V'VOLZ#s.=]S�U"]+t-:BRE8[=Zp*4D%<1qj7a)8c%Dn%<G6jK+l61S_T>Yc)ybar:[:8W3%.r^.5G�U";r%el5Gze6c*;Z3/*NNC>Zj2kj2;B:BTet873w&\EVjZug]sUp^*al:pmiZfNrR�U"RS3/23s49iAuhXAM.r:x:1ysVc2ep/Wni+W-G,/spI2T&vN6rrQI;1lfm2-Y1Py�U"^jV9k+R?Y7hu3ijCW'-?c'.O,SiD?8Y/;8DLgN1CI[S#Tv2a3<$),V.>]Rf&D<V�U"Q1P/;W^']U%jVzy)\wM<kz?-o<iSrzg:2Gg#t1R=?OwEup#(nI*Gs#jN8fwOh]p�U"<B:mYN?sU=rqe?G*tV)T778s(l,E#9K;W3aLZuR&(h:xDh%9FKZ=4_V=]_hCSs^�U"F[l,&8Y1L$ivFxqqc6)6Th[h$1k24$L7Y-o(]2U<-Id8juR&2KiN&Prnw_A]e0v�U"tjH%Xx8xB3COl8Cub./XxoA3b,QYRTF4ok4$9-4CBb[Mh2+Q;e*g<nMbNm01E86�U"TmeKUv_Gr7c:9I(b7NBVtbq;aFS>1t0C.EL?WTigwvO$j&5xhi[w6uC7MU]6+Z0�U"''&9#G2cAv^oBzT-#Mtdo#\0-P>bu0n,8*psJW/dNAWVmNLz?7V9,N5rGjE%'Fw�U",_TmE]ETb++ChT&90<>rd7XOuvOW/%U^_89h8.,Szy>3hA2NiB#6>3h8'$h=00b�U"Ow3u&:MD%I(qC8;mc8>caau<(kV+WGqij:lmM;X_qw6.d;0-4FVmqzOEIyxj8C&�U"lOx[d=8xNVTMOC'loESw7b+.c%Qela,\a&T'O=d^Yr]q?q&F3ynBtC2j],ub;jo�U"PUpS+sac3n1ZTb]MFS04ENlGN75nfVjBdp]?0=]s0:hB(t'F<Ds8y3Uz=hU29Y,�U"%b,e<%/T?3o(>e1kzT0.-AJ=GQ3uk]Zen3mqyAQ'\D8N5:ksvvkf1c[O4<.vi?3�U"[W9wc4ViEyFfspe>RdnJPWbtJ-Y]j3(o]RAIMhFwsppzZ-$E)<]Eg),L2SRq-GR�U"\'(bQT>jn?#:bvM?AAulwr^Yua]%bO%UX_a*)tT]Wp6#6F_bkUeSNWoEJYTt,GK�U"FfoBfhlMx-;ACA2-^Y+87M1x)yDrYwsO2myV*d<nrsR5w?Bn.>-r6InAM;6T&_H�U"Mu19l8l9G*W[N]5SFtjwP\bZuSI.^'Ny,4QE=iDRlep\VxZNbU^tTV+Eb),oZ?'�U"I,5km*ehhpIvD[[PW>j%3,=67E771qYm8&P=4js]^EZOHq3g:%$Ck6s5ubmZG/K�U"BVQZi&7a>>ZZZ8Y=29Ul0m3H0]Y9v^UX+X#L)L+::)I%L\H3wWB]dbFCTdrx<OK�U"QCw.99x<C=xKSP^>aCK&ofRER\S+Sb20=hK&*<G'gfu%^ZFhDqf8(^V'tQrl328�U"'BSJ9.2)=slSgZCK&1HOq?N'F((bqUy,4W[Pt+lq#PNf_dCJq7^<5L$TDDFS:Cu�U"upz2EZ:)?l75YC6,FG7<x^9cM0gK'VC8YkI&'q#3d_habn34S2DP'0_dgSPi)>y�U"lJ?B\SM%/OFRkjbd.if'lBSJq8:YNPApmcy<7._JXdiS]u0-SikijS*%?ioQVu^�U"^jVDu36jcdC(CV<MjS7>:*ZRd\Lf/x'/aTm$Xl*8qepC0-7=eoOXV3^UjnKr(;-�U"&Ck$fTD\'8zvCarl\Zxno)sKcK#CMDhcxnrP.>+#cHz<Fv3d0ZfD%iu'S<s>2Lb�U"_?R_ss\ocP?l0Kx667RmITN[\>cqoKEuMQWtZ_F,zjW4Q/Ktnh\muku/Zr:S=tg�U"m#T<XTN&2g.kz8ZSXbtYY%8X,#Flro7a.I#,q=-6)$S9vCK\Y.S(7eGbj;_4N[2�U"gOb(b4uHwUMw?(<=&auQmUc%&ny2DplUv_\HB:le:Uf>252<Nr=ZI)rh^al\js;�U"MQSl'_s$3jr[WiXpjr4BHYn_*Z5ksUrKU]63dM#]Pw5nlOBcu+Ag$pKz5JYADk8�U"=EEP+z$zJ(9,st%UD_^j$<(I;R<+sqTqO[NwF)o.XCFc<:sT>Ec3WO6Dj7%2vWI�U"?_/<K,O%8'=ER^:,AI1yNd7,JX$HI+7Z,.cJ4unnB5\NCN7j9KMWsIJIB7tbc_S�U"m)_hvS)D9xtMi^f$aIbTG/nPI(U&31F*_[nHsX>4Q$VatbADFBO:Sdub[s&.up(�U"%)9%'%%-%uG%7K#CpN=T[9%%>%r%%0#%%%5M<4=DD33S1;0B>aq:BT?c.Xb\Wx?�U"S#.GWU9_$YaPFCLxYSSQMK[2nJo*fCW5B29vR1%ZV9lVB^8bJGcjVq3#8_hu:)r�U"46Ht<.Z7-p[?sus>iXjnPDMw,5jbpFSs0>6i\9*DFl8SW=6x=Su1tZhGbh$iX^n�U"uJJ?%R5Gx_)-0T1_W(.8%8jSV\NmKKI_MKKb]tBS6e$0bwHQ^tjpVZkZd5s=uI9�U"QS>XCMep^\F,DHbuxh/;cJ=Ol)'<]lU1u<AP8LgL^2tNuhg2PMD<_0;O-XlYxj)�U"G_rN*.h54V_3*+,3dZ$\kOZCUfpKtNJb==BOdjr[^VW\Y7l4i^bWO-BfHWN.E^_�U"-]HU[iW?_Tu5YdRnKU[,1>P/eB[?r8ibi=Jeq#>(DU+n5dCc?p6e_'c8cl,wKUP�U".5P;#]i/ImUA[Q?kLER2_e\f2[rS+8(7[1=]w6]rB:.n.IT2$=Vbq=Ow?S?4n+j�U"]1f-u1TKQB&q(m)-g-w>fZOH+sS=\U/a7lnD%RLSrkRTW&\XW-qm5irgSUJ13og�U"S($#8sJqm6idYUS'$MC-ja)A4fAx'FLxyKJJ0e*=H;i1QTkdU9WorqD$9tt<)S;�U"WC^YUm:UU=%^/dWMsN2P<\=W795*m<>Zd*$GS^zN]rkEJG8<hk_RnUQ-q4E1Tu)�U"gRe;p95ooXX[&M.z&GoT+>jh,>u*]g=PSW)o*Y_*.O6oO,1QWj(MI+fEc$;lD_A�U"3$A'd[Am1bKg,ogEHKO_UMikBZxhE0#gk?]jd7Q'>Az31MQ]Ae),8_Il>;aJG,8�U"m1IW45fV7OmOmEa_;N9<TS*;:Y=(1^9FFV$NZFAYURh9T^MwF-z0f510ke^JQNs�U"K9g$?kQ7^]4>G68e^;OkxT)d)>hjBsSeN+emo5K]L?t-8B]>6vBv/R7'OH)jc[:�U"Mz#;IAH.Axi&NVoZr8gKOOrV[c_tG,7x;+:r+jLGE:rx(H>J__,iDf0\jB+bFcm�U"Do>TMo<\eJ$;FWr$*k>TSM>kV]ff1sTZ)_))#Ti;=QPe_bg+Q0mnRNSsBoblqQX�U"keo6S=3W3IUBJb?p]&sPsrrfBQ)niC.rl\984KRey3qC$O1Hk1%D:Z;F#29-2o<�U"H>n<FvrWnR<Kjc0xM/Gn2OAlp'Pg#]pnvnjJ9IrkrBQc1%CcX/Vp0]=\5_gRUSS�U"Ylb?E+FEk,^8C9P%x4B7N_=0ke#9dc%1=qq[<BW/#CSS(-f)(,j2pGS^EW5gx&G�U"Erk)FC1RH.upVA6Y+wCxph-e[1$eQ1SCAo,+5$N?Q8Y<:+:krwlK9GHpG'(BCPs�U"Mnuh_Wt%P&n%^w?Goh*5/IBhUEF#V5-#me.Dk[IW]r..L&uaf/tl.LpFSI\k7xK�U"QwG_YgLeN%k,<i/MMtB'=6SA1sNhMHK>gp[m7#<U$]6RtYbXrXfaXS-E+_B4NtH�U";1t$gCqkqGiD\B3[*vU?5D3pIdm)QB^lLIh67J/WFE'>6vPF^cs&rvg4u=pRr>(�U")kh[.8bj2%QeA?Ku_03/#%+-Q.5Ii%YSXo)23[PO<0z>G#%rR.wOV-Od[f-k,Q.�U"k=k[bJwsJr5U_J9NT:'<hR?<43czg'R'SH4P=>aWcAZ0K=1p_m5rFtwO-WX'#I]�U"BUUt.Xnd1N+J%8R<s)*s5lt:bJJ*l6M1-CF]=Zk>KpS^kSp=LeOtBOF^QAA/?>u�U"q/p)<Dr.D/0I24c)lD9QXhhn>_GQS/_%[mRpjKRI$0&QS1HK_#C1n*bum>,joT&�U"b$XT92.-_M=oC:x#,aQv'7kd+kIdwg(#+J;E1mY81\#I7b\nNWJE(nOCMrk7s^-�U"eVZK^)?tL4s9k,_N[k(DT'RJ>=3?=D$Z?/q=D3'kMtN^fbEognKjq*4l%9qb6<p�U"Px824>'S=V%&VNjCA#U#7ovl)dSC3?AWG4RHHEQz:-ev#Uvp)k)1KniDDoqRT/-�U"R</?81?#o6M18;rZ$q28>qA_MD=AR$;P8nIw(Qi&F70.G2b\P6la.cmh('daf1K�U"PM_G:tb[rp>o(qE\o001-FGbopKhf&$EH^F.%^QLPeuM&Q;x&E0-Hk+Z#Ox7Fj4�U"gF9q.Gk$%0u,cmA7H/l(3S5z+cSwNGvFGY.:)qW<-]8J=*]ldH2c=]_OG\(,&5Q�U"Zk/p6(JwX\=mDjqcre1j7z/BFzW&%A#oS)T3j]f5KV%8a>EqH\Efv/i*zarmbi:�U"O6t2Gi>&hIOSCi#$TSwX5N^S$6F5\6.IOlLQi=WuJ[=]uDfflc,FDbXQZBLh$Ho�U".o#lH3[<U7;,aNbu\^wmf]K(uqsJSW'qNVlWAL[W%0375x5C,t0M>5eOt*LG:5U�U"T^/#qE['k]a);*Ih-jHL78hd)orlepA-AusZ2FgGxEY[mb6Z-epBdO8;:s.'gmA�U"ET+LLXXPmT3.QAougf(IaYKf_P$kVBl,rmTI:a$wLQEHCXeobW]^SaX78-QZX_2�U"JAQ4FhLpB;5L:Lo]//^V+v7R377JZq9ZU20K^5AQi*,Dk#'LdeN_E^\YbO+)[Kv�U"IPfovRk1.K^(sX4A6Q_P^>nqB.7+)3(g3SwZ9<waV>erhKiCyG1#]vyS4xe/U9a�U"A'k$b#=qSqH_?v:K#T1UgNA?<UBW$fg/rrf$H5-)7B);md$c[x^w'/d'oDh>VDO�U"?=Hs94vv*h+K)3[*xJnt_WJ=7<sX2e8^tq$DGd$&cC)7*hT-7+Z*:L%9DNa#VqH�U"w9M=*r:[W<h')gcjU%*>0E7Z?0>,*IEA%40bGz\RnR,f-X<Nq<-)w(H;#B'r(dq�U"4qQZS=C1d*1;)XAWbfH=XtrtRE6$#xi_OX>.(a);b;\ITbDoB\e<6D*hJwSavpN�U"$=;1]ua\J+Yh8Sq^gCs&Buw<F]F$w:htkSN7Mw6/W.C*saUs(9lrx';j'pr0%9V�U"vZlK%k/u1+l3UP&K-R_TFS^msd<YOt(Ki0f#CiC?ZI63$v7HSWt42Qg\0[b;P6/�U"<GN^N8ENsI?#26bytEM['fDj*uh$>YQ)H>ff*]dsf;n;/lhNUe?<Zwl>ATr<mIb�U"r0U*KZfAdW^fIB[stBB4>fn*ct7Q0pbayTBmZ/7\p1E--t.+p>_fJf.w]79G7]i�U"Kppo6$xH$B8[pbMgT87qcx:[^Nhq+g'_<VnMg^Sc<ZRYrb]Lit$<'CcKhD3aMl_�U"fI%E%+c),p%XIbHUrYsr#>&:_T8*$7BoJznoo#c%%bBH:4f7UJWR'6%Sl\jIWBE�U"tvPYX/Glm$'S3l6ww?/[/%X9*;$G*&j?lYP9xF&]/#I/xuz\EjB*,5-Rs:=UW=L�U"+#wr*[7_eJTGEwpvh:N2]I%Y2y]]3P^s8UKaZ[y4i&0y3o%9l5D;'?8t9[wHj]B�U"C;/H^s+9h9R7bZZ=(_9qf$ep-5]o.c5^9H2w49+9=uxO<'YDY9Ff#KDO;>l/tpK�U"#+l5#J8&p4ODb_k2hhYviSe7R,.yF55[njW1i8M7lDkf,xvtpxVxtGbLb>\jJ8p�U"B\wb0-YpSR4ye=aHB2rW;OM_#_+.q(FL<;vYzLO?h#Q0Bu1x*Nt#E4;+Y<?Xar7�U"PERxS6&G435YqP._3g>f>M_Sq<$48=P*2tRa<AqKe4a7+HBT0tadR=z;_4o*k?Z�U"oA,Z.pND&6$&SlMks;aghwlr<GmbRiVHNb6c\_^2'*Wz\3Qmcb.rdXW<Ag\>.-%�U"VPVGvSgkClgnz[-r7YcR+UW1J<-/^ekigs4O0/ZU/c0+wkJp;Gk^arBKJd%D1/Z�U"cWe68ecm2<f/;=MdR4O;WAJD3XrQ7>QcZ^-VKmj2xCeUz)$;,z-IH8)pCI6d(0A�U"*bq#0=:L9a_qmw)_1\)wp:MqZ/VG,JDxk\b&4at4DYU%ecTbfB^-;$JYRi+Ukfo�U"UK^vx_-0%31Vb][>V-XlY#]InlDR1]OIu$%T'BXhE$FJ,]<<Q3=WueMpYkII.1L�U"T)2>Hq;w+o#+j+E\7T4&EwcuC,kCGZ;2DOUuvke,JlKRHr]e:pVg4g0]8.T;;O<�U"vU$)']CT$tIKBl)Q5pO)w&DS/n^$1aB\6YOj(&<i\7G/I<S3O#,>vlsz34;Lj8*�U"NYiY9tol>o%5#'9-h9[3B\Q$g0D)bgn,gPZOw<RTMTTnEroH8Ex.3m/e1G2Y^ac�U"B&opN=V)n3cB;-UPLN[+-jB=UVh1JUS\*TE\)[*b1J?>R2DC[[UQtgE>Wt^/*(1�U"nR)J*wW8QE?/;U8#gggx-jleE%#_'v%i-YoZ-;[uL>e+teWAw66qhYbWmgFtZdh�U"Z>i:TPJg'I/gLhI'rDY;l84DPMV6X0Bo4>X,,^+jr2IK;cG,^Vg^P^)(teV%Lkx�U"vMLxmE=-Vlxu$-&?Rz<E[hF-F^01i)Kn1dp$jATe.jm*/s^IL8W*d<N$Z(qCfL]�U"pa[TN_F9h9&2W6sGh,<#l[ugVZzp1gEqRMa:G60rEb2;q=Tnsm)**#8Ah^V)EWN�U"U8+wVF5xdZ^i(lar?q=E#'wwF>Iisz.RoUOBD)Z6gQ-&NW?a0t.8*DuAbj+-%Xf�U"Z$<TE[r4zI(ltzCX=iCNGxl%+xCmIX4Yq<Y5*X^LbmuP^g^bC[tmF_.bj^;KrL6�U"Yd),&^\5CTXtmTE7KBDM^ou0b0sY>lO=PwLe\z:H'neqQU,+bqW*[v.$zg3lV:+�U"5c,6<6)wz&0D96RRG5Tx#grlnBVi')u)6O9A:O]S-iZB,iIS^XQohYwAY-v/EXZ�U"*:;_I_ED&h56:_&qz7+,sRSP&hT$l:0=E=z3nK]5dN7+de>9,*no&lFZ'&bMOYG�U"#Y-^2JsGyme03mMgIHDT)m3\hOZ%#KdL3ad_$hk+'.udaX$Q?RJ(CUCPP*MGf*o�U"q_$NqzT)8fMU^<xyH3'A#yj]bU]E,2Gc%_X92s&l?bN-:uGL8JY8/[.GiXpHg+l�U"0e,,i*rIH7A*2K:#na%.o=[ps-Q\1T6C$NkxFt2ub*;jbz)KneWh)WNKBGb-Rn7�U"SOlPZzIwOUkT>X<e'I&16E=&JS/(7?U\UU^FR^R(&Y*/FI/\j$V6c.OEPD(&s%2�U"Cj%(_41WfH7lmG,^_=rZ]U:O7)boM^3)EZJ[98PpQsh>6qP#Z\WY$'X6uXL)uB)�U"cld,pIx*5&*9KdZjZ?SVP.qXvQhKe/8-rdFkpLU;l^$m]hd5xko]/4>99&5Bfe%�U",fS</Bcu>oE.WV9K+AmRIpRyvcQ;twV(WDZF[Qk(k>axojKUQ5V^P0Ix>I%cPJM�U"TL;Wj:7GK.Irtw3b%'rHMW$gFBgvgO3>8<h6qO5J&O:yP;&2tWv[a>-W,wjA#.#�U"h,m0/DnN]Y.F#C#,L,lDWF_eCFrH.NneXWz<dlB;(TVS..?_lwL8'1s8[BYA1Sk�U"t#?Ik*QR/(se]]qUPjKY75uMv*z7]/<S(%K8u\0J0[Q6n>Ym*[X.::V)O7h.y*4�U"YWhqR_Vc[YgQDHOB'Za$u^FCn)AbB:2C3%CE&FhtjOqOS<QNTc&%PHb)LFZBH4k�U"(O#\Km#hS-EI)R(W]#RSYnCWc;i(w,qYAnOyE7Ms]=CpO:W%Jyy=l/f'9^U.>iX�U"JS%D2jzGuWK/ZtRD>5PD1FLd6fDr5Cbvqf3s3q+)v-:LI1w.Z=xHYy,2tz4t.?T�U"a>]j]'U+Lig_6Zz;h'C$L$&?q7+ON'NVgwMDex%?ms,7,MS:zO\+JwD(5(/z\u>�U"_8a&2nRX./RSl-'G(U$>gJH:?lKp,;NNQMx8=gr_d&qiKGzw^tKinq.yJ3,td8t�U"M>T'<;_vpf<c>WAh;5W?rB_f,'f8$>JGP?WB0D#Ygj(nMS&u\v)cOgNHGTr4;%x�U"M$Y+CN,8zeTKVaDB%Vf^\&-A=<$,qNyz.rjd*W)I2QQeBEC9_y&()Zt$P:YEd4I�U"^1Edu'(VZ0v'c0]a?npfeP0oM1x;]UitV?ScHd0O.'<FMMy+Nq*pD19cGPyH%<1�U"t0EXSSJKpX8j[(ne>+e\Cq8.m:jLc4D*[oGrG.vbkkn\#'j)P'2sYnZfeT_[OrV�U"Q)(pFzl?B#3A*jkV;Pc%Ui<_p2V.c(&LcVCyIe5wLww)q(yKJB0w%q+\B(Xk\%x�U"N1_[=-R%[NJ*#b$r;gCtHC%V*JDooD8$w%v4IE5]P6nD0:^p(tTZ:mA7GT-jkvj�U"VgfD9ar9sg(^MT&3wXH1g2>(3bURdNDa-ixh6$XcGk:cEd0<H+&Hk&1Y<qDBp*^�U"^EcefRx2$(D9vO-umB[D28*HIxf3.;h<e$;%e[;/d(zd%btHILpv%.;L;nJi$%A�U"ZQ1itXo7Duqr;UD<#tbNJjw;6Vbi'd;b>5VT+Um6?[7XBJtJ>\='Cr2lIEJ+tW-�U"o2:?mXckYzLR^BcUo,Y++,_A^taLa<0&mnls3YjO+[/r5>tJ/+9d(+?klPO\r'b�U"5XMcXNNR+Pl*VK).5yCcnatOJ\+]7%-8DuM-vC\=sO=O^s,\?GWXfX)XM()6cPV�U"O[njt>xpnP70WD.b:]4Ovd*ItL^AyTH)5rkq8jDNnM?nmnh0,yN_/6+ZPWbZ2m;�U"L#J?nstZE7EcCv0v.k=1:^AqhNA4aiL.an]e#5M94E^BtnYx#dvt,LdSPNT^S_o�U"f6rkdb=3d;t0a(3PuL:0jP>ke:oB]^NQlk*HtBe1;<l17xuQhm9;Mlkr^c#PLXU�U"#bmMFk&</dExiFA(;Y7<K,xD>CC':NH%q(iK+P]L'$ihXJ%><esq4qKrXl,6x4u�U"%p()9%%'%-a%Py77K,4C-7P,%(%o#%%%1%%L%5<4M=D3<J>S10PB^'L)>jq7cx8�U"w89<M$[gkVBYefKxG&^3(s;GY*Df9ryD8xGowSr_YRbDLmvci0Te;Q<Ky6Pm$sG�U"V%55tMl+,u,,,TUo1I-T7%kCc7le\=XDgv[cW'#6uT1&G.m8y;Xo8za5D-+p=&X�U"Xm_duuhg&5/5HAbtmP1sr-r2U?WS>RFdl#C3u^q7:iQ#<i_[Xr7][.o0NO3IA##�U":uB?qoZl3e)(/W:1.,*(bMzuZpu]B^0S&+bZON)/$R6h_F]O7MOI7Ja96Oe&-5l�END SUB�SUB V2�U"P$dg/drLU\0fnJ>GKSkH2c1SE&ZFoD3YBaS_xu-\G7*Gi;gmK)j\XH'AV_Xj6t,�U"8ei[7p4.QR?CG0=A6:hY,ReDLTq5]=$*[VG)or.+Kh\l&:T<F5v%Fbote>2A,R%�U"swi(Qlh<a>bZUcN9<U&.5L:yu)ZqopDB#0YR0E;?)ALI7$nK*N,Cds<6=-np=PB�U"9.WF-K$0*q-]VLiNP;-jfZHr5K9JgbW2XxvRQX7?QZIo:j/I[r]>mbGRL#]=5tr�U">[_QCjI,52_k59svLwd_K0FYB-9;$%j-(./m1m'J':jAcdAyp1[BEN.RjHHa1\P�U"WbJGcV8v_.oRCj_<\6m%phG6KFYF'G=0iC3IqkTaN'^SHCotX*N9ev8_d+iXN^C�U"1B7fOPdHN-wnt6Nmnf#?XmsPX21p1tj7=J9'b(3:okI1and7/]jqYO&bd)&P,?^�U"(^Z6,5'\7,/<2d_-RuKT.Mqg6uq9J[6R5m4EWu02k38&:v]a-.jW5VSZ_F,Dhgq�U"Pq4j'ZKTUmJ,5aqbAWT5Ml#VT/%'k%3kXmTfg\0NX+;QiN7k^-l+DW#SGSaPu7g�U"fa$WWTCX'\ZoNEJloa32YAf.wOPK=HoPi&Gy?N4N>PFUgCKi?H4wDh5g+Spl^iq�U"mgd[*mCchLT%6AWd1dSb%=g$-E:k7f$Y6YwDs^T.a)l6I'6Ii*>U/;P-2^q%jta�U"s)\(YnmsN?=ra_uU,OJ=8n+P45,,r4_)r'F-Ib[YKUK93x\n0^B&N/:J<[avy&_�U"C1anGXm5Cg-v?GTdV*G*&kuHb;*5Af=-*fk:nWJiwAsMk#hrnR;vUDhlIXOhjL8�U"/WR$XYHk[QVJsflZ3l(%5f:\ccHRPFLU8-055yLdJA$zEukW5^,[]cSj]v?C-(b�U"K&6L9j7PtAA,t#wgL=26;p1Lfe$22'4gzE7wMa7tNXy\xfC92)BSLCLrMv.8ye>�U"oIJ<EN/x7#(-2E>t0/j,JJ]c?Uv[F;mR=VCjkodIMZa#IIK>CEf5qyc.n+l1_03�U"-Vf:3rJ(+4==r$kJT,41Mb%YSP/82qW^?&/Qn^9GRlo($a,fUPt'*k7XrKpl.u'�U"f.[o;UHb8cJgefbEHy&Dvx?H)FJ_x=yf*%VN;kSi=(&b=tSMY+rNtt[::sR2ygi�U"k;7RWxH2:>PYT5R:*\Xox#fvOUA[QJ,m>sqGlwIq_P;HQ/1cy<HHHR_ct4<+gei�U"/VRZ)[DI)0(Zs4N7*tAmML^dz8q2cC\F-[RHYEibkSa4+sYe$AS;lCnXWhCjevq�U"Iqp$bJQM_IYlA+=L-6)l*AAyI#MJ?*&kr\)\)\I,)[%'fR15W=D/^Mf(ulMxJj5�U"H1N,-QuinrHw^kbJOu0D)DTqZN-cB]p90jqnq*k*v:TJ<=1lkW?Ti7<'&E/xM\:�U"u(0*3%(pMB,tPc+Z*&OYn_6/>^V)N<924g92RM[+%&L12_H/:W6-v>9JG4hH-'T�U"baTB7^')swI4Ot(JuSJH1]a[tZm[Ofn&prt1$JIr7S^0qk#Q0*uE\#x,eh>uVM9�U"n8Y7/bv$^:TT7L[l*-Lzo-%G33vi?\F_FP[VH?7ndDC<++hk)7OkgmZGWcik7o;�U"#eR$+nXGWj:r);y)Grg(Got9ofp-ot;cXgxFK3thn_cmpm&,ZapCS<u\N3lhREA�U"/ucf-cpMz;\/cFc.r83>wiN-E]oRj+\]WO6$:-kH^bpLt#1UFqiFZCxfWpNH6cB�U"pOtqm*$+W#7tuQS&Mx.;\FxEQW\.ceMYi3n%j,(Cb6qIpt8avr)UWH2Vl\zDf2B�U"k89r*DsA=W[W1.WfWBbn;AC<Jx>;E=6b^2OtO[Za_fsx^;QMiNB45w4lNZR:a-o�U"w:(A>gTyI3y+;+uO*12FI?%861mu;Jpis?cKoi'hFr2/XSbE4]<E(f4&17AFo-\�U"JhX=m3/.isrkq_jn*?q1VNTEmHs^2>6WDOgVBCf^1#k&6j;Y(aD&WQ]&jt=F36[�U"9_REU?_LrV?,SP#WVMb8AQf*f1XeuUTF=9QPs_'ZUJ_>jcL0<ZAdcRn*j6&K)Z?�U"IUHFk7-X_5Q%VBf<dgiRd>Y.j):rlLmQCCIfa?xRo-J]6wrXvK8KSu/JgGQUXye�U"wTXF+q$rcevMU$$F]'>jXHd;qmL<H]?;9Wg[kD5sPTUMLU)]3-)p\8.r5f+fs2a�U")u7t6v?#lmAcKGz]wn*CP2*MOH(,e^VkC.lS^]6;W>YWB9/O_[Km_ARpfVVr'?b�U"$8N*6#'sAZ<2A0v_0u/Y&_^L8pt5RWpewQp6cKN%%up&'%9%9%%'%-%7kr7Knx=�U"0:&]6%%'fe%%%.%%%%%%%%%%%E%%%%%%I%%5<24=DS210Bu%p&'9%%9%'%%-%uG�U"%7K#CpN=T[9%%>%r%%0%%%%%%%%%%%%E%%+%.6%L%5<4M=D33LS10B%up&'%9%9�U"%%'%-%9Py7Ka,4C7'P,%%&o#%%%1%%%%%%%%%%%E%.%%2KI%%5<M4=D3D<>S1)0�U"Bup%*+%%%%%(%.(%y%.%%3S%%%%%�END SUB�V2�CLOSE:IF S=74AND B&=Z&THEN?" :) Ok!"ELSE?" :( Bad!�SUB U(A$):FOR A=1TO LEN(A$):C=ASC(MID$(A$,A))-37:IF C<0THEN C=91+C*32�IF K<4THEN K=C+243ELSE?#1,CHR$(C+(K MOD 3)*86);:K=K\3:B&=B&+1�S=(S+C)AND 255:NEXT:LOCATE,1:?STRING$(B&*50\Z&,219);:END SUB�Don Schullian & Lance Edmonds  USING WINDOW'S PRINT SPOOLER   d83@DASoftVSS.com              06-16-99 (01:49)       PBCC                   482  17812    PBCCPRNT.BAS$IF 0�    ----------------------------                      PowerBASIC/cc v1.0� ---|          DASoft          |------------------------------------------�    ----------------------------    Copyright 1999      DATE: 1999-06-12�    | FILE NAME   CC-PRINT.bas |          by�    | DIRECTORY                |  Don Schullian, Jr.�    ----------------------------�             This code is released into the Public Domain��  Note, please, that Lance Edmonds's (amongst many other's) input has made�  the core of this code. All I've done, in effect, is gather all the info�  and build functions around it.� -------------------------------------------------------------------------�  PURPOSE: Print to the user chosen printer using Windows' print spooler�           and fonts found on the user's system.� -------------------------------------------------------------------------��Well, I was going to remark the code but there just isn't much to say about�it! All in all it's pretty simple once you understand all the Windows calls�so I'll confine myself to this discussion.��The PrinterInfoTYPE has MUCH more information in it that would be required�under normal non-proportional printing but I left it in 'cause it's easier�to remove something than it is to add it. Which brings up an important point�about this code: assuming that you're working in PB/cc I'd suggest using the�code below to build a customized print driver for your program. It would,�most likely, be easier in the long run.��The biggest headache when printing using Windows' routines is that you NEED�to keep track of the X/Y position of the 'print head' on a pixel level.�There ain't no rows and columns so TAB and SPC are out of the question. If�you find yourself requiring a lot of that then you'll want to obtain the�average height and width of the character set (for non-proportional) or�set up your own array of pixel values to the offsets you want to hit. To�put in a blank row is as simple as bumping the current .Ypos value by the�height of a row! When you get a bit of practice under your belt it REALLY�is an easy way to print. You know, label #6 starts at Xoffset/Yoffset and�you can "print" label 6's data first, last, in order, whenever and end up�with the same results when the page pops out!��Anyhow, there is some code in PBmain to get you started. Notice that I'm�printing the ASCii values in order (0 -> 255) but that they will be displayed�on the page in 3 columns with the numbers moving down the columns. Then, when�that's done I print in the upper left and bottom right corners of the page�totally out of any 'order'.��Ah.... got questions? Ask Lance, I don't have a clue! d;)��BTW, I've tested these routines on 2 kinds of H/Ps and my Epson Stylus pro�all under Windows 95. If anyone has any trouble with their printer let me�know, please.��If any of you have Win98 or NT and this code WORKS, let me know. Just for�my peace of mind, you understand. <grin>��Thanks,��Don Schullian�d83@DASoftVSS.com��$ENDIF�'�'-------------------------------------------------------------------------------�'-------------------------------------------------------------------------------�'�$INCLUDE "..\WIN32API.INC"                     ' you'll need to add any required path�$INCLUDE "\PBDLL50\WINAPI\COMDLG32.INC"        ' info for these two files��TYPE PrinterInfoTYPE              ' some (most?) of these members aren't necessary all the time�  hDC       AS LONG               ' handle for Device Controller�  '-------------------------------' page dimensions & info�  Xtotal       AS INTEGER         ' total width (in pixels) of the page�  Ytotal       AS INTEGER         ' total length (in pixels) of the page�  XperPage     AS INTEGER         ' total usable horizontal units per page�  YperPage     AS INTEGER         ' total usable vertical units per page�  XperInch     AS INTEGER         ' horizontal units per inch�  YperInch     AS INTEGER         ' vertical units per inch�  X1offset     AS INTEGER         ' left offset   (in pixels) to printable area�  Y1offset     AS INTEGER         ' top offset    (in pixels) to printagle area�  X2offset     AS INTEGER         ' right offset  (in pixels) to printable area�  Y2offset     AS INTEGER         ' bottom offset (in pixels) to printagle area�  Graphics     AS LONG            ' TRUE if printer capable of graphics�  WidthMM      AS INTEGER         ' page width in millimeters�  HeigthMM     AS INTEGER         ' page height in millimeters�  tDI          AS DocInfo         ' current document information�  '-------------------------------' computed & temporary variables�  JobNbr       AS INTEGER         ' <> 0 indicates that a document is open�  PageOpen     AS INTEGER         ' <> 0 indicates that a page is open�  PageNbr      AS INTEGER         ' current page number (manual)�  MarginLeft   AS INTEGER         ' left/right margins�  MarginTop    AS INTEGER         ' top/bottom margins�  MarginBottom AS INTEGER         '�  MarginRight  AS INTEGER         '�  Xpos         AS INTEGER         ' current X position of print on line�  Ypos         AS INTEGER         ' current Y position of print on page�  hFont        AS LONG            ' current font handle�  hOldFont     AS LONG            ' previous font handle�  DocName      AS ASCIIz * 256    ' current document name�  tM           AS TextMetric      ' all kinds of goodies about current font�END TYPE��GLOBAL g_tFont()   AS LOGFONT�GLOBAL g_FontCount AS LONG�GLOBAL g_FontMask  AS LONG�GLOBAL g_tPI       AS PrinterInfoTYPE��DECLARE FUNCTION fPrintJobOpen    (BYVAL DocumentName AS STRING) AS LONG�DECLARE SUB       PrintJobClose   ()�DECLARE SUB       PrintJobCancel  ()�DECLARE SUB       PrintJobEndPage ()�DECLARE SUB       PrintJobNewPage ()�DECLARE SUB       PrintJobSetFont (BYVAL FontNo AS LONG,BYVAL Pts AS SINGLE,BYVAL LinesPerInch AS LONG,BYVAL CharPerInch AS LONG,BYVAL Wgt AS LONG,BYVAL Q AS BYTE,BYVAL W AS BYTE, BYVAL U AS BYTE, BYVAL S AS BYTE)�DECLARE SUB       PrintJobPrint   (BYVAL Text AS STRING,BYVAL EoL AS LONG)�DECLARE SUB       PrintJobMargins (BYVAL L AS SINGLE,BYVAL T AS SINGLE,BYVAL R AS SINGLE,BYVAL B AS SINGLE)�DECLARE FUNCTION fFontList        (BYVAL NonProOnly AS LONG) AS LONG�'�'----------------------------------------------------------------------------�'-------- test code�'----------------------------------------------------------------------------�'�FUNCTION PBMAIN() AS LONG��  DIM Char   AS LOCAL LONG�  DIM Col    AS LOCAL LONG�  DIM FontNo AS LOCAL LONG�  DIM Margin AS LOCAL LONG�  DIM zText  AS LOCAL ASCIIZ * 256�  DIM X      AS LOCAL LONG�  DIM tXY    AS LOCAL apiSIZE           ' used to be SIZE��  fFontList -1�  IF g_FontCount = 0 THEN�    PRINT "NO NON-PROPORTIONAL FONTS FOUND"�    WAITKEY$�    EXIT FUNCTION�  END IF��  PRINT "Pick the letter of the font you desire or <ESC> to cancel"�  PRINT�  FOR X = 1 to MIN(20,g_FontCount)�    PRINT CHR$(X+64); FORMAT$(g_tFont(X).lfWeight," ### "); g_tFont(X).lfFaceName�  NEXT�  zText  = UCASE$(WAITKEY$)�  FontNo = ASC(zText) - 64�  IF FontNo < 1 OR FontNo > g_FontCount   THEN EXIT FUNCTION�  IF ISFALSE(fPrintJobOpen("Test Print")) THEN EXIT FUNCTION�  PrintJobSetFont FontNo, 0, 6, 10, %FW_NORMAL, 0, 0, 0, 0  ' pts,lpi,cpi,wgt,qlty,it,ul,so�  PrintJobMargins 0.6, 1, 0.6, 1��  WHILE g_tPI.PageNbr < 1�    PrintJobNewPage�    Char   = 0�    Col    = 0�    Margin = g_tPI.MarginLeft��    FOR X = 1 TO 256�      zText = FORMAT$(Char,"000 ") & CHR$(Char)�      PrintJobPrint zText, 1�      INCR Char�      IF (g_tPI.Ypos + g_tPI.tM.tmHeight) > g_tPI.MarginBottom THEN�        INCR Col�        SELECT CASE Col�          CASE 1 : PrintJobSetFont FontNo, 0, 6, 10, %FW_BOLD  , 0, 1, 1, 0�          CASE 2 : PrintJobSetFont -1, 0, 0, 0, 0, 0, 0, 0, 0�          CASE 3 : PrintJobSetFont FontNo, 0, 6, 10, %FW_NORMAL, 0, 0, 0, 1�          CASE 4 : PrintJobSetFont FontNo, 0, 6, 05, %FW_NORMAL, 0, 0, 0, 0�        END SELECT�        PrintJobSetFont FontNo, 0, 6, 10, %FW_BOLD, 0, 0, 0, 0�        g_tPI.MarginLeft = g_tPI.MarginLeft + g_tPI.XperInch�        g_tPI.Ypos = g_tPI.MarginTop�        g_tPI.Xpos = g_tPI.MarginLeft�      END IF�    NEXT��    zText = g_tFont(FontNo).lfFaceName��    IF ISFALSE( INSTR(g_tFont(FontNo).lfFaceName, "Courier") ) THEN�      FOR FontNo = 1 TO g_FontCount�        IF ISTRUE( INSTR(g_tFont(FontNo).lfFaceName, "Courier") ) THEN�          PrintJobSetFont FontNo, 0, 6, 10, %FW_BOLD, 0, 0, 0, 0�          EXIT FOR�        END IF�      NEXT�      IF FontNo > g_FontCount THEN GOTO AllDone�    END IF��    g_tPI.MarginLeft = Margin��    TextOut g_tPI.hDC, 0, 0, zText, LEN(zText)��    zText = "This is the top right"�    GetTextExtentPoint32 g_tPI.hDC, zText, LEN(zText), tXY�    tXY.cx = g_tPI.XperPage - tXY.cx�    TextOut g_tPI.hDC, tXY.cx, 0, zText, LEN(zText)��    zText = "This is the bottom right"�    GetTextExtentPoint32 g_tPI.hDC, zText, LEN(zText), tXY�    tXY.cx = g_tPI.XperPage - tXY.cx�    tXY.cy = g_tPI.YperPage - tXY.cy�    TextOut g_tPI.hDC, tXY.cx, tXY.cy, zText, LEN(zText)��    zText = FORMAT$(g_tPI.PageNbr, "Page No: #")�    GetTextExtentPoint32 g_tPI.hDC, zText, LEN(zText), tXY�    tXY.cy = g_tPI.YperPage - tXY.cy�    TextOut g_tPI.hDC, 0, tXY.cy, zText, LEN(zText)�  WEND��  AllDone:�    PrintJobClose�    PRINT "DONE"�    WAITKEY$��END FUNCTION�'�'-------------------------------------------------------------------------------�'�SUB PrintJobSetFont( BYVAL FontNo       AS LONG  , _�                     BYVAL Points       AS SINGLE, _�                     BYVAL LinesPerInch AS LONG  , _�                     BYVAL CharPerInch  AS LONG  , _�                     BYVAL Weight       AS LONG  , _�                     BYVAL Quality      AS BYTE  , _�                     BYVAL Italic       AS BYTE  , _�                     BYVAL Underline    AS BYTE  , _�                     BYVAL StrikeOut    AS BYTE    )��  DIM tF AS LOCAL LOGFONT��  IF (FontNo < 1) THEN�      IF ISTRUE(g_tPI.hOldFont) THEN�        DeleteObject g_tPI.hFont�        g_tPI.hFont    = SelectObject(g_tPI.hDC, g_tPI.hOldFont)�        g_tPI.hOldFont = 0�      END IF�    ELSEif FontNo > g_FontCount THEN�      EXIT SUB�    ELSE�      LSET tF = g_tFont(FontNo)�      IF Points > 0 THEN�          tF.lfHeight  = -MulDiv(Points,g_tPI.YperInch,72)�          tF.lfWidth   = 0�        ELSE�          IF LinesPerInch > 0 THEN�            tF.lfHeight = (g_tPI.YperInch \ LinesPerInch)�            tF.lfWidth  = 0�          END IF�          IF CharPerInch > 0 THEN�            tF.lfWidth = (g_tPI.XperInch \ CharPerInch)�          END IF�      END IF�      tF.lfWeight    = Weight�      tF.lfQuality   = (Quality AND 3  )�      tF.lfUnderline = ISTRUE(Underline)�      tF.lfStrikeOut = ISTRUE(StrikeOut)�      tF.lfItalic    = ISTRUE(Italic   )�      IF ISTRUE(g_tPI.hOldFont) THEN DeleteObject g_tPI.hOldFont�      g_tPI.hFont    = CreateFontIndirect(tF)�      g_tPI.hOldFont = SelectObject(g_tPI.hDC, g_tPI.hFont)�  END IF��  GetTextMetrics g_tPI.hDC, g_tPI.tM��END SUB�'�'-------------------------------------------------------------------------------�'�SUB PrintJobPrint( BYVAL Text AS STRING, _�                   BYVAL EoL  AS LONG    )��  DIM Tlen AS LOCAL INTEGER�  DIM tXY  AS LOCAL apiSIZE�  DIM Tptr AS LOCAL LONG��  Tlen  = LEN(Text)��  IF Tlen = 0 THEN�      tXY.cx = 0�      tXY.cy = g_tPI.tM.tmHeight�    ELSE�      Tptr = STRPTR(Text)�      TextOut g_tPI.hDC, g_tPI.Xpos, g_tPI.Ypos, BYVAL Tptr, Tlen�      GetTextExtentPoint32 g_tPI.hDC, BYVAL Tptr, Tlen, tXY�  END IF��  IF ISFALSE(EoL) THEN�      g_tPI.Xpos = g_tPI.Xpos + tXY.cx�    ELSE�      g_tPI.Ypos = g_tPI.Ypos + tXY.cy�      g_tPI.Xpos = g_tPI.MarginLeft�  END IF��END SUB�'�'-------------------------------------------------------------------------------�'�SUB PrintJobEndPage ()��  IF ISTRUE(g_tPI.PageOpen) THEN EndPage g_tPI.hDC�  g_tPI.PageOpen = 0��END SUB�'�'-------------------------------------------------------------------------------�'�SUB PrintJobNewPage ()��  IF ISTRUE (g_tPI.PageOpen) THEN EndPage g_tPI.hDC�  StartPage    g_tPI.hDC�  SelectObject g_tPI.hDC, g_tPI.hFont�  g_tPI.Xpos     = g_tPI.MarginLeft�  g_tPI.Ypos     = g_tPI.MarginTop�  g_tPI.PageOpen = %TRUE�  INCR g_tPI.PageNbr��END SUB�'�'-------------------------------------------------------------------------------�'�SUB PrintJobClose ()��  IF ISTRUE(g_tPI.hDC) THEN�    IF ISTRUE(g_tPI.PageOpen) THEN EndPage g_tPI.hDC�    IF ISTRUE(g_tPI.JobNbr  ) THEN EndDoc  g_tPI.hDC�  END IF�  PrintJobCancel��END SUB�'�'-------------------------------------------------------------------------------�'�SUB PrintJobCancel ()��  IF ISTRUE(g_tPI.hDC) THEN�    IF ISTRUE(g_tPI.hOldFont) THEN DeleteObject g_tPI.hOldFont�    IF ISTRUE(g_tPI.hFont   ) THEN DeleteObject g_tPI.hFont�    DeleteDC g_tPI.hDC�  END IF�  LSET g_tPI = STRING$(SIZEOF(g_tPI),0)��END SUB�'�'-------------------------------------------------------------------------------�'�SUB PrintJobMargins (BYVAL LeftM   AS SINGLE, _�                     BYVAL TopM    AS SINGLE, _�                     BYVAL RightM  AS SINGLE, _�                     BYVAL BottomM AS SINGLE  )��  DIM B AS LOCAL LONG�  DIM L AS LOCAL LONG�  DIM R AS LOCAL LONG�  DIM T AS LOCAL LONG��  T = (LeftM   * g_tPI.XperInch)  ' compute pixels requested�  L = (LeftM   * g_tPI.YperInch)  ' for margins�  R = (RightM  * g_tPI.XperInch)�  B = (BottomM * g_tPI.YperInch)��  g_tPI.MarginLeft   = MAX( g_tPI.X1offset, (T - g_tPI.X1offset) )�  g_tPI.MarginTop    = MAX( g_tPI.Y1offset, (L - g_tPI.Y1offset) )�  g_tPI.MarginRight  = MIN( (g_tPI.Xtotal-g_tPI.X2offset), (g_tPI.Xtotal - R) )�  g_tPI.MarginBottom = MIN( (g_tPI.Ytotal-g_tPI.Y2offset), (g_tPI.Ytotal - B) )��END SUB�'�'-------------------------------------------------------------------------------�'�FUNCTION fPrintJobOpen (BYVAL DocName AS STRING) AS LONG��  DIM Copies   AS LOCAL LONG�  DIM FromPage AS LOCAL LONG�  DIM ToPage   AS LOCAL LONG�  DIM MinPage  AS LOCAL LONG�  DIM MaxPage  AS LOCAL LONG�  DIM hDC      AS LOCAL LONG�  DIM Mask     AS LOCAL LONG�  DIM hWnd     AS LOCAL LONG��  PrintJobClose                           ' just to make sure & clear g_tPI��  Copies   = 1�  FromPage = 1�  ToPage   = 1�  MinPage  = 1�  MaxPage  = 1�  Mask     = %PD_RETURNDC           OR _   ' gotta have this one�             %PD_DISABLEPRINTTOFILE OR _�             %PD_NOSELECTION        OR _�             %PD_NOPAGENUMS��  PrinterDialog hWnd, Mask, hDC, Copies, FromPage, ToPage, MinPage, MaxPage�  IF ISFALSE(hDC) THEN EXIT FUNCTION��  g_tPI.hDC          = hDC�  g_tPI.Xtotal       = GetDeviceCaps(g_tPI.hDC,%PhysicalWidth)�  g_tPI.Ytotal       = GetDeviceCaps(g_tPI.hDC,%PhysicalHeight)�  g_tPI.X1offset     = GetDeviceCaps(g_tPI.hDC,%PhysicalOffsetX)�  g_tPI.Y1offset     = GetDeviceCaps(g_tPI.hDC,%PhysicalOffsetY)�  g_tPI.XperPage     = GetDeviceCaps(g_tPI.hDC,%HorzRes)�  g_tPI.YperPage     = GetDeviceCaps(g_tPI.hDC,%VertRes)�  g_tPI.WidthMM      = GetDeviceCaps(g_tPI.hDC,%HorzSize)�  g_tPI.HeigthMM     = GetDeviceCaps(g_tPI.hDC,%VertSize)�  g_tPI.XperInch     = GetDeviceCaps(g_tPI.hDC,%LogPixelsX)�  g_tPI.YperInch     = GetDeviceCaps(g_tPI.hDC,%LogPixelsY)�  g_tPI.Graphics     = GetDeviceCaps(g_tPI.hDC,%RasterCaps)�  g_tPI.X2offset     = g_tPI.Xtotal - g_tPI.X1offset - g_tPI.XperPage�  g_tPI.Y2offset     = g_tPI.Ytotal - g_tPI.Y1offset - g_tPI.YperPage�  g_tPI.MarginRight  = g_tPI.XperPage�  g_tPI.MarginBottom = g_tPI.YperPage��  IF ISTRUE(LEN(DocName)) THEN�      g_tPI.DocName      = DocName�    ELSE�      g_tPI.DocName      = TIME$�  END IF�  g_tPI.tDI.cbsize       = SIZEOF(g_tPI.tDI)�  g_tPI.tDI.lpszDocName  = VARPTR(g_tPI.DocName)�' g_tPI.tDI.lpszOutput   = 0�' g_tPI.tDI.lpszDatatype = 0�' g_tPI.tDI.fwType       = 0�  g_tPI.JobNbr           = StartDoc(g_tPI.hDC, g_tPI.tDI)��  SetTextAlign g_tPI.hDC, %TA_BASELINE OR %TA_NOUPDATECP OR %TA_LEFT�  SetBkMode    g_tPI.hDC, %TRANSPARENT��  FUNCTION = %True��END FUNCTION�'�'-------------------------------------------------------------------------------�'�FUNCTION fFontList (BYVAL NonProOnly AS LONG) AS LONG��  DIM hDC     AS LOCAL LONG�  DIM Printer AS LOCAL ASCIIz * 256��  REDIM g_tFont(10)�  g_FontCount = 0��  hDC = GetProfileString("WINDOWS", "DEVICE", ",,,", BYVAL VARPTR(Printer), 256)�  IF ISFALSE(hDC) THEN EXIT FUNCTION��  Printer = EXTRACT$(Printer,",")�  hDC = CreateDC(BYVAL 0, BYVAL VARPTR(Printer), BYVAL 0, BYVAL 0)�  IF ISFALSE(hDC) THEN EXIT FUNCTION��  IF ISTRUE(NonProOnly) THEN�      g_FontMask = ( %VARIABLE_PITCH OR %SYMBOL_CHARSET)�    ELSE�      g_FontMask = 0�  END IF��  EnumFontFamilies hDC, BYVAL 0, CODEPTR(Enum_Fonts), -1�  DeleteDC hDC��  ARRAY SORT g_tFont(1) FOR g_FontCount, FROM 29 TO 60, COLLATE UCASE��  FUNCTION = %True��END FUNCTION�'�'----------- call-back routine for Windows -------------------------------------�'�FUNCTION Enum_Fonts(       tLF    AS LOGFONT   , _�                           tTM    AS TextMetric, _�                    BYVAL dwType AS LONG       , _�                    BYVAL lParam AS LONG         ) AS LONG��  IF ISFALSE(tLF.lfPitchAndFamily AND g_FontMask) THEN�    IF g_FontCount = UBOUND(g_tFont(1)) THEN�      REDIM PRESERVE g_tFont(g_FontCount+10)�    END IF�    INCR g_FontCount�    LSET g_tFont(g_FontCount) = tLF�    IF (tLF.lfCharSet AND %DEFAULT_CHARSET) THEN�      LSET g_tFont(0) = tLF�    END IF�  END IF��  FUNCTION = %TRUE��END FUNCTION�Thomas Gohel                   UKAW: E-MAIL AND NEWS READER   gohel@basicguru.com            06-21-99 (00:00)       PBCC                   518 34229    UKAS122G.BAS' UKAW: E-mail and News reader for PB/CC�'       Includes POP3, SMTP, NNTP, and a RASDIAL client for Win32 DOS boxes�DEFINT A-Z:SHARED K,S,B&,Z&:V1 'Created by PostIt! 7.2�SUB V1:OPEN "O",1,"UKAS122G.ZIP",4^6:Z&=25341:?STRING$(50,177);�U"%up()%9%%%%-%%%fNKy;-DJ437%%8S%%%/%%%%jR%rfnq%SgfxT6?fASjmkNbyk�U"367QsI/gNabe;%kY)OpAu[gfV?5,JRR<OkAq[AO*9>c/gVgF*hr=<7OZhYY+0DJ�U"yy[5ls4J3_J)ax<Z>uabLkAvbRdpnX+_gR8n(9.)7RPz=\i?l4dFQ]F'k^Pujiq�U"qaC(t[Ir7S=asos9,(##\kRlGfnVEV\mdDgUsQig0rbEa>&jCkWKUQV(a5s>1'r�U".ac.c3:e:Ta4QoWkD:WsFsgDIM[K^1q7r:_(3^dgdPEEp0>sN7fV.CEWE.Ht9Ug�U"(s==g8k+pf<]U>;3ULPp%\2,<8M5v.1\M_VZi8PwgtnW/u/)'f&X+'[Ng?M5(07�U"z\=L?n9sRWa_iD2D'F4JoL)20rSn.C0O:.d'jB<_DmAx0&B_l9X<da,Fi-$LLl;�U"^(eb3UMuCXyYRIdYC\J6sVE:Ws$kAASc=4;1w/+i,:B[*ae.01dnv&W++w4473(�U"+_UM+;Mt5ji5P]i?JU%ypAz05iAo'm6*8Ky2>'HL=&h$()q4'_2g1CLrn'LF/,J�U">hJ?G[s1:;phLutQ\vta$kj7O-<EHl6]);%sdIi0hJhOpU1x0/<>[G=-1RWAfO#�U"2eZA7tv25o3<'c\G=oEEV0TjL#5n)wn:$kx$A&fakR]EggL=irBgWju%76q\+u_�U"lpI\1tlLg/O\C#S75XJC)(,tj+.Jl8pm[c^\%gX3oMNt[+^O2,?;TVaxPUjQetK�U"ZocXKKJ?gJs=AI,2Rx^.qCzTS_zH:Y3hU^Dm0SdjrA)71s$5tnn%9M:GNIL%HCB�U"<b.n>_eB/g7hBph>j_s;UXdkM\N+dnQCgs>/K)fXz.>0<LOaL;O[U]=;Zg*HP&m�U"O17gyBY21MruEM'M<1Tl11,p2pb,pwuS0dmnLh<,cBYdcdyocU*Jc)T-Dn^GBY^�U":v^,o5CSc(ePP'qhw)qc7yO-)K#]r9\tKBpu>)%rKLLGpV?0Fl\-Aj7Gf$VF:Qg�U"%x'v/CX>Fc_SM]XjTf3i^N2-APUT-M#jj=R^k1jm=&*Rp'/hq*F2=IJ?C>z6Eta�U"dt98tG%Z[C1vW3nk\NbuM7NF(//>I1JDDVlJnNOL./x=UHF\&m%duq,Yg<;1uYo�U"PJP:E%&9ulfHmR2R]^R;CcHbSk=6+CGPFLKj4mncQ:XJn?SmhDbNIFr<Z;rg6uV�U"ZULhCv].XqX8NK()$n18\tw*S-NoL.U^WJ=7:h)exZ)jMUuUKt^uAKp*b8.6QWS�U"q5y*I:O604(ufk$c-c]SHa<'2_g$dCqVQPi<<VnRfG\Di?;dM?7vC4w/l'v&b>?�U"_\X+LKG5<l6/(uvplZlR&=M9]KSl<jEZ3QiIJsDbl2n<^O&gXh&WTA9]R2^yptn�U">V)_iu^#9D30l1SgFr&]gK-8#MlOdAy('nh54l#.vK#,94+;Q'BBrI+aD/wmK<)�U"kOgxv5WFs[JZ(p'h]>_YsLo/Jj]^XA%OX-JuT,_[u0p.-B'\[4LG)uJWK6a3-AO�U"qKgIW(4)(bV<Tt-9$j8?a3,1Pa$a1)Moldf3jftN9640pX>B<?(_l,_r&'DAr1(�U"7LlXD9UM;IhG93F?HYHROQkNv-TaC&[+6QvX9'[tQd>jP=_PZFWW;u7.mvl0/*x�U"vU+fx$?1=s-_Ds-o([4A0O5U7?Y$l(hgg6eJ.Dy3Mb*H7t'H#ffeJvfC^045D&l�U"3b7$j?DQT#H*(cV49Z_CWTE4mhXBX7v:,-$sW?r9OtL]XJw&6QC6A_EoyRTmLO'�U"QVn+QqUYMR214[<ntkL<<,\FsknWn+F>t-BK[::f9p4H5FkdPsvH&38%1s#zvL0�U")SDAttj%r14-XOD\]72OmyanaM32Q9^,sTfy.RTaK&AasA?S'E6Vk.W=B>#.mHQ�U"9rIvV68UlS/j.[ZOz&my1x^yv1oJLKst*xqlxN]BA,mYu5p>O,b;r#Fl:$7SPI+�U"MWRi%w^<OES'I&QkxSDrKsX6XXsOfgRoQR/4R24Qx^1\eL.Ja8;KGSS#ab/S#uT�U".ccOd0+Cn4BW5NmO8dcIoZv1VdPjy%EYqddv2RW/A3=Cp74'SL0<1,Mj]Sx,%#b�U"^M4=Wb2+s/GL&$^HYo/xXJQZSI41MGw\:-EMIeU4/?ud^BXmJsw.?72ud7e1NA7�U"YJxs%d[e%/?Q(B_j:suH#(Dmbo4b%(h\ZuIFr.aHY[^R))',e;uv#VYXn-57-QB�U"6Gu)Hf1pw8di/JvK-nXS\QVv*4bjB$FpYz(X=YA%C]n7VB/'*Vu8[Qs/dM8dF$/�U"_#:iX]NmgJbx0QH$vAB<:P']</Z==psZSsc',rm)Wdmq2]C\gb9%d^ji_#I'[\^�U"e&^8>AcL8RR1dy3\?t'GDUVF2kqa6<J\KrWs\I<jZDTA:#.Q:0\BGB(mJs*<.,L�U"OV;Dq:ke=#qcd_bs41\<SiiUgc'/M:UnQaw*P&IPzap-.^iW0'5R7zO5k_)[vLQ�U"ImRfxl_^TX.1hDICxguT3burn1+(9hO#q19ce9+5aq:+)a<h%z6b/c)tHFawXl;�U"Qstuf:bpG+Z7v\#<,+=&gpw=l2DkY2fK2%Pb'B8i:,GoiKK3Ki$#8CVPt8La]\)�U"8EDM:E(,Cr)clJuOJ6w.[6bXa\qZ-m,K')15cUC4Z?=OiD5koeUddU6I&BU)P4;�U"5:Sqs\1Q/*_i.aFCEQjgK7KdWxMNDTrHjOY+RoLFuEyu4;U+E1s/)3WYjHyG&(&�U"s42vMJ04z]E8#,Ug/o)+#GS-1cr\&&1hu7Z2a_Jibo^t60E;/8vfw%S0(agPOU\�U"yg+598WRTek30F.U:J,Yi$$SMi$9_'&x/M0Sq0^'g=O[gHk=lt=1mF1YkVA'%I;�U"L'9jT8r_s)-g/PaAwPl$HuWOxbu:yO#zHZqgJ&KPeEc#-RP7pmibu9x8QN&O;OB�U"F6\0J#=A&W:Q2:lWKkzg0W%Ovo\f&OrM<;S<Mse)mB.$*&HlC'-ZY$<Cq00ogiq�U"A#vb5#E&nVn,#yY?Z*,7vS'tC9\46Lof,MU=5n4IzYiTEukH:ef\>,ks6kdFb-T�U"auf7.ajwTm;<L^[[%m_sS[%#n10_+KlDof$F[D3'4Gujrj()3AElO<Ap>Iig96i�U"\=')G&Ntobf0eBsT&lKoMtVZ6[PBC)6O/E]FFAFlpe%UR=q+6,%U#C;kC]e^l/R�U"Ce)5;rA&k1#,/-R[OXXIqFv#(.l$HB>3>'DLi7BdpEm-8GA*9Qjy/&12Hq\J\oR�U")?qk]:I9?%?$>X5dE1w)U7DrIX)kLYi(=;.Lk3,JguB.%T\.)+<qG<s,*t1XA\W�U"CLi>0ep8JWCMm(Dc'772U/ra.+Qv6hco&]eSOB(B]:2[(O0yf4kK?l1<U:Dc&'P�U"R'\06s[,Jg,9SYsvJ^$N\syEL(,/o7T1pDh40?m*5;?/lppIT7Z$t:iLj8t+:ZW�U">8y8W%/[4\MX+n[AUaTG*gnme\:\pJuJ<b9*LoS3&xC&F'gt?b5q71l\I/SNqa<�U"TB8^nqyQ:_Ue<kH$EWH>n>#=T<ImpR$IF95ul;G'Uk-tigt<+auI5V-K?8WO0UG�U"O0Tw(/g1*\.=(Oz*28z:,.IguM7KF2w].8#Qb:9TS2;Z:[skdj7MhHp:VCyk]U/�U"\#L&ZbmFj#\bmL%Tm'duC,h3&w<rlo6td7Q\J^xQveCnbsS.'e$Rrr'Y.XWSXD?�U"XpT#L:AEleMnCHO<loZNk;;6)b%z0pr]'xXT03_HLumR:ag0vtFRo0PAd)dSW?<�U"Y9kJ2,bRNc0dM9r)>GU0F0ds#*3oP3gO2,dC+Z\4$JrC;T4&/H\z(3N=mP(cBCA�U",=u06),Tsy3AD$,]*5tKGXLjkXR?)?B-^19I\UaZC-[A_C_#Gcm258u1PN=5/Dg�U"rah;Xj(\ZF:<cc*'C,+67^=LXjBL^B*Hns-&wEc:6*N3)gy8]OuBujV5(ik-Mr6�U"sN&V;zH='[.<ip[EEbWG%(m[_y*ml?_G0Fqd<ODK-gy;uB8a)8rg07mCK>2Vm]t�U"e6VhOY;zxDzCa)E(mLMC;(Q\\$:pG&r9$0;S_hzhkM&JgR5ChyC*&T$v?2<Vubn�U"u/=&<ioyoUtdo_[7JeCW8Y%8qVxgO0NBQ/N8d#PqJ7Y6?.#lURMSvHYgP8r%DeS�U"JlKfh13v+#Z0M'>eGKKAYpuStk<XxUDnJTDE<OGl/cl^KrDIZ#Q*k^:rVpOZRwc�U"-6\wZJpMWMgQ+Zf3Oj-2n^4w[ujBmv/3n04Ou]eoRWU:956Trv,(Cy_e&N3NhU(�U"1hjJlP91540>_9$f'njqJ4_$p.JhJFHhb]W^6d&>r[^6e=c?9V^S=93$e2&,LfT�U"OG$j&sOhKj8*YUhXU;Iqy0WaKQCZbDvkS0SFn*&iap;L>uBW/<)b7ZbEX<fZf5E�U"J&Gse&],fPekS*D0u8UVX2m359J<,&GAW*u1y50V4VhDpJW.iELxgJ,XNmSw>$:�U"V+3kgd)IhpVF]tpr<QNro#tn?JW1F_#z10Spcl;e*JaZM-I)<*U$x06]hsf;a(]�U"vPc>B0\WEvh*ae/pbR.+Sx/:XV\lX:xX04pyjG7pfW;1?6auiu;T#fA:&)bQ_X]�U"]n>upiw'X-<x0u%p()9%%%%-[%%%N=KS'Y-tL>%4%\)%%%/%%%%jRs(j&xS[gfx�U">ga<BS=]0X$lLxose#\Gfo)eKg7[#LJT=nvcd%<kf2E66W73-ixh2B<Ll-vExZr�U"NJZORrT3;JF_WRRVK$PCWCCWG$%rsDx:H$l6l]4D3LdiqOuwCLkFS3G_BaSEcEp�U"N[Fks[fAFsR^hVEl(0Uk>05V*qpnJ3jX]<[i&nqd_GRhMk)<nXHgvY'u%pB7<6W�U"0+RY?r85U'Q5tvAHG?I<<hS*&s8qFn?tq7H5r5>ogQ5?SM-tq5jfP=b6s'r>oVa�U"kDE:SZQuY/Q-4#)[G0s/bDUM1sQD53rpwgWp.JJdd.^XTZEsUacYE^-YxQxSnd4�U"CT'k\:K]DNRY.sEh1t=6hp,89cQom1u/$wFaOAV-ao;4gqes\g3J<wq%oEL<p+L�U"6o^Wft'?OY2=.F1_?[3cLk_)7MX=k\g5G<IJw1\pTH5['>4_fABJGK.Xrtb-5hN�U"rK()WV3dKZs]D[&4wc[T#61+3I4lRhkR'=#OhHl[fJA6<7]o\5AJf;1CYAT_QoW�U"h\\l6FdnAYKIk/]aG9-7]eOh&?vB-JuRlrIDx4YY#Y:>.P4.]rQ]s.+(<oItL<I�U"HOo3i=Z^8.4k7X+r[*K,<rU;>1^D,N.:-LU-ldvArx+<[il?hs-vmLjtaB0?Vd'�U"R)C^8AS3NEV%4fiZR/RjvBIt'kS3)sO5G_Z)l\a185)Z3CMKJisEC\/cO^93nQf�U"o(d2^CS?&A3Em:M)?4P=-Yn_S)&w:isg,NpsAn$ZqGP+dO>y49Lxf^/T3E8>TIa�U"3=GF-;.wH68+cU)J0=sG76lDg6Un9Z5[0*dh)]Qa,_%ye\gy9hfD4bROJQWfp48�U"5qkCphRnH#v)EbC$,UwM8.ST]+.eD_l$HH'lbg0Q.1Lp)U7;<T4,rb&+qUqiIQf�U"2\B#9PdkSK%ry[6Bt)IoZo0Ke,AV34ja,*P:64'7>s,YgpQ7&HL$U]-O2e[oRK:�U"wT+J*mWpe>hRD;^%gmWYinfgATF]C[3U%orWUpzT(>RYks$5/03(Fh[0?Ve<QQ1�U"?A0Rr,HnE^a.R+Y<6l5cd,SKBA<SlI^SwRFDpYhAE2mO6iC24EhlXs;.],Qn83X�U"CDtPkUEj<qe23KUU:_G7ogY/[KK]5\%IU__DchwRu7FZJ;/KBlf-$45/O/6]Jbl�U"a9e0z?(PA]c.q$lY>-$OKJ3v)cpc&X,,Jx\:#FbS=U-BIWQMxJz2gm+Zs24cgCU�U"5+>R.>:d*Atvf.ATI+1;FY;7_.B5J8h)RiEk7Wh*+DwMDYqYZ:]YiG?D[OKmsXV�U"So>noKoS=cKPZItJ\RCwxlKHKInx4l:Aaa;Di4Fs2I8v<Thm?cFN,3^u,mMf5ZV�U"rD4m'Uu*ewp#ks>,o[^v80?G19#Rn:W15tkV2\^'/>eZkWR1E&E%'TVjw%P)FNK�U"8L/E%F-:5*CMD3=Ox?coS-+J6Id1eFSO;G'E&J*KMh6Ma$fFRNN7(k2B^>kYSVF�U"orfvsa^+D'Ln/zQ-<oaqW7)L:,6oGMF&(A*Hl.J,RN$a]N8<?b*x[ge-GG-\1Ic�U"2x/V#y_9lHG(+rf2xW47_TdMM9oy%i>T9-sxs#wpr[Nw?f0FB#=^:+3Al#HWC18�U"t'oEvE],vB1^Yw$^<Ez+dB.68Iud^mcBGB$m]n79kY=gFkr:\nK/ls68;>A$2)v�U"TYw$tt$w/LUAToh%Qj6whIE&5i$JZA(u<U5M..%3=oZm5U,f#r;l8JZsAr:+Ulv�U"Dii)DJ=G)xpJ/&2$tvX2V9XXU_9p:G9O5o-q,Zfk=,IRPpwJZkc.CtOR$MfQ0H(�U"5A8M)jG+02Uu59Je;=,^]vg$>vekVp=_R1SJ_)KJ3?ZJnK2BdJQLa8->2bBH>xU�U"uifl[(+Y><Ja22:R.(V5ktf[,OA03o1N)YQq30\nkVvTdNyT-kGBW3'<n7LPc,y�U"P(_Wr=Fi1;fqT=t3^^K\LG*V8RjdiPl0gJI;lI#P:TAe4L0OoyhXJ3&8ri_>tM[�U"JATWX$(U,LguMpxP-6S#Tn1F^/=cuR.1T$:M<LqI64\m^QY3UjL4qVU[-zQ%MCW�U"q$B^biI1FU_dL7ZG#iVFq5&'%N004zCwGzDasN&s./tX7)7AIJ<9VxL0;0a)M],�U"ueLoz2-0r\(K]TY?.,C20io.,7Q8q1'1?siGBO^-u>hFw^a,]X$DcnlcNZ$WHc5�U"w2F^N2t%_n/39$[/XkjBsh73U=8G;g[hpB^=\Bh<<3oC-.9<L(2[[zP/Be$mk4%�U"J'YcsWi5SkGFc>.VlEBGSgy,;iB[8m&l0/M/?QaO7Q(uLgn#V_;V,?biU1[NQeO�U"p=*6(Tq,J)Ij0Rw\k5Wg\WAQwi5RVpv0Eb5H)dr<J.kn#1RJt4c[d>%P)N&RtsP�U"pfQ9-&66]&:yAm*Q+]PjRaj:K%cNm,gb:FU%X?G0.V9P#&[dG2P8E[lE5y1W#CB�U"VvCrm/aL[a-KUU3%j^/J09Y+Y7MlINuJRUZHo1[3+d1rDZ^KWvw*-YU9S8GNvz<�U"\r'g<t9_]k&gWlJ7WDw#pth)ZK<N3nUSUj,/o6__*T1clSjCk]<?r'2)z_o&mz1�U"lPb2bR2$1jNEW7]g%$yz^nj-+/5s8iCfZ,odFq,Y7qq#121XAUC>Q_IkT/0%_7f�U"P^MmD%?'>8KQe5(Ic[%zL8c$Lh$o8_[x?b4w<=-OSEghi(?IHMSZR$jU^NJ77T.�U"9Jv1_(gb>_4'=8;p]M9D7<Zf#7AE?RNojyQ*C2M'1+R^G.=qDl:*rJxC'O'W(Oj�U"/)[jW-N#i:)Y_3_R]aHO],1F3%E[j2e8cK=iEngB.4PlG^dFK57)?5g]r/'suiC�U"3c&+TtTswU:]Kt4$L*aP^LL<o]Xn_UbxZl.b+k05VBc&_77>\7Y_C5Kw7shFI;l�U"+J&_Dz11Q1EPpTLbBLou1';PHw9%r\=FfaHUJf,IaJ:/8wIz51iPD2kkjndvAFw�U"nnJeFak^d*rO$Zvgl6*7=X+PhS.$G5k:4lgFCci'7>Xi7<>LOZ:FtpHj*UuPbY5�U"s$)=;UtXgb\f)/1:j<xor0Gnj&:pQE__:&1scub5J3'5^4[&puWr?Hn**K,r%3:�U"Y.=sQ-JB%(lq+m0ZgZCE6Mc$bR&.hciN'Jj#=s+:#M0SfsBG/p?6>SqOO-M&z=p�U"vRGL),4$rKFYPzl0H8#3_ehTV'B#Ha4o_fg-e_wUpZx5YhaoK#_=_I3dsB1&[I-�U"=eUNhVobR,tg%*-;iMko]3QrBy'jHp-SXgHh5+^z,AySMweE6:oj7NkO3Eh]-hH�U"W)rm\+sY>Ih9&+eg=J*3Sb)UD<&SEk7WS5gHa,A4sG18AS24mz3LHRv7ZVimGRv�U"2ta#iDWyU?0Og,(oRmtP.0iPZb3O1J-9=?F?Nj[6HOC3Gpb6Nn=Upl-oob<O3S<�U"=n$l'*C/t+saWJ4NqkXNWsDbX9U5_K]B;D9C*/h/$UKR$L'aVc778DG%mWj&.am�U"1T,p5J,s.LsF#cV15F3q%RnCcvA8\Fu11$Wn14;t$x3^RTcN4109u,D3/mZMMHl�U"o\(J6gKLcHsJ(PATik1YtDV*&eEMxz#X$-aS0j_Wyux/cB<ObrY>kknVB#PnF\E�U"zi-oD;Mnm_BiDWQ2Po[fHj&uCLJ]us<EnCAs2=r6FgqD9QYb77xZ$kW+O3&l$X&�U":OSTq%(\y^9C)W]rhnuKGL%nD6Yb/c#L(X%tN$96#h(Pi,bDRnJF,c/^<v>Q=c*�U"Xx:;F,Xd'-yw#mH]DUnwLd85f-sajG.&qC*ko39&H0nmn5HQ1l'EXls2\cQRw[G�U"ra]N1W&sdaPp,r(ma.6[#x/wH)E,E.<W[$5xbCUbR)OhoU/]AJJzSmi.ac.J0_h�U"JMi_MB(8=O&9'?[hl\'#WBPs3\2)GvxnU[KEIGo*do[vgc$]Q%Q-+LHES(yCQsw�U"<3XX<6kt.sghJI&%UvgQy:.0[SC$iU.oIoYVAv+DiXm#h-&(h2xs&Ad$F'J#Laq�U"oNXGt8;UCpsM,ZDUyqSqJg1q%ATY8Zuck?IhO4]R,b+X>Ympli?<SlYMB*2>#z8�U"gU3*Jva?PkWBe\y#L:[2$4#tZ)V_e_ZGjEO<&bqtiCSZYQa,rZcnt/4iK[Lmgo8�U"];tY.I=G3K<EQnJ+eS1KMX_(=I0QtD$Pgvmuum[02\ATQ]Ds]B$HB_^'4eBL9OS�U"YRI(VIraq2$:q$]:E$IC'#*QpJ5lvt>Xa6DTL[hx[?WrRkk31sO\P-m1J2L&h3V�U"qa[4\l+FK=Y)*4(F.Le)6TaN/c;q9QeR/YSXN9#hD6X(8go1P-Qe0MQL9+FekM-�U"^F'qOXn5Xt.jcu%5n\7nPoH_5#wzv[1t2kJl5IN&.gpJf4k12HMk85sO]04&>*+�U"5qIXD.EClb/8*PCUoVo5'YlJ1$O5_q7Klmx:fr]RnTNgD.dB&D&a?;J\S^Xb)#J�U"Bj:i%(S^ghGc\Z#O9FzG9Fhzupc..>;]]wE0BB*&e\ViE'fy7h6i;\JGca8:\xW�U">*)=NG.QXsu)ejErqx9rp#]ilA\zHmx$&QIF09]1u#am6o%HOExL$aBH9+Nt$D#�U";qW&5.+_d(&L,V*3(x->J-wI1L953[QR*aBmicbFF6>D_BrMR.kc#abw3^=abwX�U"fCN1ejJVZYAx3Us:p8#gU*yE9F.evtVeQM4mNm^3KW4&0(rkO'JJwz=\qzWh9#)�U"=GpMQ]MLqF,G]H[R-hxn<G?98mh0&9QX^-.\.,#'0AN-\^8LWquTOTm$UuI)QF4�U"1<spVvxvuc-'Bdg+vx8u?#g^7>_PqsDCsF_w,JjBo1.C0Q+R[?XXx,aT+XM=w,h�U"+LGcoQj?]No>RI843jZi63/EmqPsa*,;zva+;stDUevzg(2KD3%Ld*vt&Is.]1A�U"6inERe63q$5k<qM*od8zsxuTx&)<9[n6/,O)Pn4I7dj<lIKif_Rae;?U/VTF.'e�U"_0'L)c;,1'NU>4n(nhiU3cp(I^rsW;gZ)-VDyx(9ZC\M<0CBAZcZe,:Ud<:xuHU�U"XU6I<iY3XVs(hfB>Y?2<\fNmORCFD&6]Z+txX8e]EQZ-mJJEs9gOd8wf''iK9N+�U"gO5Q-\;<k)Wf*pWnF10sLQk<hiq1dPN2rv+G^_*(bMCy5XcOQpUS33:EePu1%J2�U"%dADu3POkY1?oI'$GU+x*cPhT-e.kJ.G*G8Hsj]AM=%^7'XT)-NA8WA87N2n=G1�U"(N1H9iO)guyas*,Q6#YX/f7QndKD(6zxscghxd%K6-Hn9mDpaekmxSI[2l4GF32�U"UC**t<^NZlU6.xH<WP/JqR'(kV0O[AJ<<kzh-&,>NR=hk:mw3h[,>%t[OAyqMH4�U"iF3>5^O)YlFsImu+VYbT*f*\*Yd1d<10>Dje_e1tGP,pX%E0fp#J79n='Cv-F>q�U"/DM<R]Z&8'O-E0X5SG5]wM0'aMWuEmB0'SCuqC?,pZ>eGnTeYuBSA6Fm>:VXD-4�U"qMY;lRk5?FCOaX2a7:?E#A.hN16?\-MgIAPHp^Y2e,tET%,losiZ[pms8kFC^[)�U"IzVL]iTsR%,Gy-O?%t$$.sF/8tA9[:XwSkrYHD:O#2wYu4lMA^yZ?14kYd+K8$X�U"PT$uE'%_09<FYnNggSUW02.x671EN]%DPv*.2w'uL&P'9Q$mX4$ikP,q'eW)U4r�U"jn)DRev[m^1:??]#d]5]K<^l.JpNmTE%22<oV5Kjh+>x0FWd^TlH;z#+CkF(KVs�U"kr'(Z+RDLNMu7pmKsIE>yGCRa3#.EVp>,$cC2yFA1Ny\f^rL8>[#\V3=bq,]3GP�U"FC3V)V;RP_U*Yn-%7ocjH>Jj79RDp_r:ffMef-9SO9?:Z[M,fqkZ8Z-BFquYzBR�U"x$7^9Pb-P,b4PikEF.-Yjq0jb8FWcPSzp[3k9tsT[I[+#<ws9=C]R6iDUT%xAS9�U"IlSig8'/wO.)*D-W6a4bTWu,RIwoQ6;Yf3:cIV5QW\cvf5qDn2i\+'J1O,s,Gju�U"\R'Ksj2.+o%Iu0Mm4Ykpiroti0bL\bEtrl9Q0HUhmFrm*bglID,)'\p6e^\bpM?�U"fM6^E?]6wMbQ(CZSkPUfL&K^f^/DAM_&ulsWZEc&C8_GZf)Mshkj5Pj8$dCRMoi�U"bJk[T,eHapq+/9[]lwnb39KwJ:ds).Aj:mzwKLx,vnR]LLUMC5+%)n;Qjg5WpCv�U"%A^?RfL2B+vVG8Pl7jUq0Gd+3Q&'8%SGc?CS=wi1Rh$%3n,?]C(SIVNmeS3_uI%�U"8.cHFYjt?CFMlvp/vo0yS;ai,,8*VBI:9e;LB.7gtRpQQlpr8,lPCPT+Yt&Z+^$�U"-B]FXdTVv7?Bl=cHe/9U%u_DCX8AETz[Y0%7\4sr8Fa/?s8_q,7X2VG:FWU-0TQ�U"iIetBwp;i;HB06Zw+<ZR1TH_ooPmv8z7XoIQQB+IzT3z^d^v,onOa)jv(&0-Gqv�U"wRUkKnNag9_&AOpI?8h>>pY.$E18*s/(,tHz_w*WQO$Ki>r+bG-i75k*b_Uk[Iy�U"bHs4#Fd:P^kbtq(oj'/KKZS)l1,%$5*0+6Y>8n[jN.EYrLYO%2iKUf)kU+\WC<j�U"D0xr5n4z%IDp7in1>^)TUnl6Vq6I6*:fDSwmWZno5U*(Q.bZ$q%XdoJ*KQnnTfH�U"_$K-?gEgEr?-O1KTnOQlLt*Uuhq'=R]$/)x54PnRa7V(&)8([/'nuTf/oLP<y9?�U"b65S=yf^&Qhu_mr+MhbWBP*C4w&5g)e:=VKpOeYq2QGtYwu3Qu+GlLU&VG,KIh*�U"^4C2o6<&A3a6XNzd91FG5uP^[c]Gkdo7/pL#:QYTIaL#RmM8^b>#]gpkYqRign,�U"+-X[G1#6qN1Q_3v[br.5R#7epY-:^DiwHu4khLB>K1?j/LU-.CKr:df(>;Lq?O6�U"=;YQd%:V*V#152RD%.*+Q9]T>/bzfA[>s&[.I]3y4NDnQ-+fSd9m;&8d^B)5-FN�U"QVV/<=]qt$OKBB8UvrUY]vY'Kj4Hr.CHqnp%,NeLlPI+H7Nq9e_,<#>]vE(HTUK�U"s4MUQf_<h8iKM;qb%Nab'ry$N(cR23%3NqgW7,iArQ]Egy]#C-dJF+8ecKYk]Gr�U".tI)5k]W5dcpxx%QZ]sPn*C>?bLgMMq8WCfO=K_pt?Wua\FB'_>p4<UJVj<kjGE�U"qKg'0.wWfc7r><?^O]2tFARI=1I/4\a3VWstltZp3V=^<FgEoiG\P:tP^BYdg%a�U"n;-6^sM8Sasx5Vr)(?TuYO7Q\.i\O+Eb=]pt&GIRqa&-xRe[:qawu6Ou=P51Nr-�U"s:3#2hwgp9+>Dbd%82<#4;Qbwd+uEhP+lJH>C/rofB4n\DRESa.3hMJp%^#?7M5�U"z8Ek6W'3l9X_mbhJ0;afn'N$Q.AOtVm,Hh0:ght++n2TlnE>b4A&7G$67ZoJumk�U"6VT&'_S5o0M-1rB-5-bi9+XYsx[*DmD0PAT\tR[n(lcJCNAMnE4T4+'GkM=im1N�U"+^/m?z49bBrmt*(*\d^X;+NlPHYY>vaZ6:,1d,Frp4xltOxvTV/IKc72IHo8H#_�U"*Fu+^[OwaY]qB7lmvzGYpH>kpeepVaI*_\=_iIpE;2wNO1gXbqU,iX7-R=4Nt\a�U"nO?GALj7HYqKk,+BS$ZjamRAhOH^FkJk1M7Tl$3redZ+'u:>h6)nZB*MaO9n<DQ�U"3q0GoxZD0MY_1>YECD54*%GU$Rtr>lrtKN((fBEeu]hL?DJk[&N6I)6AYjRk677�U"v73Le_IZm\pm0]C#3k'q(A)14q0;BJRKKNTnT\t2R5c[[TS5>4\Wi*\#1'w99ZP�U"m[5NY]*QNArq.[vWAFrr2b;+lQU9AVp%nFB8S?^f>;e/)d;s4*X0RGSdEI>l[gZ�U"2IBTwf)ndXgw*MVF*(z>qCb9=D\;A]Y-.?s#moiPJ?jIH&SnB#-4_39Vx:7V6LF�U"bPtq9).SN4?i\)/TEA,^<tBK8wI1XgdoRtnb//)SLj/0deoTZB^N$Xelt2he]ob�U"t8e8l0PtKg\sCgIqpt_+:PKh$(+1MS\L8f;ZP5pA6MnN+9(,$jmx7er/%Q'X:.C�U"$t[Z]_S5U7cq]49U::t)O^t5aDpyO7Fat/<Za+XC_K<f]R9X3DsK[\N)8&.?4DM�U"Q4,N<97dt$IXxLQsJ8fBEO]M/n<1jNtcp8-Bi;nEd>7dK_VhY3JfZ_v-Dk.9tL0�END SUB�SUB V2�U"8L9(Ld$V(aOv)#ZR_lSVcD94Tf\=a*tE^6WM5RXA&vcUi\/Hp0_GHEx)wFRnSmf�U"9=P)CNx-F=*U7BNrGj#\A#Z4;p;ug1'L&A]M8-(O9b*5a$MoZ(DT*f+?CeIo?3m�U"4pr>H[u4xW+NQCO$C0\2ACv79HX^ZC0>^_O1G<Xq]5cYLCQcouT(7_[RiD?(N5<�U"wFVIOW-m_+%OTrQ%I+RVw:O<uqJh9Df'h3x\F.lfT.jW$;Q>A.3':'0tgTWr3't�U"8m0hY8H.*u.up%()9%%%%-%7%%NK%K_(#&'7%%'6a%%%.%%%%jRut%uSgfax6$f�U"DEjme$xBsW)pefB#6FjAFW6$Y$*RJ]H)?gZ)?kqL'#,0I'Jfe(r+bw6b^)T1P>+�U"Dz#/McsR]$,zDC*uDrdMP&,*0oT,-w8drHn693xpjPBn;Rk3(-U5m?H&8mU<Iw'�U":pwdR/6r[NJ7?A<+Ponr-Zv99BmX=lRT7$bsaWSSI&c=uYdV6kbszFFcR4%0JsQ�U"fMUb57K_,-Y2k;[C%DD,:Vo&jLa?fh068vRc%KPTB4as0VKqKEl#14DrlMl_d+L�U"WO0'7HdiHROh;7)8B.['9Jw0?4lEohgpX3Jdb)6vpmD3wX=bpd4YxD+lcNpK)SK�U"-5*K?R7e0R$>TJY)%LcVq=u1j;%n8c7v<s%'0y_-MC*r0\-3SMn4:DK;k+6cY0i�U"HnSDCL7ZnngP\)rf8h;VrZs-0Xh*PP<Or(VqlHuRyjL=ytpQRFK1-d_ARi6;$qq�U"'*Rp4nYsN+Wm0IV+8O+RXUsx&0-mZMCDXSg_wO3C<ncwF+SSa(-z]ja=CU$efWq�U"f*g2:ZWdekVqal^FC*)+m%<DH4]v*rp-jS4'4dn%vNaewzjMpx,Qj3+2aFoOS<f�U"kI2uuIdg[xT6^^=BMCoTMFi2Bc3BC^YX$WiyH<Tfw,)oI)J?%4P--jPL*LPiw/7�U"aA>$#+43ej\u=MjpL21mW+:%DFQ[QX\EpT:H?hK(4ICMlXs,hPWP$P*a\9T$-$$�U"deu/j+&qjCjAXB:YYZkvpnn/Km7D4:DbCi,l;<LGeI>x$1.<_'=UffeXp5gqhL8�U"1A+8'qs/MXN]Ege.GvxQ$l6f2UHp?^M(bUuhP9NuK/mro^p_c%*e5L4*pA5CdeT�U"w790_3]uPrcDvh<5]T)XtBu>g7_9aTuLnXV]3k&L+FIG5ol/X:lK5BNEHG0Q#<;�U"CfJdmF[mO&%.[NN[tE^5m.K'#H]=sgg*#)PmN1:7xlNIuvUDLkON<b1j)1\-24L�U"A6*td]0un5BNh\dWbKton)0Tc(wtpbrEXEZDcV7vtdi%GI,+&OQr);q*[cGY^=V�U"V<<+t;Bip1g)A-fh=E;Y^&Iv=IzpQZ3UNMeG&mK_K(<J2cqblE&H31,ySnMQt[<�U"pG);G5I.GK5U*5KBC0dJceMGc$1Sjj^o'o\tU$b?qu*Wp;Q0CI+h3&8vxds_nf%�U"'mD<QNo^iPxA-j%+rVTGGdP&-wrsUo$fCuAxCPO:q\c?y#d4Dk95FhONpTr6Q_+�U"'PDTEn+L?U&'[4WLfyIXG=m^)m8g52G[D;Dj,y-V+_mMhknnUPMa4ji[=:9&y)w�U"kO:;JK$i*B>B'N=6AFuekC<^p'X&r(20]C^Lx\t%F?4^f'SI_EazDQ#FD_=R_cK�U"NhMA)RF6h/F5qIyY2$Nx[;:QA3z^1k)5L?zS:7i0^ZENnOWX?6T(uEgm2G5DB?Q�U"#4t<t8c.U]J<0DH-F$JT+M&$+OQ+DdyhnWj&)5xi\M_HJVfYh&.$$d6q'Cy'Cw0�U")NE94jUj0StF85*UNb$jg)gD;Ci3xk<oCpvhni^d_NhaC)^46RkfuekNHGv*+2D�U"UJT5C/o]fBKUO=6]%5Y#Z>^V%(9;JOwh[Ac>Mbfc*In0c:I=72k<2[Wh>lXhYtI�U"ia670rx>]Uk>5C.^2qYn1gcIc:+A;9nzL<h).lU)[9a[Kr_taHgb)5x>de<2a+m�U"h]SI.3]_+6:f-scglq.rVGI0,CwuvWKMpNiY8$/U1+k?S3Z$eu7+ar-ZmYt&FN,�U"xjb)Z7Pda8VGm1/^iAQMYj5X^D=E<SwliLIl&O1W6)S3l6;_+tpFBp6)m'1$Vpo�U"7*laIoMWLz#'kMDIh>;A*[7:leOrW*1PFm)1L4[;P2kb2*,xFfgngm5Hf3nlERO�U".Oq'KoJ6I:fOVjQS6CS.nC.e5U;BhTCs[rHGM.mc:R[sS\wW.-7uc&MO(q?%alJ�U"/s%qq.]MJUuW1*]48-U[',j=6Kpl+w.gI(&g_#>=s\0#JMI32XS&Hh9Ddrqup7x�U"#qcBtDxMNt2KK$A\wTPVYMY$7wc4_qgn0LxeX.64OdPCJv8#7gpJ59W_5J9ij*O�U"m/$o2(e8FVB]_iML:)&;w:t$.44d+i=h]GnZo'nH8Rypf/14.JBj41h-.zlDx'k�U":J7:SiIRKy0uI&WJ*^tC_q4csW#[h4-T[_4,eUg6.RjxhM$8(j'MVkLY6WotW#o�U"6)c5TmJ?r>2kp6Va>LtRJ(x%[=2s-wskki(-Me5:ZR<si*P0uFjDHGwx:E0'R+e�U"mEQIl_u[$Cjg.eSl=5hTh,o(?l'1B?.a,Cn'Zi'HJnyoi%cp1vm>vnT6)<5&<.g�U"isDwCh9WX8BY#5V[jg3C7QJxrXQ1_hp^+u(&y')eBm1=&(]9?*a2Nu\aoc\TmMF�U"=G&j[1\1:*MQ?a]^_lEjYF=9[*8erJo?,5&P'B[n+0?39:oi[psz40MR\VQa,)t�U"qVr-<-^kHY:iVcfsoeXm2tUmr[B?;EddBHPT+wM-yPKd+wJ<<)u*j^[0pX5A<7q�U"FZ+(h[*/]QS[j/hHAROU92cN12POsC$<-poSq22,8DvFPb_nj1jccGP0M?[vU?Q�U"\$e/1mme658QP[lR&BrC;6X$bg_XF%&%O.z=Wa$dOP'A[dN%ZcacTk2S,/M[rMZ�U"5Z(+sAH'(DlV-Jm=yKu3CZ)M*inF;WL.2MRt*nrs8MVVj-LD[MHP9q0w3ZOqhz$�U"X+TFls'n5-sk#9>i7]hf*fv3(JE*gGA)21df_:%4$d]WK,Y<uj#U-Dh+7B=\\hX�U"L51'wSWJ.Ol]/2?jVB;Huk:rlU^2uK3DL^np$28HQ,o%$w$N*n3SWNA]V'E]ZOa�U"PU#'sBSXZ:K[uVb5]1^/+SMJXKE.<xzM8cs4MjfsmGDK<^qAYzcod0on;>(S?PD�U"(F5qy1-6]M+N;DyAxy(4Gt&OI.rLHO>RI=U&f?zO[%52OsWnNGetPl,?sSUZ.Y8�U"^a3F7i#j[3HcLt%3]3l)uvj.4_n9JqW^d[+RVXu>I40B64inES90:IpLX1)^V6F�U"e(wgKrn*yXkr3h5h.7-Vj*ahS&gBGE'7f_t^CQmT?H1=DeijQ+)^4Hl'SrE,.$6�U"o*pzR&ou<GTMM7in3[6pSDfSDioMCZ$:[X;2g&R4\Ex]H:bxRd&'jL^kk**m_(U�U"#,Ne;FF9LjT=$41:)?cLE1Z7c1#aO>Yove^kVj>k/ZNRYlj$c='eP^h+CMUiG?4�U"S8d<)f>CT/h_0*su.Q.ap<w]QZWvB6%XRX3W6/TR,bJkkW,Lqdi%.s1?4jwX,C6�U"IhT'(^h/zM+,cwP1fou1VsdF^']nFQFRkJ%K94yNt1/axT6/BSMy=*1mk6F/SCu�U"O8Qnj$K#04ipzU/RO>6oZP*xJXFbPI_jQTr/=KZ4i>nd6OrU'Dj)%24y,Fm_;0u�U"T9B.%z3Skgr#_#7DVcwe7&[VN,rkLYbP2X3V*IL1QWmwpYikj5oF3Y)0U4WnWW+�U"JUanLU<#(Q1.tolBZ;cK$[sR0bnB-=0)6*8%\PKKZJn4m]z05ID<4*Ul.2;MWct�U"iHSPi4y[D&eAT/Xgb%xd\ly2=l3HcJ5?Q5LTaD^G<Yp#k+Y:Oc?#[/^PPkt++NN�U"EKpr]j)g=_\)NE[8r4Vp]jlSoBPdkywH821<O5LA#8pvP:]I2CYmN[XnvH/2Mv\�U"8te<&rp-\C:^edT,<LCdol0,4Xp_wsH\OrKE,Pv^6uYlmNs;L'XeMfRS(uW*X+(�U"l+RN(p8*=ci[h1(3uNfp)+8:keJkaTWY1(KIBQJ_kpOwJcl=\ktAjGTeI*pj70s�U",<_&=iP10GKJV/?YcF(G$rzj(3<7S/cQAke#s1$LJx(df%go?J/M./%I++&7;co�U"X4tjPgWZuY\owXU</s8IF?1.398o'#MG<$WeGbn-(9Q:m&I:\M#+:'aNb&zG#bj�U"An%m(V82-LfQ%:t83SOpRKE0,Yn=:-1fD\i;=7yUYx\'d5(nm9%c\faCv?9^KS?�U"A3Gf2Pz7DS5B>%F2\8(7Qnd?okS+([S,P]>>8DGnND7PaI.OoQ4%X?+>WLe1497�U"iCL:qa)/_Nn)51M6F']>K:2(Wl7D:KhJo/Mmgdr*CaWRH)dl9#i8mob=>+lbnH>�U"'*h(WQY(U#6*2^.*ae1Mr9-J]lH+E9lAFiNB\tWUzCMj%#Rt$qjp>UfetUP6'Yy�U"<]L,I>(3toLQv=j)F2YYd3z$N<Dp)Lk>R$PlM2y^%L,t&/)w$hK0pwUE*%m=N;8�U"_jmk=[-Y5jcceQ5HI\dWTFbK0(l5)Wt#3qY&Ba^mCZI6/%l.?_e'h/t_Wgxeisb�U"4J'JoJ/vcu:xN,jmLQkTC-G7XV*$K+JARQ?D1BliCMv/<\<OO2nG;ZoPcS#_En,�U"'-?vUPIOB^e-hQY:%In6QZfOK<-&chRdJa)9'Dl7zk,aBNos)=P,T'SZV*SCb,;�U"IwA4\JA5''_z:bn(6s-g0(i.?9wb[mDjFa%**rghYiRCIu#i'\PLj)5'9:Qq]?8�U",z#p/rnQ;GErU.%e]Zkc(I]i*d1n(F.h8z&pk_dmL8pWk_\2PQ+4^3n^'%)BGY=�U"M?8ZV<po<.R+ZBcubWINnHdU;sLH_:qc#D%6[<v$MPljp-pMYlnClYG-;k4S<RO�U"&dvYRIT=dGJ;$p3#l$URiAXDJFNcU/(h'K.Iuho\lzi<^RtEkImwS#5*GXjFcZJ�U"z%4$b8S-Z?$N4S#vt,_QB-/2Ej2)TD^/aHi$lk_YD2buK*$t$r9CGSk$rx?mBmf�U"3I(T&7%#Ki^\r=Mq5$<#n:S'V-AT(Y'U57fCvOp:E47i;lwa,JKEsD.C8h[hF\k�U"HKijUN5>MirjD:oP_BX&>dMKT3XR=fp[1ZH)[,ORcrT8ut?)4xt%EjC^KRs5dPr�U"*)S2]3eW]P-I9enb-1THfxh-&3vE_T41u7M,bn)1\PeBag;5as=hP0%^&L2dxPn�U"BInaqK9m5$_b,Wu4Snb)v_6O2W5z1*FHNP-f(_z_h1z:gnkDA&PylNr+4_.dJ)X�U"=o<;</3Q71>pXp+iaCD,r:=tHL7;HO[5CQghqK)9[:_6/;CbcigEE+,M.::IXt*�U"eK*B+U9sRC0Js['v1%gIK3G4xF1rIp/BF'9MxqQK:wj7$u\kU[X?s<?Ea3d[e_Z�U"CbP(y:5Oemq/TV7<gAAUKb(tki<dZs/(Ox7i;'/YJ<Z'%Mv*hiC8U4=2XZL/NZw�U"moUCwC0fE$MfAqT(M=sg1z'2WJ.Kpl53GjG.+?47:H,NhMjcV9[JC-zr*/oo$<P�U"'wo(Hse8q[n'6pVF'?3b0u>cB-hcp(VZw$'Fi0IZ80UiSP'btD5z[sL<3#1HQtH�U"X[;pFo-0NJ>0p%X3b#w4k3XcQxM;T*x(l>RzCs26*WYYk0m:&n>cHugk>s;AxKo�U"YDLk$+#D)PIVpB'Bd?AbMCrF<rQH.v^VK/8ZC53>zZ*9i*rY_/=QCB%sr^[)mSw�U"1SW%s(e=:QTpFsF.L9iZlec/DV*HwRW$]JinkQ569xS7JGT17&8&(]7>Im,Rh)g�U"ZPpR'L%Yru=hLvZEG?d)Vf^r;ml6,G$g29<=[7U\EqgxUU$BPsQB$rYb?myX-c[�U"f6,RhA0p*q#;R1k,bU:M>xM1tn.1*sjuE5?,26Gu$cf4ttx1J,00)Lom,Msts+S�U"[r[)N$h,uUS#4'd7O;L3Y;Dr?V+wkpcNqbFHP(EM9]0Gd.X#B8;oX12XDf?dGnq�U"<vl[UiS:lPh<+LX=ILgnuf:S3ih=%7nTr0Ti'2I$,MrfB16?crnz/a]JArbEc$:�U"A/C.aqSH(41pH;s6hbGF(AR:$Rky6wh>&N#^x4+T]22TEg^iqq*Z5U=+-^.PNUo�U"NC+7m5JJ*Tpbr4NZ&*6<ubMX7-cI]qhdRTu6K7vgI6Z\cVaTLXMTo4b</*NK:ie�U"xl>%Pr-EM%z-_&PocLRlSS-xf^gDC1<gAtBdFF[t_,Cu2df*%JjMv_226MU.SAP�U"UpwFqx%&up(%)9%%%%-%%+%NKrQ\x;N#&%%7%(%%0%%%%k#nqj.%niSiLn)\b9F�U"s\U:9TpHBj3l,7:N'i2(DE:#ru*<f%[r'LrAj'7][k4XOe_tY5:EA\s>;5%8NRY�U"Tuyc(DG0BlZtrQMeK_'8b^7bY6#>?&R+Sk:ck1bbcntJ3aa^6_Pb%(viL[rJu<S�U"6NB=9f0n8QG%D#]#xovVSS92>_K3QkAxD_ZUrAaJw$utYwpWp/v)D6:/SDSS4er�U"UFePR0.<1.YC-Gn7tOr=ewWh1,\]7$3s3?kBG)UdxvbdgF-XsskJWq/ELj&Ml[t�U")[nrr[>7SRt4gomg<2P1uN;I)HeeutA3+EErAy-2qGUIgh.7*(qKW[Z<;$*pgHc�U"LcjI.\aqgnI&k_6avL5-fer(=edRsSFdN_C4fSLpf&<+7bVy/9N&6a7Za^MdX_5�U"X6?d%\:Fz-tB#;VB>XCPkKWJxa[7E2O['uf>PFb7W2QMWR>tr&Tg(.#;nhskjOZ�U"tJH13h%Dh)]k_jY93pLR:YqGfvxui8l$%>up(%)9%%%%-%%a%NK=&=)9X['%%L%�U"+%%0%%%%z.pf&q%tlSgIfx\c3TBieX9?Xl$jN],3kornHF.Z]%49;hlD>0PC_HI�U"EL#h1/s9KsX/Ff$RGkB)n=a$0DuX2)V&]n2l.4M'puHY/hVPb5gA0Ke6N9G/Jil�U"=vT>0D(jT;t>:tNIf9ZbRAgF:>'5J/*c)T/hdsE8oC_N^FLD6bqB'eeDO7n_f,I�U"fgz6d7(0r[&-Lke+SG4%:>%OY%='>f/p13/4d==D=J(Sy^W?&vGD+rr4]E318m4�U"9\oB[U<4aRW=Xc:N3IW>_=Gv)FzgwY*fnqqm23qj8ohX[jwAah>MrH9()3;<fo.�U"D)YdqJhMLCyRNHCMblX3oZ\]0RP<U^Anv.jdCXp&vyN]$7p$9F3tq;1Jd>pieX#�U"cI;3:?#SWL(eVV^/+g^zVIkB9?1UC8oRfSxguZ:x.j7[FFGeo0?Nu?CG.GYg&,0�U"rPfBIP)D7896k(um01T6fIdiqXp0bgcK#]I$).eE6UW&2B-XR*R#)s[p8R_dV/U�U"fk(&$t)8RmX6bnWE+p&,F]3fPuAXC_8^e?)b;(wsfIQ4<],2w>J8_=aiDK(<]05�U"BFA8[/7_X695h8Q=1=h:TKDwv]GEP%ao3YLz=SKJZB^#[vijpD2w2QQbKKAiYMa�U"2\KaQ(Ntxl:O35B]2**nbV>s:H:qI<;,:XdCYe)BAM0wE)PbNW])8YG[',yZaro�U"iOZ7\0-25Ua,>xVUCy\Pp4w4ebiW_dq%dup(%)9%%%%-%%+%NKAI#zKs[-%%b%?�U"%%.#%%%&%infq%SgfxT&=t>nrkspaovD7=hg?YH/PsE'0L\s+4TIfFp9'kVC*&y�U"SX>Twd=]5Ut+o(85HiUI-T4jvmUXXtpbBk\p\K7xrgSv:3srE4FPmLud%UTtMtp�U"hK0v3vI\WH5Hd9Kr,K,B..*=VI-.6:Jx?ioj&j61]pU]Sw]Z8wnO=m)RB6L\78I�U"Dy]37GgZO%-V&itviqq^]y&6#rCmKt[uZwlXk63<:3m=7i*k_fj64a#xE=R1DsG�U"h'<L-G)oJ1>(ku7/UhWL/[<iME?0YZ.(cqYAcWYEs+'p]Es>q0.ubpXnsAV.PBG�U"g,TWTE-i.$/*ZW%T2-oc%C6M0ln8UP2=efc$]_B/<*$oGzL7FCFZ&iZ+fs-;MAB�U"cUnAU+5\)q823CllV*Cl<u;-Y[r*YL$I+u=o7'vr8v$F)-xj[-<<OYr+Ar)=hO8�U"*PS9nk9\<Ra<Z/9>C%6lI39*<I568=p3JxV504w<4uGi4U[QXMk2h,V*m:LEj&a�U"Jt]>?I$*8VpR9B+b#5'V-jok:N_s.OoJP>;tWq&+/>\N^%%]VQ?b0TnWuH)Oav)�U"Fa]8PL]3+Yuo;RA2Eg^nn4wonv<$#8YA=^r5&h-lYR2Ub^EN[6.^Qp-&tzn\4Q*�U"U;p,^ul7bK:XPoqr0(Zs&v[ln<#t;d/JhO_Dh0nA1bEIfi^]\V*lQ]iqJvO$F(H�U".s,hf*?7ENcNBs]2f#dRn+q94oJR2CmDXWVSv&>o\'VE?BdT1jGQfm$t_3bc[J3�U"BH4a\e$gE.(SM?N2g=_qmgtg8U[m46ju8Ma'T0LKhq.yk2Q$=35m$mnDWdZ6L/1�U"cs\jQb9hA;RqVV5P7Z\Bcy^D(bvLhb1ax.;PQbkl?-C7#IvV]t<(C(OPTP/K?17�U"6-?%8hCbgZR[J=sMj6rq,]HLCv[Rz>uY-ATCZ%9U6kZc;UV?*DL,[tNM]Y,IljC�U"oB$T^tVXTHv);9(k^DRrOOaU.-'(6s(-;FIR3N-4d^trBqki_s5osu#<ZbG\mgg�U"t?n+9KH&6HU*OwGdUCsw2Y&Q&9xRZzIndV>aVb#gey\OF-:h2wCQ;^oNj$Jm&6^�U"LvLnN'Hk]UG2+muTZoYPk8?Evfan]hw\/j9OWBVTPPUxu3%1n#oVJkMv<I2P0J_�U"yk%w%teM&^9u=r^t(yMhYK.2A.W4[IY.qwGDHsgc$k-EUOMLYSAz&P&_T]<p(59�U"6+P00$),2O)c^5j-+Ub,>9oeQz=7]RKD_9kxWRTTpiFe:h*#giL1y)pqnXg2lnK�U"jxNTiOJ([t=K;goB+6TP<jx&OW]x.T:tKRsN:$*Yc0U\:HnCqdS_SB.6#s6R\Ip�U"kJfP+KGeuo<u+X[%QU2pfhE&aq'9m+GA$O+?;,cJ;W_#]Wn*clN8q-P9AmTs8D_�U"q&.SSpzpPtGC7Oht?DdB;N5*^FToqXR#L6]]VU,k/CDMv[XOTfkQtF\aSm7;e8&�U"v\oNohkwWs4X]9gJ)XbVIi0E#JAl_JHuPbC2Iw(+f6>=9Olvx](m8T2-4,cap7\�U"t-BqAYRKWc,J+S=k>-xeLT.N.8W4IB);W,jOi$b2CAmTWw3M1xTFAAOHj*(nB6i�U"Zv4^gQ1[GA%[k'8dKuSl9C;nnDBLd%AUq%9i$-hqK'YHf[yPD;oC\;9\-W:*?9k�U"+hF1^A=sQ+V38G(b,Tqg3RG)ZQc-0S;)n&jFnFPQF9i1_+KBRy<(NIQAOZ8DDeC�U"P%rME2],*)jf_'l7C&<,H7[lxuYa9'V^[RRr\--h-N*M%2bh:4L*CZ=x.B](/>h�U"/lD4SeuNF2DG7B+z3tOVkF90S=u]V058,^r3M>E=Spe:il4]R%8fW\sQFr=&xy5�U"Jl-EXShA47[dGR#q#:7VfYi3N.:+8(%$cxO-b:Yl<RYprmblPWOh)'AH#smzH4_�U"tKLhW[j'_P?Z8$N[q9B[yQ^WCF3bdj80gNOaS(8*6P?AKrAeaX^<o6f&5R)J(HU�U"LQ5lMB7]uMFvMksbfvtKi\phVtbAbpMTvNd51uWwQuK\S&)N:^sPqtH_uAl<$1?�U"V.gH4efVD_h/K2K7V,viMKob0gl=d[fDl^IFrp$+i'uGX5NVXFRldSdNw?ut9su�U"=Yrr_HdWs\+avNlGXxU_Y0Afde);5K^8*B?xx^C,v[kpSADgpGnA.OI%'Hi,IO2�U"*=;b9?F%SwkBC0NYMw_nN;cUdGAkn_TA0/6OUJcYw7N;555tq_u+':;CY]]bt%5�U">ws3;$WY=]Yqm>ph\R1_UC/EhHxI4V?U.Nx.weBHVEyf[%gR:Fo9[AP0:v.M1n/�U"dMwpU1C3:lmdXWR7.;pL)APtWFXHV=AJj+eIzo5uLAEUJ^jlZ'XF=rKhEvhv2*2�U"hrOj$9HG)$BytM(9qOT;gcsLcG+-n3CrfZm*1-5C?s9(zsytg.$FuPnbOSxx(f_�U"CJk8QG<MztBkSk)WY8B*8Xb7CaOMu'.0%=S\k(Z*qk=:Lx&NFq9cE+./S+V=uCq�U"n0cK]8NSjde#rsLtA8jAiNsdf>.3Pj^.,sO^I$RviR3S[cpNv,;&b'V^pbzq+S#�U"FK/Of4'WHBjjqu5$Na%Ir_B0$AwDMT5dP]w^di]T[SDo1GPtl5<m5bLt;w;i[GK�U".$5B/:Db0lJkgWqOB_tL)7p(K99%,>q8:?J8]Twun7UB')2YCuTsZQUL*G*phA&�U"^uha-d##Nal,h??&uOw'[c_iK'06+;h1mP%N976aqA?+]$<6WI9i_:A/3Y6hXzM�U",FvhXmF\.TGOp\ouO_XV&=/SN,%]02Ho+OLdB_nFf2u9&?RU-7mGZ/>V<dCX,Zj�U"qL.3do:^'x<%up()%9%%%%-%%%KNK>y7*ki'.%%0/%%%,%%%%wf%xSnsah&zV)=�U"jq5W6^]Fhg)<w6c(dB,tcr950<fG&0e+\1o=yZG;ez/N*'W2cXnBs$9,U)40?EG�U"YD(5BlGEkrP(u89(?i.\sU1wOj^r3XoD\.9?sPuWLvk.2<myJI_-jM=(:z%yBug�U"a+sEv:pXK['fm^G2Q2ZW1XC26]=*s[u5WE_p+[l$LgbR&&$n[QLe\k%dw'CF#1n�U"Y(c6mZv0?1j[g<avSU,;\_H67CkPDKZ7EZot1vKpjaX_=HYH25f68)Y+3q8a='*�U"p)ajZxtT%S%S9v0y:PU&qPc*Bo0s\fNO9Dr7MB$#x^\\V.AH[MaWlcZG5&\EF1J�U"i\=S*j*.)v<\z)9H9GagdA.pCyR]_zLrOUqFk/UO2f.umqFr1z<3MR82wneiH&0�U"CqgEuI79Op(4p#HVUe]9Hi>4QdSMUGE\C0UrKTlZT<t>Oh/(g-'P)xkXGC+SqU4�U"Wn[okVeA(9b&;g?-vY[;Uxn=MUv\d>J]YXY1K=5.QT^J)F:gWJZ^rnquJ,-g4iZ�U"$bk?f:>6379Jha'nH^YViUR?1-5V8Init*dIX;#JlyhI]&kM&'kKN7>=Qr4lJuU�U"Z<[ww60(<Jn4cWrZLm3x]9[#sCh,?'QRBsktVfe_or/,w7U[>^YXtXGEM5[p4%>�U"z,6eREql9vg\]AYBc*%_dSwq?t&DDij&qM*d8gIcbX65-gR1s#1*'3>Vtj#T<ut�U"^_>KFhLHzmJ;Klb:[v<c%uAzDjh4K1>SdwE(Llf+BZ=gaf9bpx:b1[R^U4MRi-V�U"AjD:AacS9^fpS3j54600?x:jwG>%]v5I[=m=k8O>GUSpbi$PWmuB#+NrGF-L*c/�U"I0gwB[jcU:>0)n'XBQxCW+Lg&LBRuoEH=8H6$^mf\>uhs3/;*\^Nax8p9L4i;lk�U"kYmee8XZmL-$&XDd6P5v<gG'uLn\Q&7=06s]j*6)0ej?2tN(%QN%&up(%)9%%%%�U"-%%a%NKi,M:fe#%%%:%%%%-%%%%z.pf&S[nsh\r^Apj;FAmv%-pRO?GEHx/?1%-�U"m3.km;BVD]hee3]g<0$AHiBtF-DEn*UnHsT?134+Q:^YP)A]**-A3%u%p()9%%%�U"%-[%%%NLKyxO&[8'%+%o)%%%-%%%%zpf&&Sugjw6c8&=8f5B?dpu)W7uO*Cr07(�U")bimds*gu0*'#9&VIB_mS<T;1^*F[#vM5q_osm:-Ti'aI,b>O6qF;3(3bEOuo-d�U"RurlF0sX4O.$O=rKtu;qsGt2Asqi=)WtcWFcQF8#XGM'C?U3h$DovA$nO:OLD3n�U"QDrK4m<Du-F7Fi3];\YBvTF(^IrJq5DMx'Im4a^t&8^%?Mx43-PUojfGC%j6OHp�U"h87TR-mXZ>;rf3*/-0n8S\:\NL+jg,lcQJcK4R%pRm#AL7Qh]S'kV^t?*^aw)1<�U"\u2q&GqMlX\^\)KlBob.,9Q#1]Xg=Ob2iXB<bn$39W+&Luw$e$;Q2FgFa'dX]*q�U"HjH]-4ak_pGrj+ul_u//'l3OKi=H,aK3Bc,td:cctEA(A.a?KtZEt%ppK/0$*s^�U"[3S]3VI>QVd;9du<bxfFLW?y#CHu-b6e0V4gZe(*n'ayrtc*paC03Yud(&z40V,�U"q,ICJkYQYNL8WUSn*-HVD*1cDVh5G2(lQ8E/k9D%XlUls6v[gz-JqH=MdD<ek7:�U"*g6[h4DFkcqyC39\9^787:JLRK#>a6s86>6UfJYAcZaDuOsfG^-&l.Lu(WTxhDf�U"%vXSvG2Kok,D>nWs>c;T$2eGdE/H][ZU:$Am46v,&\\0<^8XxHxg6lTNq+ppalY�U"Un.B4-rN%%up()%9%%%%-%%%9NK%c8+4G&%%%<)%%%,%%%%zp(f&Swah&x:)]jU�U"596Hj47HsRz/e]8S'2Zpm)Za*PG_IodIGT#WO:)$<bY+zxK6]3zh,4to[502Ycp�U"_2lRa1g>r1;D/KcH8+;hh#ohY,lJdBanYjvAQi4B%w7H.EMs7gCNfLyUGNBDZUY�U"XhQqz:]W;EJkl/*Wl/b.;E/Q,WM,/Tk&J;f%JDfK1JY086>T<?GS,M\pd\3fT]$�U"o07Xt/xV[<df><:\Wok;Y=e)WmH\(f(7%<s0=Bi:j2IYf2N,;o$%s[L^SF,#84+�U"jqNIpJDsY%I,v7U*.=Pd;5Z6M=WscidU4#>q_r4;S_l[0XykvJdn%8XK1J'CTuN�U"/JaBxU1C]?DN[vs\V0gYV5vo//BQ0.md9o0:?17tueDht3RMG]q&p$?FbC>11hu�U"ab[].&xUZn8r&T=m+k].iHFfxj-KJk9mw:s<Kf=#cX<3a4FUAkqK5u/WRNuDFfl�END SUB�SUB V3�U"[XvQDV:(4h4M(*$dpLae87n]v(><w9.ESn,>6p3nUzu=Q?A[ZP,4u*w3CcILkUH�U"B'Q4_>0oujixH5pi(=w'Hbl-6%&H,4P&C?u4Omjh^\RY35P7L]uAW3>]MPjXuZ,�U"<q(u%p()9%%%%-[%%%NgKS_A+jt&%+%M)%%%-%%%%zpf&&Swjjx6c6,=Lu9l#x$�U"+7E;=8,g&mu]KuF.#85/\M)aYe\e2>P%rQw$i+b%b*Ip(Hd((><FXj+cKX^]Td8�U"M1[t)$_W-lrdD^\1*I$nDnDTdp,a$XP?Gn:RAPoR4.(Qpe*Ii<xz7tIU4emT^Ts�U"?OuwhsWt?UH+*5vBr#lI81qurAcPvyF&W7\a9\^NJXWsFJjJqDk7<N0_3WcaaCw�U"_a;k9%50v>7g>=*tcQII4pj/kJ>hHW3=;Hnl.jVH$^ii1;f8eMKlgYu]=*O6bK:�U"kTb*Lyo2'$#'Iqpn,h&,EmqlZqW<v2HX$,Y)ZWVpCGMP8/OHb#c$dSPfbgWtUDk�U"FZrf)6miOIA]5S8VjTdtT.ZaVu,]OTAFR7z7t\6FPqiF+&k*QDVPbRso4ANyziZ�U".t/KhE*jY=Lp;U,];;YyQb.Y<8Kx2UE$4?UC3Yeudt(7FMm,,mNPG9L%u#Kw*CH�U"3?MBTY&)&=atJ367C6UNMmvoYuU+%Xm::(\#_eLsuw*tGWb*ZImKXhRawof&BL*�U"wZ+6ryypmFUHnW]TicFg'g_$n0pQwB69NHJ;l>^A5cQ0x:e1[Le;\#QtMjrlCbg�U"^c>h5CwMQ<07w?]D>^wYVwRz)j?0AZX2#N=swoDHLJH^A$GbBR1zun%up()%9%%�U"%%-%%%TNKVA%P&S%%%%U%%%%-%%%%zpCf&S%%jw0pmROGE]Hxv)%zuOX'MXWoY&�U"[^AmQRBA%Twv%g.U3]'$K;PQ1$6s0_%t%%up()%9%%%%-%%%oNK:7&^;Y%%%%^%�U"%%%-%%%%zp(f&SgIfyB?YDoi&iiFB\W^A/YL.?AEI[YW#-km(WhR+Rn/+H+:GO[�U"s]<:mGVkpW]Z&/g4M%*%up%()9%%%%-%7%%NKYm)dh'</%%&(>%%%0%%%&%jwx%�U"ntsSCy'yl5'V=#T2:7.>/XZyn'YG'gk#aV,<&+&:9*W=T*B:A3O8jGrY7GE6)[_�U"xqa2B3X0Yd-W^9X=WXs$_:H(oM%jx(so?X]r?r7llQ;6nFJ>k&LTq:&bak4'Vr%�U"c,KOHe,eAu73M#VJOG%yao3%rzpJdaRKuof\p>sIxXHZ0X-iuZbYRi,1g9uNJBa�U"m9?fbZ6x]&LCCrp_vSS)7,LLnAASOC%(=Tj%zPAc?-]:t>cP4q*W9JZhaSrlY-#�U"sE+>S:[7jyrkj.d#b)b2Q:]S/zOA_2?SF;C9_5pfycuT%CIr:dMH\nJ<;%BnfGV�U"+&f$Tir^A9S*rL10vumh]tq&\JWhfFJ*&d'mUwO,fDcAO0$#%hiM&nHTDckLU;d�U"_ey42ZG=?<b%SvU\-';E?7RADJRm2\3NkEA^D[LKREi')FgWSXq)L0-6/x0$GAs�U"MH7AL52(o2e&REZRJ3bq\N%*0Rm0\CZoO*gp9CTo;K5dItNoka)6:JSR[tD-WwD�U"UJ$2hB5Kp$Hv.gr>Fvi;%Z(TA#q;>('^rJGGS]&)mn/4Kt'r\(V[u8iE?Mahas[�U"(#e2DasIpfdaLJk/xBMA#oj^8o;]K7=YLq]%R/b1xjibF/p7%7A?mps.K$JHfu5�U"7?A%:l1Nep0w%3Sq=0UNl*>hK]ibb\d)P;#9Pvf]?Ga3H[)B[ecj$VsacCS5o3P�U"4A%r*rr2fPm._IP*&\2bBU\IGT*\N(]$R$Oj0Dk6%.JgX[:\y)FquE1NrNGXHt-�U"mlU'm+V4usmXRca]9wmm4$\/zNs;,(o3nYsiI7k\,7IQ(?eP(2VFqBJ6'FAyi_O�U"Vxx]]R]ifBnp9/4PW\y1'UC9D[SPl#o8J$aS&0-B)CRSyXHF/S*-sj7sS?8%?DC�U"t./J[o\atWtQ1\MK14iTpZ'GJ$7oPmfTWmQJ[H1>HCMB>915jWJQM;/jRV^:N+8�U"72hLS,n:oLq)kJ_IEI))QbV=q]a.AYQ<RITmeW$3?MjET4n5BIq#aL4rabQU6<v�U";E6YF#sfebikp9)u*7z/)&4(]<Wwb^,n_oh*j2):-)3fHnSpT:cFruUeeI,+GJr�U"wPzBb2b&QmTot#<Dg#-Oadq9%N%E5IB/2S>#h3tU4YCIHN$P)u)ZfX]Trfl]jE.�U"5MsCV+qYZ/;Qa7Lk+N(o^#0zkg?t-:m:o$gHfRTU/2,TqG280$*KMKt8H$H+3iq�U"G^)OFz#)ej*4EflP0\hzw?1./&r1Nc6'sH/fwkY7BbYeW.4S;l0G.yaY&J6\RXD�U"W,L7GX&Vfhz'J3(sEPaoa2*etg4&O6*j>[4[_%EWPUbV*=-.,NKD1TYpKQC*c''�U"AnWw$?)%0io8]v*,kJ\4&S[jt0IQnZjAdGL+nEY_PE]3x>lSjb/C/#Sn8hqEq\d�U"q<KKHo65kB]Q<O]Cq2P2Ke\CZW<V7FpY:7/pKa)Fp9pVbaLJ\<(7bN'/mdpoUA$�U"33B7tbBAn+(l'YiG9AfT\MjTwbU%F]-D'+;::rh89Xab5&h;/y\nBLQ>Z[^3#a3�U"rL_24vs+LdMmHg_P=A>V6RhZjkcGYZfaV%k7\0.'urb,lI+$P]Tp;9M8R9r$E^O�U"8D^vV+a^aQ9Qd-c9<6_hng$4aiTdq/H]&F?g*8bbL:*OT;/X?PzU*3Cwwc?Z,&i�U"-bEhDu%YAL?C<=Xo'+Y]HJ5iPp'W668JVr5aMB)&'WLC_$AmWXp[+=InE;'>[&Q�U"xn%><ncMnPuSJlj;g#ND/rvj3NqfkJYsGs+p&xP#1(jqV1vv>o)itJ]#Qr2yTfN�U")y/uXm<Dd3kU6'D:Cyx(,hwV-nAh12DxyQRc+%O$L_K,/KeY;SiIsu[XE/=qCy[�U"=8DcgoQq>+NrORj50:l2_RG>dEtqf'qts0oVWWfHr^Uuv<CE?#)>#m8F0D%k4l?�U"W5$+[54GBh:xAe8gb*K(z'*Up9q^Ia;71K1]FMLTG/Mp)ITj16iLD[Cdc;uC569�U"6UQ$U1cwvgSR^0qM[x*CmkbvR$9<vcGh1pn,sOgPD,^'[k=Jh5yHKXe4E+DJ-4\�U"JVk:q>-<6DZIPf5U\$R]=%-W;b^[1U,z7kh^1lTkD4/+0L(SC^D,xTiB];?faL8�U"owl*(^aYsbb^4nmEufIUSINnyiRdwH\UlrFkrW;W=CtO-+2Y$zV5EqC#B2Q-5X%�U"Z^q:YJt.E2m3Yv#h2L.)v#E]2F$d\V&hf1*,l)6qlp^,R4FA+QcCAJ?6)':jM;K�U"U-5t8d=ea9#+V?'e&S6R-7Kd5Ncs8>v8_xPT0q'^\Zr1j&Hr'HfTAZ#Ag4K=?;=�U"]^TD6c(Fv^92'=+/'Fy;(<Q20.nBPlU9NV?D\)8OsDw#/,O$am78mFU;RC34heM�U"iY'/=pDr8=/+IE=:ie)rEabmAr?Z3Uh)8,IwKur0+rl15]>zq7G-?':9h^e2TI#�U"TOyIRhs<Ad5_Q4-%hUx7T.,+H^h#$sOGueqY4-rGV1Th%\WUIi7eA'13q?AWj_f�U"PI5#oR0-Z1v1WYmnNX?;Ey&k^1*Q'J(3V2=%dRjas=6&xH-E(iGfQD],l/$>0(Z�U"h%PC&qr^<GHX<^Y;$\F$%#pggt.+4-lkL.]Z8k(I1k88lquB6CH_gLjoY'Yd;jr�U"?:6b7Bq%vm7q0bN;ii*zR4[gD(O$4jdR+Q$[bBfwcF#1itlJ<mpekOLIF2j:Yk:�U"GDwd7Bn,h5BK5&x?2+gN.PCM^.\YPd?AH:2(>8et/<_9.QqW*<#q29aT';8TJiw�U"WmkxoV=j5\4^OX_AZXTpTjn$ktYms8S)SK<NDnNl<^_9yFGEd:ISQF\e$Ly])M:�U"1<^E76o<+_WCjO*ce]atV<eJRD6WoS#Vo0uY;\x)c$I^8f#f+<YD]<O55&$$j<P�U"5?g0:l3OPnxW7W%I]#<n]8]aB%ic,A4GAh_dRX2bS/A(7]]mkjw5C\5IQmNjq1)�U"3H^OjCl)$x^mq47LU\(:(5r5CvOeky458GT\U-Zpke385fVH3C4Wt->:RbsBIum�U"p'.%==RO9M#Dg?>dbCZu)/)flbQvC&mLpYOi9Bso==PD_1Fhez&[[&t5^684.kI�U"&^8,$3/L8j%EBAA0U2O3q9:Os/WLTj>jK-$=m\TRl/'4+Xbt,ziP9zRKjRZ>_8c�U"z6G8WN-F#D'Qo)Rl2pg.ja6:oo2n&e7XV-u>h[4AV$tRooiF%6p28o7sK55;lDX�U"b7J?;'U41^C[nL0c[[&>Pi/hlcT(boS#-a)Ab,nR,,J].*DDQ;nD]KL3&K#T#>j�U"CMn%cn6D/UImFY(q0GH3&1ThU>(e7DSh+DJQ'[TXVVOnp8c:5.fdNo1%/R&FXP-�U"VmVF-9y'uQtGDR/r\Vce=K.(++hBbF</KcI%\P3S*\QjoMQ$gTx8bq4c.fFCE.5�U"ru&<dRj?Sd]iQRGFlJHWE9SEDgw:413LBvX#AV)M&9OW\GZpn*Tqqr]&bcQ[F]j�U"FaO6YudP;s,:e#)[Dgjk0O^)L>7dmU(7,bY$nFfE(?YHC_M'uDup%()9%%%%-%7�U"%%NKQ&e,[%+&%%'\(%%%/%%%&'urf%nqSwRjl._2,:RU:9Uh*]xh.eu'dUQndEE�U">8C2,z<ML*xDY'\TBa>KTcvuJD4k(Ex[B)3ZtLH#t53e]j651EBiPH,VN,f,koI�U"UW&=h3[#:+H+Q5m;[&::<VP=.d+:.e,cWQ>/&*cP2.AKjt+VLi#keAyF&X;KO$Y�U"<Zj;y^sbr7BIO^D(#s(Oo%uAfTq6I8^jpriY_>7#7;]tZegM;X_ytMXdJ.isuLp�U"'_2m6n;>DHJA\_.wv\k)vve%CS[s:oo5mdeGH7TLUOhj)WbQ9SHO:DDxTphp;'=�U"Pt6J1)S9k+^DC^n4+K[d[QOERSqX0=5wR-7yHBqj&[sU<XX8%%up()%9%%%%-%%�U"%fNKi?+bOc&%%%a-%%%/%.%%'u.sj&x%Swjl*>ctt\Re5>KhIKVe58>.,qjig.G�U"S*pdiEOxB[Y2pnz504LrF\MJK<Xe5I-:nI]e5GsXlDD-DA:.u;[U/P;d8E%rC<v�U"PQv7#6\\(=O8Ab85#h6)CU:M&:71sSL&>ScVx71iQTOTVu/XA/#u5j8Vx9]p09*�U"GmAbUSo/L.#70$8,k\NB,b%kMv.=K$tpj%PdgGOTQAZT7JF6*6RQd#Z4^/Zi-rU�U"d+$;Te]VrPZs^<E,V1+-m.3)Qm2K2aO%)hb%dXe#FADnC?jN:ECgNo/l?WZ-^xE�U".;d'&o?7eQ%*;issH+45bs;H]K.T%\sE1zMr*(1Z_^WQng8)J$hAJj30:;8ORIb�U"^2EHr&^_e.]&d>-+=jp_;+a/D3mQffqBB3kr5S)(EJ4$ccb2ng%*x*^nup%&'9%�U"%9%%%%-%%%fNKy;-DJ437%%8S%%%/%%%%%%%%%&%%E%%%%%%%%%jRrf%nqSg%fx�U"up%&'9%%9%%%%-%%%oNKS'=YtL>R%%\)%%%/%%%%%%%%%&%%E%%%%\3%%%jRsj&�U"&xSg%fxup%&'9%%9%%%%-%%%'NKK_.(#'77%%6a%%%.%%%%%%%%%&%%E%%%%WM%�U"%%jRut%uSgf%xup&%'9%9%%%%-[%%%NmKr\x);N&%(%7(%%%0%%%%%%%%%&%E[%�U"%%*%_%%k#nqj.%niSi(n)up%&'9%%9%%%%-%%%TNK==%)9X'7%%L+%%%0%%%%%%�U"%%%&%%E%%%&(a%%#zpf&%qtlS%gfxu%p&'9%%9%%%%-%%+%NKAI#zKs[-%%b%?%�U"%.%%%%%%%%%&%%E%%+%.c%(%&in%fqSg%fxup%&'9%%9%%%%-%%%KNK>y7*ki'.�U"%%0/%%%,%%%%%%%%%&%%E%%%&Ol%%%wfxS%nshu%p&'9%%9%%%%-%%a%NKi,M:f�U"e#%%%:%%%%-%%%%%%%%%&%%E%%(%do%%%zpf&&Sns%hup&%'9%9%%%%-[%%%NLK�U"yxO&[8'%+%o)%%%-%%%%%%%%%%%E[%%%t%o%%z.pf&S%ugwu%p&'9%%9%%%%-%%�U"a%NK%^c+4G%&%%<%)%%,%%%%%%%%%&%%E%%%%Yr%%%zpf&&Swh%up&'%9%9%%%%�U"-%7%%NK;S_Aj't&%%'M)%%%-%%%%%%%%%%%E%%%%Lt%%%zp(f&Sw%jxup%&'9%%�U"9%%%%-%%%TNKVA%P&S%%%%U%%%%-%%%%%%%%%&%%E%%%%mv%%#zpf&(S%jw%up&�U"'%9%9%%%%-%7%%NK6:7^;%Y%%%%^%%%%-%%%%%%%%%&%E%.%%kv%%%zp(f&Sg%f�U"yup%&'9%%9%%%%-%%%fNKm)<dh</.%%(>%%%0%%%%%%%%%&%%E%%%'ov%%&%jwx�U"%ntsS(y'yu%p&'9%%9%%%%-%%a%NK&3e,[+[&%%\%(%%/%%%%%%%%%&%%E%%4%[�U"+%(%'ur%fnqS%wjlu%p&'9%%9%%%%-%%F%NKi9?bOc%&%%a%-%%/%%%%%%%%%&%�U"%E%%.%5-%(%'us(j&xS%wjlu%p*+%%%%%5#%5%##(%%E&.%%%%%�END SUB�V2�V3�CLOSE:IF S=124AND B&=Z&THEN?" :) Ok!"ELSE?" :( Bad!�SUB U(A$):FOR A=1TO LEN(A$):C=ASC(MID$(A$,A))-37:IF C<0THEN C=91+C*32�IF K<4THEN K=C+243ELSE?#1,CHR$(C+(K MOD 3)*86);:K=K\3:B&=B&+1�S=(S+C)AND 255:NEXT:LOCATE,1:?STRING$(B&*50\Z&,219);:END SUB�Dave Navarro, Jr.              SIMPLE GRAPHICS DRAWING EXAMPLEdave@powerbasic.com            06-28-99 (18:45)       PBCC, PBDLL            283  8011     COOL32.BAS  '-------------------------------------------------------------------------------�'�'   COOL.BAS for 32-bit PB/CC 2.0�'   Copyright (c) 1999 by PowerBASIC, Inc.�'�'   A simple graphics drawing program�'   Ported from PB/DOS to PB/CC 6.0 by Lance Edmonds 1999�'   Original PB/DOS code by Dave Navarro.�'�'   Uses a 30mSec Timer to do the drawing updates, and uses less than 1% of the�'   processor time (as measured on an AMD K6-266/64Mb/1Mb S3 Trio video card)�'�'------------------------------------------------------------------------------��#DIM ALL�#COMPILE EXE�#OPTION VERSION4�#INCLUDE "WIN32API.INC"�DEFLNG a-z��$IF %DEF(%pb_dll32)�$ClassName = "PB/DLL Simple Graphics Demo"�$ELSE�$ClassName = "PB/CC Simple Graphics Demo"�$ENDIF��'------------------------------------------------------------------------------��FUNCTION WinMain (BYVAL hInstance     AS LONG, _�                  BYVAL hPrevInstance AS LONG, _�                  lpCmdLine           AS ASCIIZ PTR, _�                  BYVAL iCmdShow      AS LONG) AS LONG��  LOCAL Msg         AS tagMsg�  LOCAL wndclass    AS WndClassEx�  LOCAL szClassName AS ASCIIZ * 80�  LOCAL hWnd        AS LONG�  LOCAL hTimer      AS LONG��  szClassName = $ClassName��  wndclass.cbSize        = SIZEOF(WndClass)�  wndclass.style         = %CS_HREDRAW OR %CS_VREDRAW�  wndclass.lpfnWndProc   = CODEPTR( WndProc )�  wndclass.cbClsExtra    = 0�  wndclass.cbWndExtra    = 0�  wndclass.hInstance     = hInstance�  wndclass.hIcon         = LoadIcon( hInstance, "PROGRAM" )�  wndclass.hCursor       = LoadCursor( %NULL, BYVAL %IDC_ARROW )�  wndclass.hbrBackground = GetStockObject( %BLACK_BRUSH )�  wndclass.lpszMenuName  = %NULL�  wndclass.lpszClassName = VARPTR(szClassName)�  wndclass.hIconSm       = LoadIcon( hInstance, BYVAL %IDI_APPLICATION )��  RegisterClassEx wndclass��  ' Create a window using the registered class�  hWnd = CreateWindowEx(0, _                          ' extended Window style�                        $ClassName, _                 ' window class name�                        $ClassName, _                 ' window caption�                        %WS_OVERLAPPEDWINDOW, _       ' window style�                        %CW_USEDEFAULT, _             ' initial x position�                        %CW_USEDEFAULT, _             ' initial y position�                        %CW_USEDEFAULT, _             ' initial x size�                        %CW_USEDEFAULT, _             ' initial y size�                        %HWND_DESKTOP, _              ' parent window handle�                        BYVAL 0, _                    ' window menu handle�                        hInstance, _                  ' program instance handle�                        BYVAL %NULL)                  ' creation parameters��  ShowWindow hWnd, iCmdShow�  UpdateWindow hWnd��  ' Create a timer event every 30 mSec�  hTimer = SetTimer(hWnd, 0, 30, BYVAL %NULL)��  WHILE GetMessage(Msg, %NULL, 0, 0)�    TranslateMessage Msg�    DispatchMessage Msg�  WEND��  ' Destroy the timer�  KillTimer hWnd, 0��  FUNCTION = msg.wParam��END FUNCTION  ' WinMain��'------------------------------------------------------------------------------��FUNCTION WndProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _�                  BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG��  LOCAL Rct      AS RECT�  LOCAL PS       AS PAINTSTRUCT�  LOCAL hDC      AS LONG�  LOCAL Pt       AS POINTAPI��  DIM x1(40) AS STATIC LONG�  DIM x2(40) AS STATIC LONG�  DIM y1(40) AS STATIC LONG�  DIM y2(40) AS STATIC LONG�  DIM a1(40) AS STATIC LONG�  DIM a2(40) AS STATIC LONG�  DIM b1(40) AS STATIC LONG�  DIM b2(40) AS STATIC LONG��  STATIC hOldPen AS LONG�  STATIC x1      AS LONG�  STATIC x2      AS LONG�  STATIC y1      AS LONG�  STATIC y2      AS LONG�  STATIC a1      AS LONG�  STATIC a2      AS LONG�  STATIC b1      AS LONG�  STATIC b2      AS LONG�  STATIC c1      AS LONG�  STATIC c2      AS LONG�  STATIC xd1     AS LONG�  STATIC xd2     AS LONG�  STATIC yd1     AS LONG�  STATIC yd2     AS LONG�  STATIC ad1     AS LONG�  STATIC ad2     AS LONG�  STATIC bd1     AS LONG�  STATIC bd2     AS LONG�  STATIC iOk     AS LONG�  STATIC Change1 AS LONG�  STATIC Change2 AS LONG��  SELECT CASE wMsg��    CASE %WM_CREATE�      RANDOMIZE TIMER��      GetClientRect hWnd, Rct�      x1 = RND(10, Rct.nRight - 10)  : x2 = RND(10, Rct.nRight - 10)�      y1 = RND(10, Rct.nBottom - 10) : y2 = RND(10, Rct.nBottom - 10)�      a1 = RND(10, Rct.nRight - 10)  : a2 = RND(10, Rct.nRight - 10)�      b1 = RND(10, Rct.nBottom - 10) : b2 = RND(10, Rct.nBottom - 10)��      c1  = RGB(255,255,0) ' Yellow�      c2  = RGB(0,112,255) ' Blue��      xd1 = 9   : xd2 = 7�      yd1 = 6   : yd2 = 10�      ad1 = -11 : ad2 = 7�      bd1 = 4   : bd2 = -13��      Change1 = 0�      Change2 = 0��      iOk = -1�      EXIT FUNCTION��    CASE %WM_SIZE�      iOk = 0�      InvalidateRect hWnd, BYVAL %NULL, %TRUE�      SendMessage hWnd, %WM_CREATE, 0, 0�      EXIT FUNCTION��    CASE %WM_COMMAND��    CASE %WM_SYSCOMMAND�      IF wParam = %SC_CLOSE THEN�        DestroyWindow hWnd�        EXIT FUNCTION�      END IF��    CASE %WM_PAINT�      IF ISFALSE iOk THEN�        EXIT SELECT�      END IF��      hDC = BeginPaint(hWnd, PS)��      ARRAY DELETE x1(1) : ARRAY DELETE x2(1)�      ARRAY DELETE y1(1) : ARRAY DELETE y2(1)�      ARRAY DELETE a1(1) : ARRAY DELETE a2(1)�      ARRAY DELETE b1(1) : ARRAY DELETE b2(1)��      hOldPen = SelectObject(hDC, CreatePen(%PS_SOLID, 1, c1))�      MoveToEx hDC, x1, y1, BYVAL %NULL�      LineTo hDC, x2, y2��      DeleteObject SelectObject(hDC, GetStockObject(%Black_Pen))�      MoveToEx hDC, x1(1), y1(1), byval %NULL�      LineTo hDC, x2(1), y2(1)��      DeleteObject SelectObject(hDC, CreatePen(%PS_SOLID, 1, c2))�      MoveToEx hDC, a1, b1, byval %NULL�      LineTo hDC, a2, b2 ', c2��      DeleteObject SelectObject(hDC, GetStockObject(%Black_Pen))�      MoveToEx hDC, a1(1), b1(1), byval %NULL�      LineTo hDC, a2(1), b2(1)��      DeleteObject SelectObject(hDC, hOldPen)��      EndPaint hWnd, PS�      EXIT FUNCTION��    CASE %WM_Timer�      IF ISFALSE iOk THEN�        EXIT SELECT�      END IF��      GetClientRect hWnd, Rct�      InvalidateRect hWnd, BYVAL %NULL, %FALSE�      UpdateWindow hWnd��      x1(40) = x1 : x2(40) = x2�      y1(40) = y1 : y2(40) = y2�      a1(40) = a1 : a2(40) = a2�      b1(40) = b1 : b2(40) = b2��      x1 = x1 + xd1 : x2 = x2 + xd2�      y1 = y1 + yd1 : y2 = y2 + yd2��      a1 = a1 + ad1 : a2 = a2 + ad2�      b1 = b1 + bd1 : b2 = b2 + bd2��      IF (x1 < 1) OR (x1 => Rct.nRight -1) THEN�        xd1 = -xd1�        INCR Change1�      END IF��      IF (x2 < 1) OR (x2 => Rct.nRight -1) THEN�        xd2 = -xd2�        INCR Change1�      END IF��      IF (a1 < 1) OR (a1 => Rct.nRight -1) THEN�        ad1 = -ad1�        INCR Change2�      END IF��      IF (a2 < 1) OR (a2 => Rct.nRight -1) THEN�        ad2 = -ad2�        INCR Change2�      END IF��      IF (y1 < 1) OR (y1 => Rct.nBottom -1) THEN�        yd1 = -yd1�        INCR Change1�      END IF��      IF (y2 < 1) OR (y2 => Rct.nBottom -1) THEN�        yd2 = -yd2�        INCR Change1�      END IF��      IF (b1 < 1) OR (b1 => Rct.nBottom -1) THEN�        bd1 = -bd1�        INCR Change2�      END IF��      IF (b2 < 1) OR (b2 => Rct.nBottom - 1) THEN�        bd2 = -bd2�        INCR Change2�      END IF��      IF Change1 => 4 THEN�        c1  = RGB(RND(1,4) * 64, RND(1,4) * 64, RND(1,4) * 64)�        Change1 = 0�      END IF��      IF Change2 => 4 THEN�        c2  = RGB(RND(1,4) * 64, RND(1,4) * 64, RND(1,4) * 64)�        Change2 = 0�      END IF��      EXIT FUNCTION��    CASE %WM_DESTROY�      PostQuitMessage 0�      EXIT FUNCTION��  END SELECT��  FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam)��END FUNCTION�Dave Navarro, Jr.              GRAPHICS DRAWING PROGRAM FOR PBdave@powerbasic.com            07-06-99 (17:29)       PBCC                   259  7912     COOL.BAS    '-------------------------------------------------------------------------------�'�'   COOL.BAS for 32-bit PB/CC 2.0�'   Copyright (c) 1999 by PowerBASIC, Inc.�'�'   A simple graphics drawing program�'   Ported from PB/DOS to PB/CC 6.0 by Lance Edmonds 1999�'   Original PB/DOS code by Dave Navarro.�'�'   Uses a 30mSec Timer to do the drawing updates, and uses less than 1% of the�'   processor time (as measured on an AMD K6-266/64Mb/1Mb S3 Trio video card)�'�'------------------------------------------------------------------------------��#DIM ALL�#COMPILE EXE�#OPTION VERSION4�#INCLUDE "WIN32API.INC"�DEFLNG a-z��$IF %DEF(%pb_dll32)�$ClassName = "PB/DLL Simple Graphics Demo"�$ELSE�$ClassName = "PB/CC Simple Graphics Demo"�$ENDIF��'------------------------------------------------------------------------------��FUNCTION WinMain (BYVAL hInstance     AS LONG, _�                  BYVAL hPrevInstance AS LONG, _�                  lpCmdLine           AS ASCIIZ PTR, _�                  BYVAL iCmdShow      AS LONG) AS LONG��  LOCAL Msg         AS tagMsg�  LOCAL wndclass    AS WndClassEx�  LOCAL szClassName AS ASCIIZ * 80�  LOCAL hWnd        AS LONG�  LOCAL hTimer      AS LONG��  szClassName = $ClassName��  wndclass.cbSize        = SIZEOF(WndClass)�  wndclass.style         = %CS_HREDRAW OR %CS_VREDRAW�  wndclass.lpfnWndProc   = CODEPTR( WndProc )�  wndclass.cbClsExtra    = 0�  wndclass.cbWndExtra    = 0�  wndclass.hInstance     = hInstance�  wndclass.hIcon         = LoadIcon( hInstance, "PROGRAM" )�  wndclass.hCursor       = LoadCursor( %NULL, BYVAL %IDC_ARROW )�  wndclass.hbrBackground = GetStockObject( %BLACK_BRUSH )�  wndclass.lpszMenuName  = %NULL�  wndclass.lpszClassName = VARPTR(szClassName)�  wndclass.hIconSm       = LoadIcon( hInstance, BYVAL %IDI_APPLICATION )��  RegisterClassEx wndclass��  ' Create a window using the registered class�  hWnd = CreateWindowEx(0, _                        ' extended Window style�                      $ClassName, _                 ' window class name�                      $ClassName, _                 ' window caption�                      %WS_OVERLAPPEDWINDOW, _       ' window style�                      %CW_USEDEFAULT, _             ' initial x position�                      %CW_USEDEFAULT, _             ' initial y position�                      %CW_USEDEFAULT, _             ' initial x size�                      %CW_USEDEFAULT, _             ' initial y size�                      %HWND_DESKTOP, _              ' parent window handle�                      BYVAL 0, _                    ' window menu handle�                      hInstance, _                  ' program instance handle�                      BYVAL %NULL)                  ' creation parameters��  ShowWindow hWnd, iCmdShow�  UpdateWindow hWnd��  ' Create a timer event every 30 mSec�  hTimer = SetTimer(hWnd, 0, 30, BYVAL %NULL)��  WHILE GetMessage(Msg, %NULL, 0, 0)�    TranslateMessage Msg�    DispatchMessage Msg�  WEND��  ' Destroy the timer�  KillTimer hWnd, 0��  FUNCTION = msg.wParam��END FUNCTION  ' WinMain��'------------------------------------------------------------------------------��FUNCTION WndProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _�                  BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG��  DIM Rct AS RECT�  DIM PS AS PAINTSTRUCT�  DIM hDC AS LONG�  DIM Pt AS POINTAPI��  STATIC hOldPen AS LONG��  DIM x1(40) AS STATIC LONG, x2(40) AS STATIC LONG, y1(40) AS STATIC LONG, y2(40) AS STATIC LONG�  DIM a1(40) AS STATIC LONG, a2(40) AS STATIC LONG, b1(40) AS STATIC LONG, b2(40) AS STATIC LONG�  STATIC x1 AS LONG, x2 AS LONG, y1 AS LONG, y2 AS LONG�  STATIC a1 AS LONG, a2 AS LONG, b1 AS LONG, b2 AS LONG�  STATIC c1 AS LONG, c2 AS LONG�  STATIC xd1 AS LONG, xd2 AS LONG�  STATIC yd1 AS LONG, yd2 AS LONG�  STATIC ad1 AS LONG, ad2 AS LONG�  STATIC bd1 AS LONG, bd2 AS LONG�  STATIC iOk AS LONG, Change1 AS LONG, Change2 AS LONG��  SELECT CASE wMsg�    CASE %WM_CREATE�        RANDOMIZE TIMER��        GetClientRect hWnd, Rct�        x1 = RND(10, Rct.nRight - 10)  : x2 = RND(10, Rct.nRight - 10)�        y1 = RND(10, Rct.nBottom - 10) : y2 = RND(10, Rct.nBottom - 10)�        a1 = RND(10, Rct.nRight - 10)  : a2 = RND(10, Rct.nRight - 10)�        b1 = RND(10, Rct.nBottom - 10) : b2 = RND(10, Rct.nBottom - 10)��        c1  = RGB(255,255,0) ' Yellow�        c2  = RGB(0,112,255) ' Blue��        xd1 = 9   : xd2 = 7�        yd1 = 6   : yd2 = 10�        ad1 = -11 : ad2 = 7�        bd1 = 4   : bd2 = -13��        Change1 = 0�        Change2 = 0��        iOk = -1�        EXIT FUNCTION��    CASE %WM_SIZE�        iOk = 0�        InvalidateRect hWnd, BYVAL %NULL, %TRUE�        SendMessage hWnd, %WM_CREATE, 0, 0�        EXIT FUNCTION��    CASE %WM_COMMAND��    CASE %WM_SYSCOMMAND�        IF wParam = %SC_CLOSE THEN�           DestroyWindow hWnd�           EXIT FUNCTION�        END IF��    CASE %WM_PAINT�        IF ISFALSE iOk THEN EXIT SELECT��        hDC = BeginPaint(hWnd, PS)��        ARRAY DELETE x1(1) : ARRAY DELETE x2(1)�        ARRAY DELETE y1(1) : ARRAY DELETE y2(1)�        ARRAY DELETE a1(1) : ARRAY DELETE a2(1)�        ARRAY DELETE b1(1) : ARRAY DELETE b2(1)��        hOldPen = SelectObject(hDC, CreatePen(%PS_SOLID, 1, c1))�        MoveToEx hDC, x1, y1, BYVAL %NULL�        LineTo hDC, x2, y2��        DeleteObject SelectObject(hDC, GetStockObject(%Black_Pen))�        MoveToEx hDC, x1(1), y1(1), byval %NULL�        LineTo hDC, x2(1), y2(1)��        DeleteObject SelectObject(hDC, CreatePen(%PS_SOLID, 1, c2))�        MoveToEx hDC, a1, b1, byval %NULL�        LineTo hDC, a2, b2 ', c2��        DeleteObject SelectObject(hDC, GetStockObject(%Black_Pen))�        MoveToEx hDC, a1(1), b1(1), byval %NULL�        LineTo hDC, a2(1), b2(1)��        DeleteObject SelectObject(hDC, hOldPen)��        EndPaint hWnd, PS�        EXIT FUNCTION��    CASE %WM_Timer�        IF ISFALSE iOk THEN EXIT SELECT��        GetClientRect hWnd, Rct�        InvalidateRect hWnd, BYVAL %NULL, %FALSE�        UpdateWindow hWnd��        x1(40) = x1 : x2(40) = x2�        y1(40) = y1 : y2(40) = y2�        a1(40) = a1 : a2(40) = a2�        b1(40) = b1 : b2(40) = b2��        x1 = x1 + xd1 : x2 = x2 + xd2�        y1 = y1 + yd1 : y2 = y2 + yd2��        a1 = a1 + ad1 : a2 = a2 + ad2�        b1 = b1 + bd1 : b2 = b2 + bd2��        IF (x1 < 1) OR (x1 => Rct.nRight -1) THEN�            xd1 = -xd1�            INCR Change1�        END IF��        IF (x2 < 1) OR (x2 => Rct.nRight -1) THEN�            xd2 = -xd2�            INCR Change1�        END IF��        IF (a1 < 1) OR (a1 => Rct.nRight -1) THEN�            ad1 = -ad1�            INCR Change2�        END IF��        IF (a2 < 1) OR (a2 => Rct.nRight -1) THEN�            ad2 = -ad2�            INCR Change2�        END IF��        IF (y1 < 1) OR (y1 => Rct.nBottom -1) THEN�            yd1 = -yd1�            INCR Change1�        END IF��        IF (y2 < 1) OR (y2 => Rct.nBottom -1) THEN�            yd2 = -yd2�            INCR Change1�        END IF��        IF (b1 < 1) OR (b1 => Rct.nBottom -1) THEN�            bd1 = -bd1�            INCR Change2�        END IF��        IF (b2 < 1) OR (b2 => Rct.nBottom - 1) THEN�            bd2 = -bd2�            INCR Change2�        END IF��        IF Change1 => 4 THEN�            c1  = RGB(RND(1,4) * 64, RND(1,4) * 64, RND(1,4) * 64)�            Change1 = 0�        END IF��        IF Change2 => 4 THEN�            c2  = RGB(RND(1,4) * 64, RND(1,4) * 64, RND(1,4) * 64)�            Change2 = 0�        END IF��        EXIT FUNCTION��    CASE %WM_DESTROY�        PostQuitMessage 0�        EXIT FUNCTION��  END SELECT��  FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam)��END FUNCTION�Don Schullian                  RETURN KEY VALUE               d83@DASoftVSS.com              09-02-99 (11:32)       PBCC, PBDLL            390  18881    KEYVALUE.BASHi,��  This text is aimed, primarily, at new, upcoming programmers and those of you�that have been around for awhile will find it a rehash of what you already�know and will, most likely, wish to skip it. (or not)��  Windows seems to have lost the abilities to report all the variations of key�strokes that were available in DOS. In most cases this doesn't pose much of a�problem as there were over 200 distinct codes NOT including the alphabet and�standard characters. I'm talking about <CTRL>F-01, <ALT>Gray5, ect.��  The code and integer equates found in this file comes as close as I could�get to reporting all the variations and there are still over 200 to choose�from but they DO NOT, in most cases, equal what was returned by DOS. This,�fortunately, is not a problem as the numeric equates, if used religiously,�will carry the correct value returned by the fKeyValue function and are�named EXACTLY the same as in my DOS code.��  So, where to start....��  The very bottom of the pile are the numeric equates I was speaking of in the�previous paragraph. Using them may seem to be a bit of a pain in the posterior�but they are common enough throughout the WIN32API.INC file and %ENTER_key�makes a whole lot easier reading than &h0D or 13 (and that's an easy one).�When you're programming, say, a browser menu for an index you'll want to�offer your user a rich set of keys with which to control the list; of which�HOME, UP, PgUp, END, DOWN, PgDn, ENTER, and ESC are the most common. A simple�SELECT CASE will handle all these quite easily but, what values do you test?�Have a look at these two sets of code and see which one YOU would want to�see in some six year old code:��SELECT CASE fKeyValue(K)         SELECT CASE fKeyValue(K)�  CASE %HOME_key                   CASE &hF204�  CASE %UP_key                     CASE &h000D�  CASE %PGUP_key                   CASE &h001B�  CASE %END_key                    CASE &h5100�  CASE %DOWN_key                   CASE &h5000�  CASE %PGDN_key                   CASE &h4F00�  CASE %ENTER_key                  CASE &h4900�  CASE %ESC_key                    CASE &h4800�  CASE %CTRL_ENTER                 CASE &h4700�END SELECT                       END SELECT��Get the picture? Plus, as a bonus to those of you who are coming into PB/cc�from DOS, you can use the same code for both PB/DOS and PB/cc by loading a�different set of numeric equates. This 'trick' of course, applies to just�about any situation where a change is required throughout your program(s)�to make them act slightly differently for different users or O/Ss.��  Ok... that takes care of the equates now lets move onto fGetKey. If you've�not read through my notes on that subject I'd strongly suggest you do so as�it is, maybe, the most important piece of code I've ever written. It has�been in EVERY program I've written in the last decade and has saved MEGs of�code and uncountable hours of backtracking.��FUNCTON fGetKey () AS INTEGER��  FUNCTION = CVI(WAITKEY$)��END FUNCTION��  What you see above is the simplest form of fGetKey. You'll find a bit�more complicated form below. They both preform the same primary function of�awaiting an incoming key press and converting it into an INTEGER value. EVERY�incoming key press in my programs comes through this function and that allows�me to 'trap' certain keys, change their value before passing them on, block�them altogether, branch the program off to, say, help, or even end the�program all from the same spot! In the DOS days this function also handled�the screen saver function. It removed the requirement for ON KEY which added�2 bytes to each and every command which keep the overall size down and kept�the speed up. If I've enticed you then PLEASE read my fGetKey files and adapt�the concept to your programs, it works!��  Finally, we get to the fKeyValue function. As you can see it really is just�a few lines of code and pretty fast. I tinkered with other ideas on how to�create unique codes for all the various key combinations but this version gave�me the uniqueness required and maintained the speed so as not to slow down the�whole program.��  All the incoming key strokes report either 1 byte or 2 bytes. Those, like�the function keys, that return two bytes have a low byte value of ZERO so�when converting ANY key stroke into an integer, one of the two bytes will�be ZERO and working on that fortunate fact I've changed the value of which�ever byte is ZERO. The High nibble of that byte is always &hF (15) and the�low nibble is either 1, 2, or 4 depending on the status of either the <ALT>,�<CTRL> or <SHIFT> key. If none of these keys were employed then the byte�retains it's value of ZERO.��  Notice that fKeyValue reports only ONE of the three modifier keys. That is�to say that if both <CTRL> and <ALT> are depressed then only one of the two�keys will be reported. This was done for speed and simplicity and does NOT�have to be the case. The system employed to set the unique values can be ORed�to report any one, two, or three of the modifier keys if it is required by�your program.��  Well, gang, that about wraps it up and just in time as the wife has decided�that I'm not doing anything important and should take her shopping! Thanks,�once again, for hanging in there and I sincerely hope I've helped you along.�If you've any questions or have spotted (what you erroneously think is) a bug�let me know.��Have a good one,��d83�-----------                                                    -----------�    -------------------------< cut here >---------------------------�-----------                                                    -----------�#IF 0�    ----------------------------                      PowerBASIC/cc v2.0� ---|          DASoft          |------------------------------------------�    ----------------------------    Copyright 1999      DATE: 1999-08-30�    | FILE NAME   KeyValue.bas |          by�    | DIRECTORY   NB1cc        |  Don Schullian, Jr.�    ----------------------------�   A license is hereby granted to the holder to use this source code in�   any program, commercial or otherwise,  without receiving the express�   permission of the copyright holder and without paying any royalties,�   as long as this code is not distributed in any compilable format.�    IE: source code files, and/or printed listings.� -------------------------------------------------------------------------�  PURPOSE: Return unique key-press values based on <SHIFT>, <CTRL>, or�           <ALT> status.�   PARMAS: KeyIn An INTEGER representation of the latest key input�           NOTE: fGetKey (shown in the test code) creates these INTEGER�                 values.�  RETURNS: adjusted INTEGER value of KeyIn�      USE: As the values returned by fKeyValue% are contrived and NOT of�           any known standard you would be well advised to use the INTEGER�           constants (included in this file) that represent the values. This�           will also make correcting any errors that may exist easier.�     NOTE: There is one double among the 200+ values below: <CTRL>J and�           <CTRL>ENTER. As this condition has existed since the beginning of�           time I have elected not to make a unique distinction.�     NOTE: If you require combination key values, such as <CTRL><ALT><ENTER>,�           The code in fKeyValue can be modified to OR the values of each�           "shift" key instead of selecting only one. Insert the following�           lines of code in place of the SELECT CASE and create the new�           integer constants. eg: %CTRL_ALT_F01 = &h3BF3��             DIM V AS LOCAL INTEGER��             V = (INSHIFT AND &b011111)�             IF V =  0                        THEN GOTO ExitFunction�             IF V = 16 AND K > 31 AND K < 256 THEN GOTO ExitFunction�             IF (V AND &b000011) THEN I = &h00F1           ' ALT�             IF (V AND &b001100) THEN I = (I OR &h00F2)    ' CTRL�             IF (V AND &b010000) THEN I = (I OR &h00F4)    ' SHIFT�--------------------------------------------------------------------------------�#ENDIF��#IF 0�  Windows' default keys�  %ALT_ENTER = &hF10D�  %ALT_ESC   = &hF11B�  %ALT_TAB   = &hF109�  %CTRL_ESC  = &hF21B�#ENDIF��'START HERE =============== Used by LoadData�%HOME_key  = &h4700 : %ALT_HOME  = &h47F1 : %CTRL_HOME      = &h47F2 : %SHIFT_HOME  = &h47F4�%UP_key    = &h4800 : %ALT_UP    = &h48F1 : %CTRL_UP        = &h48F2 : %SHIFT_UP    = &h48F4�%PGUP_key  = &h4900 : %ALT_PGUP  = &h49F1 : %CTRL_PGUP      = &h49F2 : %SHIFT_PGUP  = &h49F4�%LEFT_key  = &h4B00 : %ALT_LEFT  = &h4BF1 : %CTRL_LEFT      = &h4BF2 : %SHIFT_LEFT  = &h4BF4�%RIGHT_key = &h4D00 : %ALT_RIGHT = &h4DF1 : %CTRL_RIGHT     = &h4DF2 : %SHIFT_RIGHT = &h4DF4�%END_key   = &h4F00 : %ALT_END   = &h4FF1 : %CTRL_END       = &h4FF2 : %SHIFT_END   = &h4FF4�%DOWN_key  = &h5000 : %ALT_DOWN  = &h50F1 : %CTRL_DOWN      = &h50F2 : %SHIFT_DOWN  = &h50F4�%PGDN_key  = &h5100 : %ALT_PGDN  = &h51F1 : %CTRL_PGDN      = &h51F2 : %SHIFT_PGDN  = &h51F4�%INS_key   = &h5200 : %ALT_INS   = &h52F1 : %CTRL_INS       = &h52F2 : %SHIFT_INS   = &h52F4�%DEL_key   = &h5300 : %ALT_DEL   = &h53F1 : %CTRL_DEL       = &h53F2 : %SHIFT_DEL   = &h53F4�%ENTER_key = &h000D :                       %CTRL_ENTER     = &hF20A : %SHIFT_ENTER = &hF40D�%ESC_key   = &h001B :                                                  %SHIFT_ESC   = &hF41B�%BKSPC_key = &h0008 : %ALT_BKSPC = &hF108 : %CTRL_BKSPC     = &hF27F : %SHIFT_BKSPC = &hF408�%TAB_key   = &h0009 :                       %CTRL_TAB       = &h0FF2 : %SHIFT_TAB   = &hF409�%F01_key   = &h3B00 : %ALT_F01   = &h3BF1 : %CTRL_F01       = &h3BF2 : %SHIFT_F01   = &h3BF4�%F02_key   = &h3C00 : %ALT_F02   = &h3CF1 : %CTRL_F02       = &h3CF2 : %SHIFT_F02   = &h3CF4�%F03_key   = &h3D00 : %ALT_F03   = &h3DF1 : %CTRL_F03       = &h3DF2 : %SHIFT_F03   = &h3DF4�%F04_key   = &h3E00 : %ALT_F04   = &h3EF1 : %CTRL_F04       = &h3EF2 : %SHIFT_F04   = &h3EF4�%F05_key   = &h3F00 : %ALT_F05   = &h3FF1 : %CTRL_F05       = &h3FF2 : %SHIFT_F05   = &h3FF4�%F06_key   = &h4000 : %ALT_F06   = &h40F1 : %CTRL_F06       = &h40F2 : %SHIFT_F06   = &h40F4�%F07_key   = &h4100 : %ALT_F07   = &h41F1 : %CTRL_F07       = &h41F2 : %SHIFT_F07   = &h41F4�%F08_key   = &h4200 : %ALT_F08   = &h42F1 : %CTRL_F08       = &h42F2 : %SHIFT_F08   = &h42F4�%F09_key   = &h4300 : %ALT_F09   = &h43F1 : %CTRL_F09       = &h43F2 : %SHIFT_F09   = &h43F4�%F10_key   = &h4400 : %ALT_F10   = &h44F1 : %CTRL_F10       = &h44F2 : %SHIFT_F10   = &h44F4�%F11_key   = &h5700 : %ALT_F11   = &h57F1 : %CTRL_F11       = &h57F2 : %SHIFT_F11   = &h57F4�%F12_key   = &h5800 : %ALT_F12   = &h58F1 : %CTRL_F12       = &h58F2 : %SHIFT_F12   = &h58F4�                      %ALT_0     = &hF130 : %CTRL_0         = &h0BF2�                      %ALT_1     = &hF131 : %CTRL_1         = &h02F2�                      %ALT_2     = &hF132 : %CTRL_2         = &h03F2�                      %ALT_3     = &hF133 : %CTRL_3         = &h04F2�                      %ALT_4     = &hF134 : %CTRL_4         = &h05F2�                      %ALT_5     = &hF135 : %CTRL_5         = &h06F2�                      %ALT_6     = &hF136 : %CTRL_6         = &h07F2�                      %ALT_7     = &hF137 : %CTRL_7         = &h08F2�                      %ALT_8     = &hF138 : %CTRL_8         = &h09F2�                      %ALT_9     = &hF139 : %CTRL_9         = &h0AF2�                      %ALT_A     = &h1EF1 : %CTRL_A         = &hF201�                      %ALT_B     = &h30F1 : %CTRL_B         = &hF202�                      %ALT_C     = &h2EF1 : %CTRL_C         = &hF203�                      %ALT_D     = &h20F1 : %CTRL_D         = &hF204�                      %ALT_E     = &h12F1 : %CTRL_E         = &hF205�                      %ALT_F     = &h21F1 : %CTRL_F         = &hF206�                      %ALT_G     = &h22F1 : %CTRL_G         = &hF207�                      %ALT_H     = &h23F1 : %CTRL_H         = &hF208�                      %ALT_I     = &h17F1 : %CTRL_I         = &hF209�                      %ALT_J     = &h24F1 : %CTRL_J         = &hF20A�                      %ALT_K     = &h25F1 : %CTRL_K         = &hF20B�                      %ALT_L     = &h26F1 : %CTRL_L         = &hF20C�                      %ALT_M     = &h32F1 : %CTRL_M         = &hF20D�                      %ALT_N     = &h31F1 : %CTRL_N         = &hF20E�                      %ALT_O     = &h18F1 : %CTRL_O         = &hF20F�                      %ALT_P     = &h19F1 : %CTRL_P         = &hF210�                      %ALT_Q     = &h10F1 : %CTRL_Q         = &hF211�                      %ALT_R     = &h13F1 : %CTRL_R         = &hF212�                      %ALT_S     = &h1FF1 : %CTRL_S         = &hF213�                      %ALT_T     = &h14F1 : %CTRL_T         = &hF214�                      %ALT_U     = &h16F1 : %CTRL_U         = &hF215�                      %ALT_V     = &h2FF1 : %CTRL_V         = &hF216�                      %ALT_W     = &h11F1 : %CTRL_W         = &hF217�                      %ALT_X     = &h2DF1 : %CTRL_X         = &hF218�                      %ALT_Y     = &h15F1 : %CTRL_Y         = &hF219�                      %ALT_Z     = &h2CF1 : %CTRL_Z         = &hF21A�                  %ALT_MINUS     = &hF12D : %CTRL_MINUS     = &h0CF2�                  %ALT_F_SLASH   = &hF12F : %CTRL_F_SLASH   = &h35F2�                  %ALT_B_SLASH   = &hF15C : %CTRL_B_SLASH   = &hF21C�                  %ALT_EQUAL     = &hF13D : %CTRL_EQUAL     = &h0DF2�                  %ALT_TILDE     = &hF160 : %CTRL_TILDE     = &h29F2�                  %ALT_QUOTE     = &hF127 : %CTRL_QUOTE     = &h28F2�                  %ALT_COLON     = &hF13B : %CTRL_COLON     = &h27F2�                  %ALT_COMMA     = &hF12C : %CTRL_COMMA     = &h33F2�                  %ALT_PERIOD    = &hF12E : %CTRL_PERIOD    = &h34F2�                  %ALT_L_BRACKET = &hF15B : %CTRL_L_BRACKET = &hF21B�                  %ALT_R_BRACKET = &hF15D : %CTRL_R_BRACKET = &hF21D��                  %ALT_GRAY_PLUS = &hF12B : %CTRL_GRAY_PLUS = &h4EF2�                                            %CTRL_GRAY_MINUS= &h4AF2�                                            %CTRL_GRAY_STAR = &h37F2�%GRAY5_key = &h4C00 : %ALT_GRAY5 = &h4CF1 : %CTRL_GRAY5     = &H4CF2��'QUIT ============ Used by LoadData�DECLARE FUNCTION fKeyValue (BYVAL K AS INTEGER) AS INTEGER�'�'-------------------------------------------------------------------------------�'�FUNCTION fKeyValue (BYVAL K AS INTEGER) EXPORT AS INTEGER��  DIM I AS LOCAL INTEGER��  SELECT CASE (INSHIFT AND &b011111)         ' check for <SHIFT>, <CTRL>, or <ALT>�    CASE =  0 : GOTO ExitFunction            '�    CASE = 16 : IF (K>31) AND (K<256) THEN _ ' SHIFT�                  GOTO ExitFunction          '�                I = &h00F4                   '�    CASE < 04 : I = &h00F1                   ' ALT�    CASE < 16 : I = &h00F2                   ' CTRL�  END SELECT                                 '�                                             '�  IF (K < 256) THEN SHIFT LEFT I, 8          ' move flag into most significant nibble�  K = ( K OR I )                             ' insert the flag into the return value��  ExitFunction:�    FUNCTION = K��END FUNCTION��#IF 1�'-------------------------------------------------------------------------------�'----------- TEST CODE ---------------------------------------------------------�'-------------------------------------------------------------------------------�$FileSpec  = "KeyValue.bas"     ' file name of this file��DECLARE FUNCTION fGetKey   () AS INTEGER�DECLARE      SUB  LoadData (V() AS INTEGER,D() AS STRING,SEG Last AS LONG)��FUNCTION PBMAIN ()��  DIM D(202) AS LOCAL STRING�  DIM H      AS LOCAL LONG�  DIM K      AS LOCAL INTEGER�  DIM Last   AS LOCAL LONG�  DIM T(202) AS LOCAL LONG�  DIM Tested AS LOCAL LONG�  DIM V(202) AS LOCAL INTEGER�  DIM X      AS LOCAL LONG��  COLOR 0, 15 : CLS�  LoadData V(), D(), Last��  IF Last = 0 THEN�    PRINT "Can't find "; $FileSpec; " in $FileSpec"�    WAITKEY$�    EXIT FUNCTION�  END IF��  PRINT "Following is a list of 'doubles' (if any)"�  PRINT STRING$(41,45)�  FOR H = 2 TO Last�    INCR X�    IF V(X) = V(H) THEN PRINT D(H); " returns the same as "; D(X)�  NEXT�  PRINT STRING$(41,45)�  PRINT "Press keys to se the return value. Those values that are"�  PRINT "not represented by integer constants will be shown in hex."�  PRINT FORMAT$(Last,"There are a total of ### keys to be tested.")�  PRINT "Press <ESC> to quit."�  PRINT�  COLOR 1, 15�  DO�    K = fGetKey�    ARRAY SCAN V(1) FOR Last, = K, TO H�    IF H = 0 THEN�        PRINT "&h"; HEX$(K,4);�        IF (K > 0) AND (K < 256) THEN PRINT CHR$(32,34,K,34);�      ELSE�        PRINT D(H);�        IF T(H) = 0 THEN�          T(H) = 1�          INCR Tested�          X = Last - Tested�          PRINT TAB(20); FORMAT$(X,"There are ### keys left to be tested.");�        END IF�    END IF�    PRINT�  LOOP UNTIL K = &h001B�  COLOR 0, 15�  PRINT�  PRINT "DONE....."�  WAITKEY$��END FUNCTION�'�'------------------------------------------------------------------------------�'�FUNCTION fGetKey () AS INTEGER��  DIM K AS LOCAL INTEGER��  WHILE NOT INSTAT : WEND                   ' wait for something to happen�                                            '�  IF MOUSESTAT THEN EXIT FUNCTION           ' if a mouse event then RETRUN ZERO�                                            '�  K = CVI(INKEY$)                           ' read/covert the incoming key press�                                            '�  FUNCTION = fKeyValue(K)                   ' convert to DOS key value��END FUNCTION�'�'-------------------------------------------------------------------------------�'�SUB LoadData (V() AS INTEGER, D() AS STRING, SEG Last AS LONG)��  DIM L AS LOCAL STRING�  DIM P AS LOCAL STRING�  DIM X AS LOCAL LONG�  DIM Y AS LOCAL LONG�  DIM Z AS LOCAL LONG��  Z    = UBOUND(V(1))�  Last = 0��  IF LEN(DIR$($FileSpec)) = 0 THEN EXIT SUB��  OPEN $FileSpec FOR INPUT AS #1��    DO�      LINE INPUT #1, L�    LOOP UNTIL LEFT$(L,6) = "'START"��    DO�      LINE INPUT #1, L�      IF LEFT$(L,5) = "'QUIT" THEN EXIT LOOP�      L = TRIM$(L)�      FOR X = 1 TO PARSECOUNT(L,":")�        P = TRIM$(PARSE$(L,":",X))�        IF ASC(P) <> 37 THEN ITERATE�        INCR Last�        D(Last) = TRIM$(PARSE$(P,"=",1))�        V(Last) = VAL(TRIM$(PARSE$(P,"=",2)))�        IF Last = Z THEN�          Z = Z + 10�          REDIM PRESERVE V(Z)�          REDIM PRESERVE D(Z)�        END IF�      NEXT�    LOOP�  CLOSE #1��  ARRAY SORT V(1) FOR Last, TAGARRAY D()��END SUB�#ENDIF�Dave Navarro, Jr.              SPLIT FUNCTION LIKE VB         dave@powerbasic.com            09-16-99 (17:37)       PBCC, PBDLL            41   837      SPLIT.BAS   '�' Perform the same operation as the SPLIT function in Visual Basic 6.0�'�' Takes a string and splits it into a string array based on a specified�' delimeter.  If you don't specify a delimeter, a space is assumed.�'�' Split will work in PB/DLL or PB/CC.�'��SUB Split(BYVAL expression AS STRING, BYVAL delimeter AS STRING, StrArray() AS STRING)��  LOCAL c AS LONG�  LOCAL x AS LONG��  IF LEN(delimeter) = 0 THEN�    delimeter = " "�  END IF��  c = MAX(PARSECOUNT(expression, delimeter), 1)��  REDIM StrArray(0 to c - 1) AS STRING��  FOR x = 1 TO c�    StrArray(x - 1) = PARSE$(expression, delimeter, x)�  NEXT��END SUB��FUNCTION PbMain()��  LOCAL x AS LONG��  DIM s(0 to 0) AS STRING��  Split "This is what it's all about", "", s()��  FOR x = 0 TO UBOUND(s())�    PRINT s(x)�  NEXT��END FUNCTION�Dave Navarro, Jr.              VERSION RESOURCE               dave@powerbasic.com            09-16-99 (17:37)       PBCC, PBDLL            27   982      RES.BAS     #include "resource.h"��VS_VERSION_INFO VERSIONINFO�  FILEVERSION 1,0,0,0               // 1.0�  PRODUCTVERSION 1,0,0,0            // 1.0�  FILEFLAGSMASK 0x3FL               //�  FILEFLAGS 0xAL                    //�  FILEOS VOS_WINDOWS32              //�  FILETYPE VFT_APP                  //�  FILESUBTYPE 0x0L                  //�  BEGIN�    BLOCK "StringFileInfo"�    BEGIN�      BLOCK "040904E4"�      BEGIN�        VALUE "Comments", "\0"�        VALUE "CompanyName", "Your Company.\0"�        VALUE "FileDescription", "Description of file\0"�        VALUE "FileVersion", "1.00\0"�        VALUE "InternalName", "FILENAME.EXE\0"�        VALUE "LegalCopyright", "Copyright \251 PowerBASIC, Inc. 1998\0"�        VALUE "LegalTrademarks", "PowerBASIC\256 is a registered trademark of PowerBASIC, Inc. PB/CC is a trademark of PowerBASIC, Inc.\0"�        VALUE "ProductName", "Product Name\0"�        VALUE "ProductVersion", "1.00\0"�      END�    END�  END�Dave Navarro, Jr.              VB DATE ROUTINES UPDATE        dave@powerbasic.com            10-11-99 (20:31)       PBCC, PBDLL            103  2329     VBDATE.BAS  '==============================================================================�'�'  Dealing with Visual Basic dates in PowerBASIC�'  Compatible with both PB/CC and PB/DLL�'  by Dave Navarro, Jr. (dave@powerbasic.com)�'�'  A VB time variable is stored as an 8-byte real value (double), representing�'  a date between January 1, 1753 and December 31, 2078, inclusive. The value�'  2.0 represents January 1, 1900; 3.0 represents January 2, 1900, and so on.�'  Adding 1 to the value increments the date by a day. The fractional part of�'  the value represents the time of day. Therefore, 2.5 represents noon on�'  Janurary 1, 1900; 3.25 represents 6:00 A.M. on January 2, 1900, and so on.�'  Negative numbers represent the dates prior to December 30, 1899. '�'�'==============================================================================��$IF %DEF(%pb_dll32)�  $COMPILE EXE�$ENDIF�$INCLUDE "WIN32API.INC"��FUNCTION uString(BYVAL x AS STRING) AS STRING��  LOCAL y AS STRING�  LOCAL n AS INTEGER��  IF LEN(x) THEN�    FOR n = 1 TO LEN(x)�      y = y + MKI$(ASC(x, n))�    NEXT n�  END IF��  FUNCTION = y��END FUNCTION��FUNCTION StrToVbDate(BYVAL dt AS STRING) AS DOUBLE��  LOCAL vbdate AS DOUBLE��  dt = uString(dt)�  IF ISFALSE(VarDateFromStr(BYVAL STRPTR(dt), 0, 0, vbdate)) THEN�    FUNCTION = vbdate�  END IF��END FUNCTION��FUNCTION VbDateToStr(BYVAL vbdate AS DOUBLE) AS STRING��  LOCAL d  AS ASCIIZ * 64�  LOCAL dt AS STRING�  LOCAL st AS SYSTEMTIME��  VariantTimeToSystemTime vbdate, st�  GetDateFormat 0, 1, st, BYVAL %NULL, d, 64��  dt = d��  GetTimeFormat 0, 12, st, BYVAL %NULL, d, 64�  dt = dt & " " & d��  FUNCTION = dt��END FUNCTION��FUNCTION Now() AS DOUBLE��  LOCAL st     AS SYSTEMTIME�  LOCAL vbDate AS DOUBLE��  GetSystemTime st�  SystemTimeToVariantTime st, vbDate��  FUNCTION = vbDate��END FUNCTION��'------------------------------------------------------------------------------��FUNCTION PbMain()��  LOCAL dt AS STRING�  LOCAL vb AS DOUBLE��  dt = "March 20, 1967 11:46:00"��  vb = StrToVbDate(dt)��$IF %DEF(%pb_cc32)�  PRINT dt; " ="; vb�$ELSE�  MsgBox dt & " =" & STR$(vb)�$ENDIF��  dt = VbDateToStr(vb)��$IF %DEF(%pb_cc32)�  PRINT vb; "= "; dt�$ELSE�  MsgBox STR$(vb) & " = " & dt�$ENDIF��END FUNCTION�Dave Navarro, Jr.              GET APPLICATION DATA FOLDER    dave@powerbasic.com            10-14-99 (14:40)       PBCC, PBDLL            50   1488     APPDATA.BAS '�' Return the user's defined Application Data folder�' Works in PB/DLL and PB/CC�' Ported from VB code by Dave Navarro, Jr. (dave@powerbasic.com)�'��%NOERROR       = 0�%MAX_LENGTH    = 260�%CSIDL_APPDATA = &H1A��' Declare Public variables.�TYPE ShortItemId�  cb   AS LONG�  abID AS BYTE�END TYPE��TYPE ITEMIDLIST�  mkid AS ShortItemId�END TYPE�� ' Declare API functions.�DECLARE FUNCTION SHGetPathFromIDList LIB "shell32.dll" ALIAS "SHGetPathFromIDList" (BYVAL pidl AS LONG, pszPath AS ASCIIZ) AS LONG�DECLARE FUNCTION SHGetSpecialFolderLocation LIB "shell32.dll" ALIAS "SHGetSpecialFolderLocation" (BYVAL hwndOwner AS LONG, BYVAL nFolder AS LONG, pidl AS ITEMIDLIST) AS LONG��FUNCTION GetApplicationDataFolder( strFolder AS STRING ) AS LONG� ' Returns Zero if Successful, 1 otherwise.� ' This function returns the StartUp Folder Path found� ' in the Current Users Profile.��  LOCAL idlstr AS LONG�  LOCAL sPath  AS ASCIIZ * %MAX_LENGTH�  LOCAL IDL    AS ITEMIDLIST�  LOCAL GetSpecialFolder AS STRING��  ' Fill the idl structure with the specified folder item.�  idlstr = SHGetSpecialFolderLocation( 0, %CSIDL_APPDATA, IDL )��  IF idlstr = %NOERROR THEN�    ' Get the path from the idl list, and return�    ' the folder with a slash at the end.�    idlstr = SHGetPathFromIDList(IDL.mkid.cb, sPath)�    IF idlstr THEN�      strFolder = RTRIM$(sPath, "\") & "\"�      FUNCTION = 0�    END IF�  ELSE�    FUNCTION = 1�  END IF��END FUNCTION�Dave Navarro, Jr.              SAVE & READ ARRAYS TO DISK     dave@powerbasic.com            10-15-99 (13:11)       PBCC, PBDLL            36   680      SAVEREAD.BAS'�' Save and Read arrays to disk�' for PB/DLL 6.0 and PB/CC 2.0�' by Dave Navarro, Jr. (dave@powerbasic.com)�'��#INCLUDE "WIN32API.INC"��SUB SaveToDisk(BYVAL file AS STRING, ANY, BYVAL bytes AS LONG)��#REGISTER DEFAULT��  LOCAL where AS LONG��  ! mov where, [EBP+12]��  OPEN file FOR BINARY AS #1�  SETEOF 1�  WriteFile FILEATTR(1, 2), BYVAL where, bytes, where, BYVAL %NULL�  CLOSE #1��END SUB��SUB ReadFromDisk(BYVAL file AS STRING, ANY, BYVAL bytes AS LONG)��#REGISTER DEFAULT��  LOCAL where AS LONG��  ! mov where, [EBP+12]��  OPEN file FOR BINARY AS #1�  ReadFile FILEATTR(1, 2), BYVAL where, bytes, where, BYVAL %NULL�  CLOSE #1��END SUB�Don Schullian                  SOUNDEX REPRESENTATION FOR PBCCd83@DASoftVSS.com              12-25-99 (19:12)       PBCC                   53   2987     SOUNDEXW.BAS#IF 0�    ----------------------------                      PowerBASIC/cc v2.0� ---|          DASoft          |------------------------------------------�    ----------------------------         code           DATE: 1999-12-25�    | FILE NAME   SoundEX .bas |          by�    | DIRECTORY                |  Don Schullian, Jr.�    ----------------------------��             This code released into the public domain.�� -------------------------------------------------------------------------�  PURPOSE: CREATE a SoundEX representation of a given string�   PARMAS: TheWord$ - the string to be processed�  RETURNS: a LONG INTEGER in the range of 0 -> 656565656� -------------------------------------------------------------------------�#ENDIF��DECLARE FUNCTION fSoundex (BYVAL TheWord AS STRING) AS LONG��FUNCTION fSoundex ( BYVAL TheWord AS STRING ) EXPORT AS LONG��  DIM Char  AS LOCAL LONG                         ' character being processed�  DIM Last  AS LOCAL LONG                         ' last character processed�  DIM Temp  AS LOCAL ASCIIZ * 10                  ' buffer for outgoing value�  DIM T_ptr AS LOCAL BYTE PTR                     ' pointer to temp buffer�  DIM Tidx  AS LOCAL LONG                         ' index to temp pointer�  DIM W_ptr AS LOCAL BYTE PTR                     ' pointer to incoming data�  DIM Widx  AS LOCAL LONG                         ' index to incoming data pointer�                                                  '�  TheWord = UCASE$(TheWord)                       ' upper case for consistancy�  W_ptr   = STRPTR(TheWord)                       ' set ptr to incoming string�  T_ptr   = VARPTR(Temp)                          ' set ptr to temp buffer�                                                  '�  FOR Widx = 0 TO LEN(TheWord) -1                 ' process each char in incoming string�    SELECT CASE @W_ptr[Widx]                      '  by character value�      CASE 66, 70, 80, 86             : Char = 49 '�      CASE 67, 71, 74, 81, 83, 88, 90 : Char = 50 '�      CASE 68, 84                     : Char = 51 '�      CASE 76                         : Char = 52 '�      CASE 77, 78                     : Char = 53 '�      CASE 82                         : Char = 54 '�      CASE ELSE                       : ITERATE   '  skip everything else�    END SELECT                                    '�    IF Char = Last THEN ITERATE                   ' no doubles allowed�    @T_ptr[Tidx] = Char                           ' set new char in temp buffer�    IF Tidx = 8 THEN EXIT FOR                     ' if buffer is full then we're done�    INCR Tidx                                     ' next character position�    Last = Char                                   ' save this char's value for test�  NEXT                                            '�                                                  '�  FUNCTION = VAL(Temp)                            'RETURN LONG INTEGER VALUE��END FUNCTION�Don Schullian                  PACK/UNPACK STRING TO/FROM QUADd83@DASoftVSS.com              01-14-00 (03:11)       PBCC                   145  5677     STR2QUAD.BAS$IF 0�    ----------------------------                      PowerBASIC/cc v2.0� ---|          DASoft          |------------------------------------------�    ----------------------------         Code           DATE: 2000-01-14�    | FILE NAME   STR2QUAD.bas |          by�    | DIRECTORY                |  Don Schullian, Jr.�    ----------------------------�             This code is placed into the Public Domain� -------------------------------------------------------------------------�  PURPOSE: pack and unpack strings into/from a QUAD integer�   PARMAS: TheString - A STRING of no more than 12 characters�           TheQuad   - A QUAD integer that carries a packed string�     NOTE: The incoming string will be UCASEd and all characters other�           than the 26 letters of the alphabet and the SPACE will be�           discarded� -------------------------------------------------------------------------�  Similar routines to these were developed while I was building an anagram�game. The speed difference in locating a word in list of 80,000 strings�was prohibitive hence the use of QUAD integers. QUADs proved to be about 10�times faster than STRINGS.��  These QUADs are packed to hold up to 12 characters with 4 bits left over�and sort alphabetically. One COULD use 3 of the left over bits as a flag and�still maintain alphabetical order by shifting the QUAD left 3 bits and ORing�the flag(s) onto the end then, when unpacking, remove the flag(s) first.��  These routines could come in handy to create index keys.��  PB/DOS users should make the following changes to the code:�    Change: LONGs  to INTEGERs in all cases�            STRPTR to STRPTR32 in fString2Quad�            VARPTR to VARPTR32 in fQuad2String��    Remove: the following lines�            FUNCTION PBmain ()�            FORMAT$�            WAITKEY$�            END FUNCTION��N'joy,��   ____    _    ____      ____  _____�  |  _ \  / \  / ___) __ | ___)(_   _) Don Schullian�  | |_)  / _ \ \____\/  \|  _)   | |    d83@DASoftVSS.com�  |____//_/ \_\(____/\__/|_|     |_|    www.DASoftVSS.com�  ___________________________________   www.basicguru.com�      Vertical Software Solutions���$ENDIF�'�'-------------------------------------------------------------------------------�'�FUNCTION fString2Quad(BYVAL TheString AS STRING) AS QUAD��  DIM C       AS LOCAL LONG�  DIM Offset  AS LOCAL LONG�  DIM S_ptr   AS LOCAL BYTE PTR�  DIM Slen    AS LOCAL LONG�  DIM TheQuad AS LOCAL QUAD��  Slen  = MIN(12,LEN(TheString)) -1    ' length of string -1�  IF Slen < 0 THEN EXIT FUNCTION       ' nothing to do here�  S_ptr = STRPTR(TheString)            ' set string pointer�                                       '�  FOR Offset = 0 TO Slen               ' once for each character�    C = @S_ptr[Offset]                 '  glean ASCii value from string�    SELECT CASE C                      '  convert ASCii value�      CASE 65 TO  90 : C = C - 64      '   already UPPER CASE�      CASE 97 TO 122 : C = C - 96      '   UCASE the value�      CASE = 32      : GOTO NoORing    '   this is a space�      CASE ELSE      : ITERATE         '   not a valid character�    END SELECT                         '�    TheQuad = (TheQuad OR C)           '  OR the new value to the buffer�    NoORing:                           '�    IF Offset = Slen THEN EXIT FOR     '�    SHIFT LEFT TheQuad, 5              '�  NEXT                                 '�                                       '�  IF Slen < 11 THEN                    '�    C = 5 * ( 11 - Slen )              '�    SHIFT LEFT TheQuad, C              '�  END IF                               '�                                       '�  FUNCTION = TheQuad                   ' RETURN PACKED STRING��END FUNCTION�'�'-------------------------------------------------------------------------------�'�FUNCTION fQuad2String(BYVAL TheQuad AS QUAD) AS STRING��  DIM C         AS LOCAL LONG�  DIM Offset    AS LOCAL LONG�  DIM S_ptr     AS LOCAL BYTE PTR�  DIM TheString AS LOCAL STRING * 12��  IF TheQuad = 0 THEN EXIT FUNCTION    ' nothing to do here�  S_ptr = VARPTR(TheString)            ' set string pointer�                                       '�  FOR Offset = 11 TO 0 STEP -1         ' unpack 12 characters�    C = (TheQuad AND 31)               '  read value from 5 bits�    SHIFT RIGHT TheQuad, 5             '  move next 5 bits into line�    IF C > 0 THEN                      '   convert value into ASCii value�      @S_ptr[Offset] = C + 64          '�    END IF                             '�  NEXT                                 '�                                       '�  FUNCTION = RTRIM$(TheString)         ' RETURN THE UNPACKED STRING��END FUNCTION�'�'-------------------------------------------------------------------------------�'�FUNCTION PBmain ()                                 ' remove this line for�PB/DOS��  DIM L     AS LOCAL LONG�  DIM Q(20) AS LOCAL QUAD�  DIM S(20) AS LOCAL STRING�  DIM X     AS LOCAL LONG��  RANDOMIZE TIMER�  S(0) = "hello world"�  Q(0) = fString2Quad(S(0))�  FOR X = 1 TO 20�    L = RND(1,12)�    WHILE L > 0�      S(X) = S(X) & CHR$(RND(65,90))�      DECR L�    WEND�    Q(X) = fString2Quad(S(X))�  NEXT��  ARRAY SORT S(0), COLLATE UCASE�  ARRAY SORT Q(0)�  FOR X = 0 TO 20�    PRINT S(X); TAB(14);�    PRINT fQuad2String(Q(X)); TAB(28);�    PRINT FORMAT$(Q(X),"###,###,###,###,###,###,###") ' remove this line�  NEXT��  WAITKEY$                                            ' remove this line��END FUNCTION                                          ' remove this line�Dave Navarro, Jr.              CONVERT IP ADDRESS TO STRING   dave@powerbasic.com            01-20-00 (14:27)       PBCC, PBDLL            11   308      IP.BAS      ' Convert a long integer representing an IP address to a displayable string�'�FUNCTION IpToString(BYVAL ip AS LONG) AS STRING��   LOCAL b AS BYTE PTR��   b = VARPTR(ip)�   FUNCTION = FORMAT$(@b[0]) & "." & FORMAT$(@b[1]) & "." & _�              FORMAT$(@b[2]) & "." & FORMAT$(@b[3])��END FUNCTION�Dave Navarro, Jr.              2 IP ADDRESSES ON YOUR COMPUTERdave@powerbasic.com            01-20-00 (14:27)       PBCC, PBDLL            89   3476     2IPS.BAS    If your computer is connected to a network using a network card, and it has �a modem in it.  It's possible for your computer to have two IP addresses at �the same time.��One IP address for the network connection and one IP address for your �dialup connection.��When your computer boots up, the first IP address assigned to it is for the �network card.  So the following code will return the IP address for your �network connection:��   HOST ADDR TO ip&��When you connect to the internet using your modem, a second IP address is �assigned to your computer (by your ISP).  But the preceding code will still �return the address of your network card, not the new IP address for your �internet connection.��In that situation you can use the following to get the IP address for your �modem connection:��   HOST ADDR(2) TO ip&��The reason that you would want to is because some mail servers are set up �so that they will only allow connections from authorized IP �addresses.  Most ISP's won't let anyone who is not dialed up through them �connect to their mail server to send a message.  This prevents non-users �from sending spam through their servers.��In most cases, the SMTP server will simply look at the IP address of the �incoming connection to make that determination.  However, sometimes the �SMTP server looks at the IP address specified in the "HELO ..." command to �determine if you can connect to it.  In this case, sending the IP address �of your network card will cause the connection to fail.��On Windows 95 and 98 machines, you can only have one IP address per network �connection.  (If you have two network cards in your computer, they'll each �get their own IP address).  So it's technically possible to have more than �two IP addresses on your machine.  Particularly with Windows NT where you �can actually assign more than one IP address to a single network card.��Trying to use "HOST ADDR(n)" in those situations is practically useless �because there is no way to know which IP address in the sequence is being �used for the connection to the SMTP server.��What should you do?  Use the WINSOCK API!   :)��The trick is to use "TCP OPEN" to connect to the server.  This causes �PowerBASIC to create a valid socket for connection.  Once that's done, you �can use the socket handle to get the IP address of the connection.��TCP OPEN uses the PowerBASIC file system, so the socket handle used in your �code is not a valid WINSOCK handle.  You need to use the FILEATTR() �function to obtain the actual WINSOCK handle.��Once you've done that, you can use the API call getsockname() to get the IP �address that was used for the connection.  In the next reply, I'll post a �function that does this.��-------------------------------[ code ]-------------------------------��UNION in_addr�   s_addr AS LONG�   s AS STRING * 4�END UNION��TYPE sockaddr_in�   sin_family AS WORD�   sin_port AS WORD�   sin_addr AS in_addr�   sin_zero AS STRING * 8�END TYPE��DECLARE FUNCTION getsockname LIB "wsock32.dll" ALIAS "getsockname" _�    (BYVAL s AS LONG, sname AS sockaddr_in, namelen AS LONG) AS LONG��FUNCTION TcpAddr(BYVAL s AS LONG) AS LONG��   LOCAL sa AS sockaddr_in�   LOCAL l  AS LONG��   s = FILEATTR(s,2) ' get winsock socket handle�   l = SIZEOF(sa)��   IF getsockname(s, sa, l) = 0 THEN�     FUNCTION = sa.sin_addr.s_addr   'return IP address of connection�   END IF��END FUNCTION�Dave Navarro, Jr.              EXTRACT LINKS FROM TEXT FILE   dave@powerbasic.com            01-20-00 (14:27)       PBCC, PBDLL            38   844      LINKS.BAS   'This is a quick & dirty little utility I wrote to extract all of the links �'in a text file and display them on the screen (redirectable).��FUNCTION PbMain()��   LOCAL htmlfile AS STRING�   LOCAL buffer   AS STRING�   LOCAL link     AS STRING�   LOCAL s        AS LONG�   LOCAL l        AS LONG��   htmlfile = TRIM$(COMMAND$)��   IF ISFALSE LEN(DIR$(htmlfile)) THEN�     PRINT "Error: "; htmlfile;" not found."�     EXIT FUNCTION�   END IF��   OPEN htmlfile FOR BINARY AS #1�     GET$ #1, LOF(1), buffer�   CLOSE #1��   STDOUT "File: " & htmlfile�   STDOUT ""��   s = 1�   DO�     REGEXPR "<a href=.+>.+</a>" IN buffer AT s TO s, l�     IF ISFALSE s THEN�       EXIT DO�     ELSE�       link = REMOVE$(MID$(buffer, s, l), ANY CHR$(13,10))�     END IF�     STDOUT link�     s = s + l�   LOOP��END FUNCTION�Egbert Zijlema                 RECYCLE BIN EXAMPLE            dave@powerbasic.com            01-20-00 (14:27)       PBCC, PBDLL            24   948      RECYCLE.BAS #COMPILE EXE�#INCLUDE "WIN32API.INC"��FUNCTION RecycleBin(FilNam AS STRING) AS LONG�   LOCAL shfo AS SHFILEOPSTRUCT                 ' predefined structure�   LOCAL szSource AS ASCIIZ * 64�   szSource = FilNam + CHR$(0)                  ' convert to ASCIIZ�   shfo.wFunc = %FO_DELETE                      ' function delete file�   shfo.pFrom = VARPTR(szSource)                ' pointer to file�   shfo.fFlags = %FOF_ALLOWUNDO                 ' enable undo�   dummy& = SHFileOperation(shfo)               ' call funtion�   FUNCTION = shfo.fAnyOperationsAborted        ' return value, either 0 or non-zero�END FUNCTION��FUNCTION PBMAIN()�   LOCAL RetVal AS LONG�   RetVal = RecycleBin("C:\MYFILE.TXT")��   ' use the following lines only when the deleted file is part of an array or in a listbox�   IF RetVal = 0 THEN�     ARRAY DELETE StringArray(index)�     LISTBOX DELETE hDlg,  %IDLISTBOX,  position&�   END IF�END FUNCTION�Kispen                         INI FUNCTIONS FOR PBCC         kispen@mailpanda.com           02-01-00 (22:16)       PBCC                   320  11123    INI.BAS     $if 0�Uuhh... has something like this been done already? If it has... sorry... you'll probably want�to use the other one ;). This contains functions to work with INI files. Any bugs or anything,�e-mail me... the address is at the end of this if/endif block. Here are the functions:�***********************************************************************************************� OpenINI(INIFile$) as Integer �     Opens the INI file... call this first, always� 	returns 0 if it's ok, -1 if it's not.� � ReadKey$(Section$, Key$)�     Gets the value of Key$ in Section$� 	returns the value of Key$ (if found)� 	returns "Section not found" if Section$ isn't found� 	returns "Key not found" if Key$ isn't found� � WriteKey(Section$, Key$, Value$) as Integer�     Writes Value$ to Key$ in Section$� 	returns 0 if it's ok, -1 if Section$ wasn't found� 	� WriteSection(Section$) (this is a sub) <-- writes a section.� � DeleteKey(Section$, Key$) as Integer <-- Figure this one out ;-)� 	returns 0 if it's ok� 	returns -1 if Section$ wasn't found� 	returns -2 if Key$ wasn't found� 	� DeleteSection(Section$) as Integer <-- hmm... wonder what this does....� 	returns 0 if it's ok� 	returns -1 if Section$ wasn't found� 	� SaveINI(INIFile$) as Integer <-- hmmmm......� 	returns 0 if it's ok, -1 if it's not�***********************************************************************************************� �Hopefully, this can help you out... a little :). I should add code to ignore a line (e.g. not�put the line into INIArray() if it's blank, but I want the INI file to be written exactly as�it was read... so I didn't. Erm... sorry for the messy code, I just sorta stick things in as�they come into my head. Oh, btw, I don't like ARRAY SCAN. I really don't. Oh, second btw... I�think this thing is pretty slow. Please, please, modify it... make it faster... It'd be cool to�get this thing going fast... Oh, third btw... I think there are API calls to write/read from�INI files, but from what I saw they only wrote/read to win.ini or the registry... Then again,�I could be wrong. I only looked at it for a couple of minutes.��Oh yea, final warning: Don't use INIArray(), INISectionIndex(), or INISectionIndexMax in your�program. If you do, you could mess this up. Blah...��Kispen (kispen@mailpanda.com)�$endif��global INIArray() as string�global INISectionIndex() as integer�global INISectionIndexMax as long��function OpenINI(INIFile$) as integer�$if 0�OK, here's how this little baby works...�1) Check to see if the file exists (if not, return -1)�2) Open the file�3) Put each line of the file into INIArray()�4) If the line begins with [ and ends with ] then it's a section, and we should put the number�   into INISectionIndex()... hence the name 'index' hehehe�5) End the function.�$endif� local x as integer� local NumberFree as integer�  � INILine$ = "" � x = 0� NumberFree = 0� � ' Check to see if the file exists� if dir$(INIFile$) = "" then function = -1: exit function� � ' Open the INI File� NumberFree = Freefile� open INIFile$ for input as NumberFree� � do until eof(NumberFree)�  x = x + 1�  line input #NumberFree, INILine$�  �  ' Check to see if it's a section, and update accordingly�  if left$(INILine$, 1) = "[" and right$(INILine$, 1) = "]" then�  	INISectionIndexMax = ubound(INISectionIndex) + 1�  	redim preserve INISectionIndex(0 to INISectionIndexMax)�  	INISectionIndex(INISectionIndexMax) = x�  end if�  �  ' Add another line to INIArray�  redim preserve INIArray(1 to x)�  INIArray(x) = INILine$� loop� close NumberFree� function = 0�end function��function ReadKey$(Section$, Key$)�$if 0�Here is how this one works:�1) Add [ or ] to Section$ if necessary�2) Use INISectionIndex() to match the section... if section isn't found, say so.�3) Scan INIArray() from the section to the next section (or the end of the array) for Key$�4) If Key$ isn't found, say so and exit�5) Get the value of Key$ and send it down... then exit.�$endif�   local FoundSection as integer�   local FoundKey as integer�   local x as integer�   local LenKey as integer�   local LowerScan as integer�   local UpperScan as integer�   local Counter as integer�   local tempKey as string�   �   FoundSection = 0�   x = 0�   LenKey = 0�   tempKey = ""�   �   ' Add [ or ] if needed�   IF LEFT$(Section$, 1) <> "[" THEN Section$ = "[" + Section$�   IF RIGHT$(Section$, 1) <> "]" THEN Section$ = Section$ + "]"��   FOR x = 1 TO INISectionIndexMax�       IF INIArray(INISectionIndex(x)) = Section$ THEN�          FoundSection = INISectionIndex(x)�          ' Ok, we have to check to see if there's another section or not. If there is, then�          ' we should stop scanning at that number. If there isn't, then we should stop scanning�          ' at the last number of the file array (since, obviously, if there is no next section,�          ' it's the end of the file.�          if x = ubound(INISectionIndex) then�          	UpperScan = ubound(INIArray)�          else�          	UpperScan = INISectionIndex(x + 1)�          end if�          EXIT FOR�       END IF�   NEXT x�   if FoundSection = 0 then function = "Section not found": exit function��   LenKey = LEN(Key$)�   LowerScan = FoundSection�   �   'I would love to use ARRAY SCAN, but I don't like its limitations...�   'ARRAY SCAN INIArray(FoundSection), FROM 1 TO LenKey, = Key$, TO i&�   �   FoundKey = 0�   for Counter = LowerScan to UpperScan�   	if left$(INIArray(Counter), LenKey) = Key$ then�   		FoundKey = Counter�   		exit for�   	end if�   next Counter�   if FoundKey = 0 then function = "Key not found": exit function�   tempKey = INIArray(FoundKey)�   tempKey = trim$(right$(tempKey, Len(tempKey) - LenKey)) ' Get rid of the Key string...�   �   ' If there is an "=", then get rid of it, and all surrounding spaces�   if left$(tempKey, 1) = "=" then tempKey = trim$(right$(tempKey, Len(tempKey) - 1))�   �   ' Send the string.. modified or not.�   function = tempKey�end function��function WriteKey(Section$, Key$, Value$) as integer�$if 0�Hmm... k, flowchart for this one�1) Add [ and ] to Section$ if necessary�2) Find the section�3) ARRAY INSERT a line into it... and set it equal to Key$=Value$�4) End the function...�$endif� local FoundSection as integer� local x as integer� � if left$(Section$, 1) <> "[" then Section$ = "[" + Section$� if right$(Section$, 1) <> "]" then Section$ = Section$ + "]"� � FOR x = 1 TO INISectionIndexMax�    IF INIArray(INISectionIndex(x)) = Section$ THEN�       FoundSection = INISectionIndex(x)�       EXIT FOR�    END IF� NEXT x� if FoundSection = 0 then function = -1: exit function� � redim preserve INIArray(1 to ubound(INIArray)+1) ' Make room for the new key� NewKey$ = Key$ + "=" + Value$� array insert INIArray(FoundSection + 1), NewKey$� function = 0�end function��sub WriteSection(Section$)� if left$(Section$, 1) <> "[" then Section$ = "[" + Section$� if right$(Section$, 1) <> "]" then Section$ = Section$ + "]"� redim preserve INIArray(1 to ubound(INIArray)+1) ' Make room for the new section� INIArray(ubound(INIArray)) = Section$�end sub��function DeleteKey(Section$, Key$) as integer�'This works surprisingly like ReadKey... I wonder why. :P��   local FoundSection as integer�   local FoundKey as integer�   local x as integer�   local LenKey as integer�   local LowerScan as integer�   local UpperScan as integer�   local Counter as integer�   local tempKey as string�   �   FoundSection = 0�   x = 0�   LenKey = 0�   tempKey = ""�   �   ' Add [ or ] if needed�   IF LEFT$(Section$, 1) <> "[" THEN Section$ = "[" + Section$�   IF RIGHT$(Section$, 1) <> "]" THEN Section$ = Section$ + "]"��   FOR x = 1 TO INISectionIndexMax�       IF INIArray(INISectionIndex(x)) = Section$ THEN�          FoundSection = INISectionIndex(x)�          ' Ok, we have to check to see if there's another section or not. If there is, then�          ' we should stop scanning at that number. If there isn't, then we should stop scanning�          ' at the last number of the file array (since, obviously, if there is no next section,�          ' it's the end of the file.�          if x = ubound(INISectionIndex) then�          	UpperScan = ubound(INIArray)�          else�          	UpperScan = INISectionIndex(x + 1)�          end if�          EXIT FOR�       END IF�   NEXT x�   if FoundSection = 0 then function = -1: exit function��   LenKey = LEN(Key$)�   LowerScan = FoundSection�   �   'I would love to use ARRAY SCAN, but I don't like its limitations...�   'ARRAY SCAN INIArray(FoundSection), FROM 1 TO LenKey, = Key$, TO i&�   �   FoundKey = 0�   for Counter = LowerScan to UpperScan�   	if left$(INIArray(Counter), LenKey) = Key$ then�   		FoundKey = Counter�   		exit for�   	end if�   next Counter�   if FoundKey = 0 then function = -2: exit function�   ARRAY DELETE INIArray(FoundKey)�   function = 0�end function��function DeleteSection(Section$) as integer�' Look at all the cut-n-paste! Basically, it's a modified ReadKey$��   local FoundSection as integer�   local FoundKey as integer�   local x as integer�   local LenKey as integer�   local LowerScan as integer�   local UpperScan as integer�   local Counter as integer�   local tempKey as string�   �   FoundSection = 0�   x = 0�   LenKey = 0�   tempKey = ""�   �   ' Add [ or ] if needed�   IF LEFT$(Section$, 1) <> "[" THEN Section$ = "[" + Section$�   IF RIGHT$(Section$, 1) <> "]" THEN Section$ = Section$ + "]"��   FOR x = 1 TO INISectionIndexMax�       IF INIArray(INISectionIndex(x)) = Section$ THEN�          FoundSection = INISectionIndex(x)�          ' Ok, we have to check to see if there's another section or not. If there is, then�          ' we should stop scanning at that number. If there isn't, then we should stop scanning�          ' at the last number of the file array (since, obviously, if there is no next section,�          ' it's the end of the file.�          if x = ubound(INISectionIndex) then�          	UpperScan = ubound(INIArray)�          else�          	UpperScan = INISectionIndex(x + 1)�          end if�          EXIT FOR�       END IF�   NEXT x�   if FoundSection = 0 then function = -1: exit function�   LowerScan = FoundSection��   for Counter = LowerScan to UpperScan - 1�   	' It's gotta be LowerScan since as soon as you delete it, the next one you want to�   	' delete is at LowerScan....�   	ARRAY DELETE INIArray(LowerScan)�   	redim preserve INIArray(1 to ubound(INIArray) - 1)     ' Get rid of the extra space�   next Counter�   function = 0�end function��function SaveINI(INIFile$) as integer�$if 0�1) Open INIFile$�2) Write INIArray() to it.�3) Close INIFile$�$endif� local NextFree as integer� local x as integer� � NextFree = Freefile� Open INIFile$ for output as #NextFree� for x = 1 to ubound(INIArray)�  print #NextFree, INIArray(x)� next x� Close #NextFree� function = 0�end function�Don Schullian                  FINPUT FOR PBCC                d83@DASoftVSS.com              03-17-00 (16:37)       PBCC                   260  8552     CC_INPUT.BASfInput% function for PowerBASIC Console Compiler�   coded by: Don Schullian  d83@DASoftVSS.com�   public domain��Welcome,��  This code is offered as an (better?) alternative to INPUT$. It�allows for cursoring around a field, deletion, insertion, overwrite,�scrolling, and bail out without saving the/any changes.��  Its use is demonstrated below using an array to allow for editing�a screen full of data in one loop. This code could, very easily be�placed into it's own function and called several times in a single�program.��  There are a series of CONSTANTS set that are used by the function�You may, of course, put their values into the function or, in some�cases, send the values to the function to allow for more control by�varied other functions.��  This offering is just a starting point for those of you who are�more adventurous. Over the years I've developed 10 different�variations of this function that control and guide the users' input.�One of them works only for numerical input and looks & feels like�a calculator; another allows input of only specific characters;�while others handle hexadecimal input, masked fields, multiple lines�and other varied field types. A bit of imagination goes a LONG way!��  fGetKey% is my basic keyboard input function and I never leave�home without it. There is a full discussion on how and why on�either of my web pages. www.basicguru.com/scullian or�www.DASoftVSS.com along with some other goodies.��  If you have any questions, give me a shout.��   ____    _    ____      ____  _____�  |  _ \  / \  / ___) __ | ___)(_   _) Don Schullian�  | |_)  / _ \ \____\/  \|  _)   | |    d83@DASoftVSS.com�  |____//_/ \_\(____/\__/|_|     |_|    www.DASoftVSS.com�  ___________________________________   www.basicguru.com�      Vertical Software Solutions���'----------------------------------------------------------------------�' fInput%(Datum$,Row&,Col&,VisCols&,MaxLen&,ExitKeys$)�'�' PURPOSE: Allow user input in an editable, friendly environment�'  PARAMS: Datum$     incoming the data already found in the field�'                     returning the edited data�'          Row&, Col& the left most screen position of the field�'          VisCols&   the number of visable characters on screen�'          MaxLen&    the maximum number of characters in the field�'          ExitKeys$  the MKI$(keyvalue%) of all the keys OTHER THAN�'                       <ESC> and <ENTER> that will return from the�'                       function�'    NOTE: If VisCols& =< MaxLen& then the value will be set to match�'          that of MaxLen&�'--------------------------------------------------------------------------��%Esc_key   = &h001B             ' key codes returned by fGetKey%�%Enter_key = &h000D�%BkSpc_key = &h0008�%Del_key   = &h5300�%Up_key    = &h4800�%Down_key  = &h5000�%Ins_key   = &h5200�%Left_key  = &h4B00�%Right_key = &h4D00�%Ctrl_Del  = &h9300�%F10_key   = &h4400�%Home_key  = &h4700�%End_key   = &h4F00��%Fgrnd    = 15                 ' editing foreground�%Bgrnd    =  1                 ' editing background��DECLARE FUNCTION fInput(SEG D AS STRING,BYVAL Row AS LONG,BYVAL Col AS�LONG,BYVAL VisLen AS LONG,BYVAL MaxLen AS LONG,BYVAL ExitKeys AS STRING) AS�INTEGER�DECLARE FUNCTION fGetKey() AS INTEGER��FUNCTION PBmain ()��  DIM C        AS LOCAL LONG�  DIM Col      AS LOCAL LONG�  DIM D(5)     AS LOCAL STRING�  DIM ExitKeys AS LOCAL STRING�  DIM F(2,5)   AS LOCAL LONG�  DIM Fld      AS LOCAL LONG�  DIM G        AS LOCAL INTEGER�  DIM Prompt   AS LOCAL STRING�  DIM X        AS LOCAL LONG��  COLOR 0, 15�  CLS�  D(0) = "Mary had a little lamb, its fleece was white as snow."�  G = fInput(D(0), 2, 10, 20, 70, "")�  LOCATE 2, 1: PRINT D(0);��  FOR X = 1 TO 5�    INCR C : Prompt = READ$(C)�    INCR C : D(X)   = READ$(C)�    INCR C : F(0,X) = VAL(READ$(C))�    INCR C : F(1,X) = VAL(READ$(C))�    INCR C : F(2,X) = VAL(READ$(C))�    Col = F(1,X) - LEN(Prompt) - 1�    COLOR 8, 15�    LOCATE F(0,X), Col�    PRINT Prompt;�    COLOR 1, 15�    LOCATE F(0,X), F(1,X)�    PRINT LEFT$(D(X), F(2,X))�  NEXT��  LOCATE 25, 1�  PRINT "Use Arrows to move - F-10 to save & exit - <ESC> to quit";��  ExitKeys = MKI$(%F10_key) + MKI$(%Up_Key) + MKI$(%Down_Key)��  Fld = 1�  DO�    IF Fld < 1 THEN�        Fld = 5�      ELSEIF Fld > 5 THEN�        Fld = 1�    END IF�    G = fInput( D(Fld), F(0,Fld), F(1,Fld), 0, F(2,Fld), ExitKeys)�    SELECT CASE G�      CASE %F10_key : EXIT LOOP�      CASE %Esc_Key : EXIT LOOP�      CASE %Up_Key  : DECR Fld�      CASE ELSE     : INCR Fld�    END SELECT�  LOOP�  FOR X = 1 TO 5�    LOCATE X + 10, 1�    PRINT D(X)�  NEXT�  WAITKEY$��  DATA "Last Name:", "Schullian"   , 6, 20, 17�  DATA "Frst Name:", "Don"         , 7, 20, 17�  DATA "Street:"   , "My Street 27", 8, 20, 30�  DATA "City:"     , "Hometown"    , 9, 20, 30�  DATA "Zip:"      , "12345-2433"  , 9, 56, 10��END FUNCTION�'�'-------------------------------------------------------------------------------�'�FUNCTION fGetKey () EXPORT AS INTEGER��  DIM G AS LOCAL STRING��  G = WAITKEY$��  IF LEN(G) = 1 THEN�      FUNCTION = ASC(G)�    ELSE�      FUNCTION = CVI(G)�  END IF��END FUNCTION�'�'-------------------------------------------------------------------------------�'�FUNCTION fInput (  SEG Datum    AS STRING, _�                 BYVAL Row      AS LONG  , _�                 BYVAL Col      AS LONG  , _�                 BYVAL VisLen   AS LONG  , _�                 BYVAL MaxLen   AS LONG  , _�                 BYVAL ExitKeys AS STRING  ) EXPORT AS INTEGER��  DIM Bgrnd  AS LOCAL LONG          ' original background color�  DIM Cpos   AS LOCAL LONG          ' current cursor position within string�  DIM E      AS LOCAL LONG          ' temp variable�  DIM Fgrnd  AS LOCAL LONG          ' original foreground color�  DIM Inzert AS LOCAL LONG          ' insert state�  DIM KeyVal AS LOCAL LONG          ' incoming key-press value�  DIM MaxOff AS LOCAL LONG          ' maximum offset position�  DIM Offset AS LOCAL LONG          ' 1st character shown in field�  DIM Temp   AS LOCAL STRING * 256  ' working data string��  Temp     = LTRIM$(Datum)�  Inzert   = 10�  ExitKeys = MKI$(%ESC_key) & MKI$(%Enter_Key) & ExitKeys$�  Bgrnd    = SCREENATTR(Row, Col)�  Fgrnd    = (Bgrnd AND 15)�  Bgrnd    = (Bgrnd  \  16)�  Offset   = 1��  IF ( VisLen = 0      )   OR _�     ( VisLen > MaxLen ) THEN VisLen = MaxLen�  MaxOff = (MaxLen - VisLen + 1)��  GOSUB fInputEOL�  COLOR %Fgrnd, %Bgrnd�  CURSOR ON, Inzert��  DO�    IF Cpos < 1 THEN�        Cpos = 1�      ELSEIF Cpos > MaxLen THEN�        Cpos = MaxLen�    END IF�    IF Cpos < Offset THEN�        Offset = Cpos�      ELSEIF (Cpos - Offset + 2) > VisLen THEN�        Offset = MIN(MaxOff,(Cpos - VisLen + 1))�    END IF�    GOSUB fInputPrint�    LOCATE Row, (Col + Cpos - Offset)�    KeyVal = fGetKey�    E = INSTR(ExitKeys, MKI$(KeyVal))�    IF (E AND 1) = 1 THEN EXIT LOOP�    SELECT CASE KeyVal�      CASE 32 TO 255   : IF (Inzert > 10) OR (Cpos = MaxLen) THEN�                             ASC(Temp,Cpos) = KeyVal�                           ELSE�                             Temp = STRINSERT$(Temp,CHR$(KeyVal),Cpos)�                         END IF�                         INCR Cpos�      CASE %BkSpc_Key  : IF Cpos > 1 THEN�                          DECR Cpos�                          Temp = STRDELETE$(Temp,Cpos,1)�                         END IF�      CASE %Del_Key    : Temp = STRDELETE$(Temp,Cpos,1)�      CASE %Home_Key   : Cpos = 1�      CASE %End_Key    : GOSUB fInputEOL�      CASE %Left_Key   : DECR Cpos�      CASE %Right_Key  : INCR Cpos�      CASE %Ins_Key    : IF Inzert = 10 THEN Inzert = 50 ELSE Inzert = 10�                         CURSOR ON, Inzert�    END SELECT�  LOOP��  Offset = 1�  IF KeyVal <> %Esc_Key THEN Datum = TRIM$(Temp)�  Temp = Datum�  COLOR Fgrnd, Bgrnd�  GOSUB fInputPrint��  FUNCTION = KeyVal�  EXIT FUNCTION�  '-----------------------------------------------------------------�  '------------- local routines�  '-----------------------------------------------------------------�  fInputPrint:�    LOCATE Row, Col�    PRINT MID$(Temp, Offset, VisLen);�  RETURN�  '-----------------------------------------------------------------�  fInputEOL:�    FOR Cpos = MaxLen TO 1 STEP -1�      IF ASC(Temp, Cpos) <> 32 THEN EXIT FOR�    NEXT�    INCR Cpos�  RETURN��END FUNCTION�Don Schullian                  SOUNDEX INDEXING SYSTEM        d83@DASoftVSS.com              04-11-00 (16:35)       PBCC                   532  31120    SNDEXKEY.BAS#if 0�    ----------------------------                      PowerBASIC/cc v2.0� ---|          DASoft          |------------------------------------------�    ----------------------------         Code           DATE: 2000-04-08�    | FILE NAME   SndEXkey.bas |          by�    ----------------------------  Don Schullian, Jr.��              This code is released into the Public Domain�       ----------------------------------------------------------�        No guarantee as to the viability, accuracy, or safety of�         use of this code is implied, warranted, or guaranteed�       ----------------------------------------------------------�                         Use at your own risk!�       ----------------------------------------------------------�                  CONTACT AUTHOR AT d83@DASoftVSS.com� -------------------------------------------------------------------------�  PURPOSE: Create & maintain a SoundEX key file� -------------------------------------------------------------------------��  The theory behind all this is that the user requires to search on a�given data set for one or more keywords that are NOT included in any of�the other indexed fields of the record. These keywords are stored and�sorted in a separate file as SoundEX values along with the parent record�number.��  There may be more than one record associated with any one keyword but in�the event that two or more keywords create identical SoundEX values then�only one of the values will be stored as multiple equal values linked to�the same record would be superfluous.��  Also, if/when the user inputs duplicate keywords (humanly speaking)�these will be removed from the string to allow more room for other key�words and to remove confusion. (Users are generally confused enough�without further assistance;) Conversely, in the event that two or more of�the unique key words create identical SoundEX values they will remain in� the user inputted string to, once again, stave off confusion.�  eg: USER INPUT "RED, BLUE,, GREEN, GREEN, GRIN"�      RETURNed   "BLUE,GREEN,GRIN,RED"�      Three keys will be created for "BLUE", "GREEN", and "RED" as�      "GRIN" and "GREEN" create equal SoundEX values��  The series of routines, below, ass/u/me that the comma (,) is used to�parse the individual key words in the string. If you wish to use something�other than that character then you'll have to insert that value into all�instances of PARSE$ and PARSECOUNT.��  The file buffer is currently set to 512,000 bytes. If more or less is�required the instance of the value can be changed in KeyFileMove.��  Also, please note that the incoming OldKeys string is assumed to have�already been formatted!��  There is test code at the bottom of the file.�'-------------------------------------------------------------------------------�'-----                                                                     -----�'-------------------------------------------------------------------------------�fKeyFileOpen (BYVAL FileSpec AS STRING,BYVAL FileNo AS LONG) AS LONG�   FileSpec = drive:\path\filename.ext of file to open�   FileNo   = if > 0 then this number is used else FREEFILE will be called�   RETURNS: ZERO if file was opened without error ELSE ERR�� KeyFileClose ()�   Closes file, releases g_KeyFile value�� KeyFileInsert (BYVAL TheWord AS STRING, BYVAL RecNo AS LONG)� KeyFileDelete (BYVAL TheWord AS STRING, BYVAL RecNo AS LONG)�   TheWord = the word to be processed�   RecNo   = the associated record number�   NOTE: These two SUBs allow the programmer access to the data base on�         the level of the individual item.�� KeyFileUpdate (OldKeys AS STRING, NewKeys AS STRING, RecNo AS LONG)�   OldKeys = Previously formatted string of key words�   RecNo   = associated record number for these keys�   NewKeys  INCOMING: unformatted user input�            RETURNING: formatted string�   NOTE: This is the only required entry point for parent routines��fKeyFileSearch (BYVAL TheWord AS STRING, SEG RecNo() AS LONG) AS LONG�  TheWord = The word/phrase to be searched for�  RecNo() = RETURNING: a list of all record numbers that match the�                       SoundEX value for TheWord�  RETURNS: The number of elements used in RecNo() (BASE 1)��#endif�'�'-------------------------------------------------------------------------------�'-----                         START OF CODE                               -----�'-------------------------------------------------------------------------------�'�TYPE KeyWordTYPE�  RecNo   AS LONG�  SoundEX AS LONG�END TYPE��UNION KeyWordUNION�  tKey AS KeyWordTYPE�  Qkey AS QUAD�END UNION��GLOBAL g_KeyLast AS LONG�GLOBAL g_KeyFile AS LONG��DECLARE FUNCTION fKeyFileOpen     (BYVAL FileSpec AS STRING,BYVAL FileNo AS LONG) AS LONG�DECLARE FUNCTION fKeyFileSearch   (BYVAL TheWord AS STRING,SEG RecNo() AS LONG) AS LONG�DECLARE SUB       KeyFileClose    ()�DECLARE SUB       KeyFileUpdate   (BYVAL OldKeys AS STRING,SEG NewKeys AS STRING,BYVAL RecNo AS LONG)�DECLARE SUB       KeyFileInsert   (BYVAL TheWord AS STRING,BYVAL RecNo AS LONG)�DECLARE SUB       KeyFileDelete   (BYVAL TheWord AS STRING,BYVAL RecNo AS LONG)�'-------------------------------------------------------------------------------�'----------- PRIVATE ROUTINES --------------------------------------------------�'-------------------------------------------------------------------------------�DECLARE FUNCTION fKeyFileSoundEX  (SEG TheWord AS STRING) AS LONG�DECLARE FUNCTION fKeys2Array      (SEG TheKeys AS STRING,SEG Keys() AS LONG) AS LONG�DECLARE FUNCTION fKeyFileSeek     (SEG uKey AS KeyWordUNION,BYVAL Unique AS LONG) AS LONG�DECLARE SUB       KeyStringFormat (SEG TheKeys AS STRING )�DECLARE SUB       KeyFileMove     (BYVAL Offset AS LONG,BYVAL Bytes AS LONG)�'�'-------------------------------------------------------------------------------�'�FUNCTION fKeyFileOpen ( BYVAL FileSpec AS STRING, _�                        BYVAL FileNo   AS LONG    ) AS LONG��  ON ERROR GOTO Oops                                   ' set local error trap�                                                       '�  IF FileNo = 0 THEN FileNo = FREEFILE                 ' get next unused number�                                                       '�  OPEN FileSpec FOR BINARY AS #FileNo BASE = 0         ' open file�  g_KeyLast = LOF(FileNo) \ 8                          ' compute nbr of keys�                                                       '�  ExitFunction:                                        ' Exit point�    g_KeyFile = FileNo                                 '  set global file number�    EXIT FUNCTION                                      '  We're outta here�                                                       '�  Oops:                                                ' ERROR TRAP�    IF FILEATTR(FileNo,0) THEN CLOSE #FileNo           '  close opened file�    FileNo    = 0                                      '  clear globals�    g_KeyLast = 0                                      '�    FUNCTION  = ERR                                    '  RETURN ERRor code�    RESUME ExitFunction                                '  jmp to exit point�                                                       '�END FUNCTION�'�'-------------------------------------------------------------------------------�'�SUB KeyFileClose () EXPORT��  IF FILEATTR(g_KeyFile,0) THEN CLOSE g_KeyFile        ' if file is open�  g_KeyFile = 0                                        '�  g_KeyLast = 0                                        '�                                                       '�END SUB                                                '�'�'-------------------------------------------------------------------------------�'�SUB KeyFileInsert( BYVAL TheWord AS STRING, _�                   BYVAL RecNo   AS LONG    ) EXPORT��  DIM uKey    AS LOCAL KeyWordUNION                    ' working record union�  DIM  Offset AS LOCAL LONG                            ' file offset�                                                       '�  uKey.tKey.RecNo   = RecNo                            ' set union values�  uKey.tKey.SoundEX = fKeyFileSoundEX(UCASE$(TheWord)) ' create SoundEX value�  Offset = fKeyFileSeek(uKey,-1)                       ' find unique key�  IF Offset < 0 THEN                                   ' if it doesn't exist�    Offset = -Offset                                   '  reverse sign on offset�    KeyFileMove Offset, 8                              '  open a hole for key�    PUT g_KeyFile, Offset, uKey                        '  stuff the key�    INCR g_KeyLast                                     '  increase the last #�  END IF                                               '�                                                       '�END SUB�'�'-------------------------------------------------------------------------------�'�SUB KeyFileDelete ( BYVAL TheWord AS STRING, _�                    BYVAL RecNo   AS LONG    ) EXPORT��  DIM uKey    AS LOCAL KeyWordUNION                    ' working record union�  DIM  Offset AS LOCAL LONG                            ' file offset�                                                       '�  IF g_KeyLast < 1 THEN EXIT SUB                       ' oops! noting in the file�                                                       '�  uKey.tKey.RecNo   = RecNo                            ' set union values�  uKey.tKey.SoundEX = fKeyFileSoundEX(UCASE$(TheWord)) ' create SoundEX value�  Offset            = fKeyFileSeek(uKey,-1)            ' find unique key�                                                       '�  IF Offset < 0 THEN EXIT SUB                          ' not there! nothing to remove�                                                       '�  KeyFileMove Offset, -8                               ' close up the file�  DECR g_KeyLast                                       ' decrease the record count�  SEEK g_KeyFile, (g_KeyLast * 8)                      ' set EOF of file�  SETEOF g_KeyFile                                     '��END SUB�'�'-------------------------------------------------------------------------------�'�SUB KeyFileUpdate ( BYVAL OldKeys AS STRING, _�                    SEG   NewKeys AS STRING, _�                    BYVAL RecNo   AS LONG    ) EXPORT��  DIM uKey      AS KeyWordUNION                        ' record union�  DIM  N        AS LOCAL LONG                          ' new keys temp�  DIM  Ncount   AS LOCAL LONG                          ' # of individual new keys�  DIM  Nkeys(0) AS LOCAL LONG                          ' array for new keys�  DIM  O        AS LOCAL LONG                          ' old keys temp�  DIM  Ocount   AS LOCAL LONG                          ' # of old/existing keys�  DIM  Okeys(0) AS LOCAL LONG                          ' array for old keys�  DIM  Offset   AS LOCAL LONG                          ' file offset�  DIM  OldLast  AS LOCAL LONG                          ' current last key #�                                                       '�  KeyStringFormat NewKeys                              ' format the new key string�  IF OldKeys = NewKeys THEN EXIT SUB                   ' same old, same old�  uKey.tKey.RecNo = RecNo                              ' only need this once�  OldLast         = g_KeyLast                          ' current last record�                                                       '�  Ocount = fKeys2Array( OldKeys, Okeys() )             ' fill old keys array�  Ncount = fKeys2Array( NewKeys, Nkeys() )             ' fill new keys array�                                                       '�  FOR O = Ocount TO 1 STEP -1                          ' once for each old key�    IF Ncount > 0 THEN                                 '  if there are any new keys�      ARRAY SCAN Nkeys(1) FOR Ncount, = Okeys(O), TO N '   scan for match with old�      IF N > 0 THEN                                    '   if we've found a match�        ARRAY DELETE Nkeys(N)                          '    delete from new list�        DECR Ncount                                    '    decrease new count�        ITERATE                                        '    loop it�      END IF                                           '�    END IF                                             '�    IF g_KeyLast > 0 THEN                              ' this should be redundant!�      uKey.tKey.SoundEX = Okeys(O)                     '  set union SoundEX value�      Offset = fKeyFileSeek(uKey,-1)                   '  seek existing key offset�      IF Offset => 0 THEN                              '  got it!�        KeyFileMove Offset, -8                         '   close up file�        DECR g_KeyLast                                 '   decrease last record #�      END IF                                           '�    END IF                                             '�  NEXT                                                 '�                                                       '�  WHILE Ncount > 0                                     ' if any new keys left in list�    uKey.tKey.SoundEX = Nkeys(Ncount)                  '  set union SoundEX value�    Offset = fKeyFileSeek(uKey,0)                      '  seek file offset�    KeyFileMove Offset, 8                              '  open file�    PUT g_KeyFile, Offset, uKey                        '  stuff new key�    INCR g_KeyLast                                     '  increase last record #�    DECR Ncount                                        '  previous new key�  WEND                                                 '�                                                       '�  IF OldLast > g_KeyLast THEN                          ' if file is shorter then�    SEEK   #g_KeyFile, g_KeyLast * 8                   '  truncate file�    SETEOF #g_KeyFile                                  '�  END IF                                               '�                                                       '�END SUB                                                '�'�'-------------------------------------------------------------------------------�'�FUNCTION fKeyFileSearch ( BYVAL TheWord AS STRING, _�                          SEG   RecNo() AS LONG    ) EXPORT AS LONG��  DIM  Count   AS LOCAL LONG                           ' found keys count�  DIM uKey     AS LOCAL KeyWordUNION                   ' record union�  DIM  Last    AS LOCAL LONG                           ' last ubound for RecNo array�  DIM  Offset  AS LOCAL LONG                           ' file offset�  DIM  SoundEX AS LOCAL LONG                           ' sought after SoundEX value�                                                       '�  TheWord           = UCASE$(TRIM$(TheWord))           ' strip and ucase key word�  SoundEX           = fKeyFileSoundEX(TheWord)         ' set SoundEX value�  uKey.tKey.RecNo   = -1                               ' create a SoundEX record 1 less�  uKey.tKey.SoundEX = SoundEX - 1                      '           than the one we want�  Offset            = fKeyFileSeek(uKey,0)             ' find starting file offset�                                                       '�  SEEK g_KeyFile, Offset                               ' set file pointer�  FOR Offset = (Offset \ 8) TO g_KeyLast               ' loop until end of file�    GET g_KeyFile, , uKey                              '  read next record�    IF uKey.tKey.SoundEX <> SoundEX THEN EXIT FOR      '  if SoundEX values don't match�    INCR Count                                         '  bump the counter�    IF Count > Last THEN                               '  if counter > ubound of array�      Last = Last + 10                                 '   add a few new elements to array�      REDIM PRESERVE RecNo(Last)                       '   redim holding array�    END IF                                             '�    RecNo(Count) = uKey.tKey.RecNo                     '  stuff item�  NEXT                                                 '�                                                       '�  IF Count > 1 THEN ARRAY SORT RecNo(1) FOR Count      ' if there's anyhting to sort�                                                       '�  FUNCTION = Count                                     ' RETURN number of found items��END FUNCTION�'�'-------------------------------------------------------------------------------�'-------------- SUPPORTING ROUTINES --------------------------------------------�'-------------------------------------------------------------------------------�'�SUB KeyFileMove ( BYVAL Offset AS LONG, _�                  BYVAL Bytes  AS LONG  )��  DIM BytesLeft AS LOCAL LONG                          ' bytes left to be moved�  DIM Buf       AS LOCAL STRING                        ' buffer to hold bytes being moved�  DIM Chunk     AS LOCAL LONG                          ' size of current bytes being moved�  DIM L         AS LOCAL LONG                          ' temp variable�                                                       '�  L         = LOF( g_KeyFile )                         ' length of file�  BytesLeft = L - Offset                               '�                                                       '�  IF Bytes > 0 THEN                                    ' opening a space�      Offset = L                                       '�    ELSE                                               ' closing up a gap�      Offset    = Offset - Bytes                       '�      BytesLeft = BytesLeft + Bytes                    '�  END IF                                               '�                                                       '�  DO                                                   '�    Chunk = MIN( 512000, BytesLeft )                   ' size of chunk�    IF Bytes > 0 THEN Offset = Offset - Chunk          ' fix seek position�    SEEK #g_KeyFile, Offset                            ' set get position�    GET$ #g_KeyFile, Chunk, Buf                        ' take a bite�    SEEK #g_KeyFile, Offset + Bytes                    ' set put position�    PUT$ #g_KeyFile, Buf                               ' spit it out�    IF Bytes < 0 THEN Offset = Offset + Chunk          ' fix seek position�    BytesLeft = BytesLeft - Chunk                      ' decr work load�  LOOP UNTIL BytesLeft =< 0                            '��END SUB�'�'-------------------------------------------------------------------------------�'�FUNCTION fKeyFileSoundEX ( SEG TheWord AS STRING ) AS LONG��  REGISTER SndX AS LONG                                '�  REGISTER Char AS LONG                                ' character value�                                                       '�  DIM      Last    AS LOCAL LONG                       ' last character processed�  DIM      Letters AS LOCAL LONG                       '�  DIM      Vals    AS LOCAL STRING * 27                ' SndX values�  DIM      V_ptr   AS LOCAL BYTE PTR                   ' pointer to values�  DIM      W_ptr   AS LOCAL BYTE PTR                   ' pointer to incoming data�  DIM      Widx    AS LOCAL LONG                       ' index to incoming data pointer�                                                       '�  Vals    = CHR$(0,0,1,2,3,0,1,2,0,0,2,2,4,5) & _      ' SndX values from _A -> M�            CHR$(5,0,1,2,6,2,3,0,1,0,2,0,2)            '                   N -> Z�  V_ptr   = VARPTR(Vals)                               ' pointer to above�  W_ptr   = STRPTR(TheWord)                            ' set ptr to incoming string�  Letters = 9                                          ' 1 letter & 9 numbers�                                                       '�  FOR Widx = 0 TO LEN(TheWord)-1                       ' once for each letter�    Char = @W_ptr[Widx]                                '  draw off the letter�    IF Char < 65   THEN ITERATE                        '  can't be a valid letter�    Char = ( Char AND &b11111 )                        '  ucase & subtract 64�    IF Char > 26 THEN ITERATE                          '  oops! this ain't a letter either�    IF SndX <> 0 THEN                                  '�        Char = @V_ptr[Char]                            '�        IF Char = Last THEN ITERATE                    '  same as last char�        Last = Char                                    '�        IF Char = 0 THEN ITERATE                       '�        SndX = (SndX OR Char)                          '  place value into buffer�        IF Letters = 0 THEN EXIT FOR                   '  check if buffer is full�      ELSE                                             '�        SndX = Char                                    '  A = 1  Z = 26�        Last = @V_ptr[Char]                            '�    END IF                                             '�    SHIFT LEFT SndX, 3                                 '�    DECR Letters                                       '  decr buffer counter�  NEXT                                                 '�                                                       '�  IF Letters > 0 THEN                                  ' add trailing zeros�    SHIFT LEFT SndX, ( Letters * 3 )                   '�  END IF                                               '�                                                       '�  FUNCTION = SndX                                      'RETURN SOUNDEX VALUE��END FUNCTION�'�'-------------------------------------------------------------------------------�'�SUB KeyStringFormat ( SEG KeyWords AS STRING )��  DIM Count    AS LOCAL LONG                           ' # of keywords in string�  DIM Keys(25) AS LOCAL STRING                         ' individual keywords�  DIM X        AS LOCAL LONG                           ' loop counter�                                                       '�  IF LEN(KeyWords) = 0 THEN EXIT SUB                   ' nothing to do here�                                                       '�  KeyWords = UCASE$(KeyWords)                          ' convert to all uppercase�                                                       '�  Count = 1                                            ' assume at least 1 keyword�  FOR X = 1 TO PARSECOUNT(KeyWords)                    ' loop through pieces of $�    Keys(Count) = PARSE$(KeyWords,X)                   '  set new word value�    Keys(Count) = TRIM$(Keys(Count))                   '  strip any outside spaces�    IF LEN(Keys(Count)) > 0 THEN INCR Count            '  ok! we've got a word�  NEXT                                                 '�  DECR Count                                           ' back off by one�  KeyWords = ""                                        ' reset incoming/returning $�                                                       '�  IF Count = 0 THEN EXIT SUB                           ' no keywords found�                                                       '�  ARRAY SORT Keys(1) FOR Count                         '�                                                       '�  KeyWords = Keys(Count)                               ' start at the end�  DECR Count                                           '�  FOR X = Count TO 1 STEP -1                           ' rebuild KeyWords string�    IF Keys(X) <> Keys(X+1) THEN                       '  if this word not already�      KeyWords = Keys(X) & "," & KeyWords              '   in the string then add it�    END IF                                             '�  NEXT                                                 '��END SUB�'�'-------------------------------------------------------------------------------�'�FUNCTION fKeys2Array ( SEG KeyWords AS STRING, _�                       SEG Keys()   AS LONG    ) AS LONG��  DIM Count AS LOCAL LONG                              ' # of keywords in string�  DIM Temp  AS LOCAL STRING                            ' temp string�  DIM X     AS LOCAL LONG                              ' loop counter�                                                       '�  Count = PARSECOUNT(KeyWords)                         ' count the individual words�  REDIM Keys(Count)                                    ' establish SoundEX array�  FOR X = 1 TO Count                                   ' fill array�    Temp = PARSE$(KeyWords,X)                          '  get individual word�    Keys(X) = fKeyFileSoundEX(Temp)                    '  set/create SoundEX value�  NEXT                                                 '�                                                       '�  ARRAY SORT Keys(1) FOR Count, DESCEND                ' sort SoundEx values�  ARRAY SCAN Keys(1) FOR Count, = 0, TO X              ' find any zero values�  IF X > 0 THEN Count = X -1                           ' if any 0s found set new count�  IF Count = 0 THEN EXIT FUNCTION                      ' nothing left to do�                                                       '�  X = 2                                                ' remove any double values�  WHILE Count > 1                                      '�    IF Keys(X-1) = Keys(X) THEN                        '  if same SoundEx value�        ARRAY DELETE Keys(X)                           '   remove it from the array�        DECR Count                                     '   one less in the mess�      ELSE                                             '�        INCR X                                         '   next value�    END IF                                             '�    IF X > Count THEN EXIT LOOP                        '   all done�  WEND                                                 '�                                                       '�  FUNCTION = Count                                     ' RETURN number of SoundExs��END FUNCTION�'�'-------------------------------------------------------------------------------�'�FUNCTION fKeyFileSeek( SEG   uKey    AS KeyWordUNION, _�                       BYVAL  Unique AS LONG          ) AS LONG��  DIM F    AS LOCAL LONG                               ' top record #�  DIM L    AS LOCAL LONG                               ' bottom record #�  DIM M    AS LOCAL LONG                               ' middle record #�  DIM Qval AS LOCAL QUAD                               ' middle record value�                                                       '�  IF g_KeyLast = 0 THEN EXIT FUNCTION                  ' oops! nothing to do here�  F = 0                                                ' first record #�  L = g_KeyLast -1                                     ' last record #�  DO                                                   ' start search�    M = ( F + L ) \ 2                                  '  compute half way mark�    GET g_KeyFile, M*8, Qval                           '  read record�    IF M = F THEN EXIT LOOP                            '  if we've hit the mean record�    IF uKey.Qkey =< Qval THEN L = M ELSE F = M         '  compute new half of list�  LOOP                                                 '�                                                       '�  WHILE uKey.Qkey > Qval                               ' if we've not quite there yet�    INCR M                                             '  next record #�    IF M => g_KeyLast THEN EXIT LOOP                   '  oops! run out of records!�    GET g_KeyFile, M*8, Qval                           '  read record�  WEND                                                 '�  SHIFT LEFT M, 3                                      '  compute file offset�                                                       '�  IF (Unique <> 0) AND (uKey.Qkey <> Qval) THEN M = -M ' if not unique or exact match�                                                       '�  FUNCTION = M                                         ' RETURN Offset value�                                                       '�END FUNCTION�'�'-------------------------------------------------------------------------------�'------------ TEST MESS! -------------------------------------------------------�'-------------------------------------------------------------------------------�'�#IF 1�FUNCTION PBmain ()��  DIM  FileSpec AS LOCAL STRING�  DIM uKey      AS LOCAL KEYWORDUNION�  DIM  L        AS LOCAL LONG�  DIM  NewKeys  AS LOCAL STRING�  DIM  OldKeys  AS LOCAL STRING�  DIM  R(0)     AS LOCAL LONG�  DIM  RecNo    AS LOCAL LONG�  DIM  X        AS LOCAL LONG��  FileSpec = "KEYTEST.DAT"                                   ' test file�  OldKeys  = "BLACK,GREEN,ORANGE,RED"                        ' existing formatted data�  NewKeys  = "RED,GREEN,BLUE,BLACK,,GREEN,black,PURPLE ,RED" ' user input�                                                             '�  IF LEN(DIR$(FileSpec)) > 0 THEN KILL FileSpec              ' kill test file�  X = fKeyFileOpen( FileSpec, 0 )                            '�  IF X <> 0 THEN                                             '�    PRINT "ERROR"; X                                         '�    WAITKEY$                                                 '�  END IF                                                     '�                                                             '�  FOR RecNo = 1 to 4 step 1                                  ' load up some data�    IF RecNo = 3 THEN ITERATE                                '�    KeyFileUpdate ""     , OldKeys, RecNo                    '�    KeyFileUpdate OldKeys, NewKeys, RecNo                    '�  NEXT                                                       '�  KeyFileInsert "Fire-Engine Red", 3                         ' load individual stuff�  KeyFileInsert "Blue", 3                                    '�  KeyFileDelete "Blue", 2                                    ' delete one�                                                             '�  PRINT NewKeys                                              ' returned goodies�  PRINT STRING$(79,45)                                       '�  PRINT g_KeyLast                                            '�  FOR X = 0 TO g_KeyLast -1                                  '�    GET #g_KeyFile, x*8, uKey                                '�    PRINT uKey.tKey.SoundEx, uKey.tKey.RecNo,                '�    PRINT FORMAT$(uKey.Qkey,"##################")            '�  NEXT                                                       '�  PRINT STRING$(79,45)                                       '�  L = fKeyFileSearch("purple",R())                           ' find all the matches for 'GRIN'�  FOR X = 1 TO L                                             '  these will be the same as for�    PRINT R(X)                                               '  GREEN�  NEXT                                                       '�  KeyFileClose                                               '�  WAITKEY$                                                   '��END FUNCTION��#ENDIF�Don Schullian                  SOUNDEX VERSION 2              d83@DASoftVSS.com              04-11-00 (16:35)       PBCC                   228  12408    SOUNDEX2.BAS#IF 0�    ----------------------------                      PowerBASIC/cc v2.0� ---|          DASoft          |------------------------------------------�    ----------------------------         Code           DATE: 2000-04-10�    | FILE NAME   SoundEX2.bas |          by�    ----------------------------  Don Schullian, Jr.��              This code is released into the Public Domain�       ----------------------------------------------------------�        No guarantee as to the viability, accuracy, or safety of�         use of this code is implied, warranted, or guaranteed.�       ----------------------------------------------------------�                         Use at your own risk!�       ----------------------------------------------------------�                  CONTACT AUTHOR AT d83@DASoftVSS.com� -------------------------------------------------------------------------��Hi,��  There are 3 functions in this file along with a bit of test code. In any�one program you not use all of them as fSoundEXuscb is a stand alone item�and fSoundEX2str would not, particularly be required unless you wished to�display the results to the user.��  Here's what I've learned (and think I know) about SoundEX:��  1) only letters from A->Z are accepted�     a) I saw one augmentation that accepted the Spanish 'n' with the�        tone mark (as the third letter in Nina would be) that held the�        same value as the english "N"��  2) the official version created for and used by the US Census Bureau�     consists of 1 letter A-Z and 3 numbers 0->6 where the zero would�     only be used to pad a string to 4 characters.�       eg: Schullian creates a soundex of "S45" but as 4 characters are�           required a trailing zero is added to create "S450"��  3) The 4 character SoundEX can be extended up to 10 positions by�     packing the data into 5 bits for the leading letter and 3 bits�     for the following 9 numbers. This system follows exactly the�     same rules as the 'official' version but packs the values into�     bits and works on more characters. The values returned by this�     system use all 32 bits and would require a DWORD to keep�     everything in strict alphabetical order but:�     a) if the user never sees the code and your search/sort routines�        will work with negative values then a LONG INTEGER will do�        just fine�     b) you could request a 9 position SoundEX, store it in a LONG and�        not have to worry about negative values and/or force the use�        of DWORDs. (LONGs will process much faster than DWORDs)��  Ok, down below are all three functions for your review. Which you use�and how you use any of them would depend, of course, on what your program�requires. fSoundEX&& allows you to select the number of bits your�SoundEX code will require. The rule is ((Characters * 3) + 2)bits so you�can store 4 characters in a 2byte INTEGER [ 4+3 = 12 + 2 = 14] and never�exceed 32k! By adding just one more character you'll surpass the 16bit�limit of a WORD and be required to either jump into a 3byte string (yuk!)�or move into a LONG.��C'ya,��d83�--------------------------------------------------------------------------------�fSoundEX&& (TheWord$,Letters&)�  PURPOSE: Create a SoundEX representation of a given STRING�   PARMAS: TheWord$ - the STRING to be processed�           Letters& - The maximum number of soundex letters to process�                      10 (max) will fill a 32bit integer�                       4 (min) will fill an 16bit integer�  RETURNS: ( (Letters * 3) + 2 ) significant bits�     NOTE: IF Letters& =< 4 then the value will never exceed 32k�           IF Letters& = 10 then a DWORD is required to keep all values positive��fSoundEX2str$ (SndEX&&,Letters&)�  PURPOSE: Convert a SoundEX value into a humanized string�   PARAMS: SndEX&&  - The soundex value�           Letters& - The number of letters/positions in the returning string�  RETURNS: A string where the first character is a letter A -> Z followed by�           Letters-1 numbers from 0 -> 6�           EG: "S450" or "W363"�     NOTE: If the SndEX value was not created using the same number of�           Letters then the returning value may be incorrect or could even�           cause an error.��fSoundEXuscb$ (TheName$)�  PURPOSE: To create a 4 character SoundEX string that is used by the�           US Census Beurough�   PARAMS: The name to be converted/computed�  RETURNS: A 4 character SoundEX string that has a leading letter from�           A -> Z followed by 3 numbers 0 -> 6�           eg: S450  W363� -------------------------------------------------------------------------�#ENDIF��FUNCTION fSoundEX ( BYVAL TheWord AS STRING, _�                    BYVAL Letters AS LONG    ) EXPORT AS DWORD��  REGISTER SndX AS LONG                                '�  REGISTER Char AS LONG                                ' character value�                                                       '�  DIM      Last    AS LOCAL LONG                       ' last character processed�  DIM      Vals    AS LOCAL STRING * 27                ' SndX values�  DIM      V_ptr   AS LOCAL BYTE PTR                   ' pointer to values�  DIM      W_ptr   AS LOCAL BYTE PTR                   ' pointer to incoming data�  DIM      Widx    AS LOCAL LONG                       ' index to incoming data pointer�                                                       '�  Vals    = CHR$(0,0,1,2,3,0,1,2,0,0,2,2,4,5) & _      ' SndX values from _A -> M�            CHR$(5,0,1,2,6,2,3,0,1,0,2,0,2)            '                   N -> Z�  V_ptr   = VARPTR(Vals)                               ' pointer to above�  W_ptr   = STRPTR(TheWord)                            ' set ptr to incoming string�  Letters = MIN(9,Letters-1)                           ' 1 letter & n numbers�                                                       '�  FOR Widx = 0 TO LEN(TheWord)-1                       ' once for each letter�    Char = @W_ptr[Widx]                                '  draw off the letter�    IF Char < 65   THEN ITERATE                        '  can't be a valid letter�    Char = ( Char AND &b11111 )                        '  ucase & subtract 64�    IF Char > 26 THEN ITERATE                          '  oops! this ain't a letter either�    IF SndX <> 0 THEN                                  '�        Char = @V_ptr[Char]                            '�        IF Char = Last THEN ITERATE                    '  same as last char�        Last = Char                                    '�        IF Char = 0 THEN ITERATE                       '�        SndX = (SndX OR Char)                          '  place value into buffer�        IF Letters = 0 THEN EXIT FOR                   '  check if buffer is full�      ELSE                                             '�        SndX = Char                                    '  A = 1  Z = 26�        Last = @V_ptr[Char]                            '�    END IF                                             '�    SHIFT LEFT SndX, 3                                 '�    DECR Letters                                       '  decr buffer counter�  NEXT                                                 '�                                                       '�  IF Letters > 0 THEN                                  ' add trailing zeros�    SHIFT LEFT SndX, ( Letters * 3 )                   '�  END IF                                               '�                                                       '�  FUNCTION = SndX                                      'RETURN SOUNDEX VALUE��END FUNCTION�'�'-------------------------------------------------------------------------------�'�FUNCTION fSoundEX2str( BYVAL SndEx   AS DWORD, _�                       BYVAL Letters AS LONG   ) AS STRING��  DIM Temp  AS LOCAL STRING * 10                       '�  DIM T_ptr AS LOCAL BYTE PTR                          '�                                                       '�  Temp  = STRING$(10,32)                               ' pad working string�  T_ptr = VARPTR(Temp)                                 ' set pointer to above�                                                       '�  DO                                                   ' start processing SndEX�    DECR Letters                                       ' back up one posn for offset�    IF Letters > 0 THEN                                ' if not 1st letter�        @T_ptr[Letters] = ( SndEx AND &b111 ) + 48     '   set 0 -> 6�        SHIFT RIGHT SndEx, 3                           '   shift off last 3 bits�      ELSE                                             ' 1st letter�        @T_ptr = ( SndEx + 64 )                        '   set A -> Z�        EXIT LOOP                                      '�    END IF                                             '�  LOOP                                                 '�                                                       '�  FUNCTION = RTRIM$(Temp)                              ' RETURN only used portion of $��END FUNCTION�'�'-------------------------------------------------------------------------------�'�FUNCTION fSoundEXuscb ( BYVAL TheWord AS STRING ) EXPORT AS STRING��  DIM Char    AS LOCAL LONG                            ' character values�  DIM Last    AS LOCAL LONG                            ' last char processed�  DIM Letters AS LOCAL LONG                            ' letter counter�  DIM Temp    AS LOCAL STRING *  4                     ' working string�  DIM T_ptr   AS LOCAL BYTE PTR                        ' pointer to above�  DIM Vals    AS LOCAL STRING * 27                     ' SoundEX values�  DIM V_ptr   AS LOCAL BYTE PTR                        ' pointer to values�  DIM W_ptr   AS LOCAL BYTE PTR                        ' pointer to incoming data�  DIM Widx    AS LOCAL LONG                            ' index to incoming data pointer�                                                       '�           '  ABCDEFGHIJKLMNOPQRSTUVWXYZ"              ' corresponding letters�  Vals    = "001230120022455012623010202"              ' alignment byte + A -> Z�  V_ptr   = VARPTR(Vals)                               ' pointer to above�  W_ptr   = STRPTR(TheWord)                            ' set ptr to incoming string�  Temp    = "0000"                                     '�  T_ptr   = VARPTR(Temp)                               '�                                                       '�  FOR Widx = 0 TO LEN(TheWord)-1                       ' once for each letter�    Char = @W_ptr[Widx]                                '  draw off the letter�    IF Char < 65   THEN ITERATE                        '  can't be a valid letter�    Char = ( Char AND &b11111 )                        '  ucase & subtract 64�    IF Char > 90 THEN ITERATE                          '  oops! this ain't a letter either�    IF Letters > 0 THEN                                '�        Char = @V_ptr[Char]                            '�        IF Char = Last THEN ITERATE                    '  same as last char�        Last = Char                                    '�        IF Char = 48 THEN ITERATE                      '�        @T_ptr[Letters] = Char                         '  place value into buffer�        IF Letters = 3 THEN EXIT FOR                   '  check if buffer is full�      ELSE                                             '�        @T_ptr[0] = Char + 64                          '  A = 1  Z = 26�        Last = @V_ptr[Char]                            '�    END IF                                             '�    INCR Letters                                       '  decr buffer counter�  NEXT                                                 '�                                                       '�  FUNCTION = Temp                                      'RETURN SOUNDEX VALUE��END FUNCTION�'�'-------------------------------------------------------------------------------�'�FUNCTION PBmain ()��  DIM TheName AS LOCAL STRING�  DIM SoundEX AS LOCAL STRING * 4�  DIM SndEX   AS LOCAL DWORD��  SndEX = fSoundEX("schullian",4)�  PRINT FORMAT$(SndEX,",#")�  PRINT BIN$(SndEX,32)�  PRINT fSoundEXstr(SndEX,4)�  PRINT fSoundEXuscb("WOODYARD")�  PRINT fSoundEXuscb("schullian")�  WAITKEY$��END FUNCTION�Don Schullian                  LARGE PRIME NUMBER GENERATOR   d83@DASoftVSS.com              04-11-00 (16:35)       PBCC                   317  19274    PRIME.BAS   #if 0�    ----------------------------                      PowerBASIC/cc v2.0� ---|          DASoft          |------------------------------------------�    ----------------------------         Code           DATE: 2000-04-08�    | FILE NAME   PrimeGEN.bas |          by�    ----------------------------  Don Schullian, Jr.��              This code is released into the Public Domain�        ---------------------------------------------------------�         No guarentee as to the viability, accuracy, or safty of�          use of this code is implied, warrented, or guarenteed�        ---------------------------------------------------------�                         Use at your own risk!�        ---------------------------------------------------------�                  CONTACT AUTHOR AT d83@DASoftVSS.com� -------------------------------------------------------------------------��Hi,��  First of all, I'm NOT a mathematician so bare with me here.��  The code below contains ideas from, at least, three different sources plus one�or two of my own. The code is also optimized for speed over size as each clock�tick in the main loop could cost quadrillions of ticks throughout the run of�the program. And, lastly, when/if the user bails out or the program hits the�maximum number requested the next number in line to be checked will end in a�seven (7). This was done to facilitate restarting the program where it left off.��  The overall theory of this prime number generator is to test only 40% of the�existing numbers. All even numbers (except 2) are NOT primes and all numbers�ending in 5 (except 5) are not primes. Hence only those numbers ending in 1, 3,�7 or 9 can qualify. Testing only odd numbers is quite common but I've added the�double loop that also skips those numbers divisible by 5.��  Next, 1, 2, 3, and 5 are loaded and testing starts with 7. The generated file�then holds only 1/2 the difference between one prime and the following prime. This�assumes that no two prime numbers are more than 510 apart. (as both primes are odd,�the difference will always be even) So far, with all my testing this condition has�not even been neared and as I've gone past 40M primes I'd guess that it is safe.�There is an error test for this condition and the program will end if it is exceeded.��  There are 2 constants (below) that manage the buffer sizes:��%BufSize determines the size of the 'testing primes'. 4k was sufficient to test�the first 40M primes, with 100 values not used.��%HoldSize determines how many new primes are found before the buffer is flushed�to the file. I'd suggest that you keep this value an increment of 4k to maximize�the speed which it will transfer the data.��  If the highest prime you require will fit into a LONG INTEGER then change all�the QUADs to LONGs. (40Mth prime only in the range of 800M) This holds true also�for DWORDs (4B). Either of these simple changes will speed the program up by�quite a bit.��  If you plan on running this program all night then make sure that you turn off�ALL screen savers, power savers, etc. or you'll end up with a program sitting around�doing nothing!��The sub PrimeView is incomplete so you can fill in the pertinent print command(s)�that you will require. Remember, if you go to disk then make sure you've got some�space available! 40M primes printed out in text will require over 760M of file space�and reams of paper!��#endif�'--------------------------------------------------'�'          PRIME NUMBER GENERATOR                  '�'--------------------------------------------------'�%BufSize        =   4096                           '  4k�%HoldSize       =  32768                           ' 32k�%DisplayReports = -1                               '�'--------------------------------------------------'�'                                                  '�'--------------------------------------------------'�DECLARE SUB PrimeGen  (BYVAL F AS STRING,BYVAL N AS QUAD,BYVAL S AS LONG)�DECLARE SUB PrimeView (BYVAL F AS STRING)�'--------------------------------------------------'�'                                                  '�'--------------------------------------------------'�FUNCTION PBmain ()                                 '�                                                   '�  DIM MaxNbr AS LOCAL QUAD                         '�                                                   '�  CONSOLE SCREEN 25, 80                            '�  CURSOR OFF                                       '�                                                   '�  MaxNbr = &h7FFFFFFFFFFFFFFF                      ' 4+ quintillian is max�                                                   '�  PrimeGen "TEST.DAT", MaxNbr, 0                   '�                                                   '�END FUNCTION                                       '�'--------------------------------------------------'�'                                                  '�'--------------------------------------------------'�SUB PrimeGen ( BYVAL FileSpec AS STRING, _�               BYVAL MaxNbr   AS QUAD  , _�               BYVAL Restart  AS LONG    )��  DIM B             AS LOCAL LONG                  ' loop counter�  DIM Bdata         AS LOCAL STRING * %BufSize     ' temporary data buffer�  DIM Buf(%BufSize) AS LOCAL DWORD                 ' working buffer for primes�  DIM Boff          AS LOCAL LONG                  ' working buffer loop counter�  DIM B_ptr         AS LOCAL BYTE PTR              ' pointer to temp buffer�  DIM Count         AS LOCAL QUAD                  ' found/saved prime counter�  DIM D             AS LOCAL STRING                ' display string�  DIM Etime         AS LOCAL SINGLE                ' elapsed time storage�  DIM Hold          AS LOCAL STRING * %HoldSize    ' found prime # storage�  DIM H_ptr         AS LOCAL BYTE PTR              ' pointer to above�  DIM Hlast         AS LOCAL LONG                  ' %HoldSize -1�  DIM Hoff          AS LOCAL LONG                  ' offset for H_ptr�  DIM LastPrime     AS LOCAL QUAD                  ' previously found prime number�  DIM N             AS LOCAL QUAD                  ' working number loop counter�  DIM Nbr           AS LOCAL QUAD                  ' sub loop working number�  DIM S             AS LOCAL DWORD                 ' sqr value of working number�  DIM Start         AS LOCAL QUAD                  ' 1st number to start search (7 is default)�  DIM Ok            AS LOCAL LONG                  ' prime found flag�  DIM X             AS LOCAL LONG                  ' junk variable for testing, etc.�                                                   '�  B_ptr     = VARPTR(Bdata)                        ' working buffer pointer�  H_ptr     = VARPTR(Hold)                         ' holding buffer for primes�  Start     = 7                                    '�  LastPrime = 5                                    ' last 'found' prime number�                                                   '�  IF Restart = 0 THEN                              '�    IF LEN(DIR$(FileSpec)) > 0 THEN KILL FileSpec  ' clear the existing file�    OPEN FileSpec FOR BINARY AS #1 BASE=0          ' open new file�  ELSE                                             '�    OPEN FileSpec FOR BINARY AS #1 BASE=0          ' open existing file�    GET$ #1, 4, D                                  ' read signature characters�    N = LOF(1) - 4                                 ' get length of file�    IF (N < 0 ) OR ( D <> CHR$(0,0,0,1) ) THEN     ' test if our file or not�      CLOSE #1                                     '  no... it isn't�      PRINT FileSpec; "isn't one of my files"      '  print warning message�      WAITKEY$                                     '  wait for a keypress�      EXIT SUB                                     '  exit program�    END IF                                         '�    WHILE N > 0                                    ' while data in file�      Nbr = MIN(N,%HoldSize)                       '  compute next chunk size�      N   = N - Nbr                                '  decrease bytes left in file�      GET$ #1, Nbr, Hold                           '  read chunk into buffer�      FOR B = 0 TO Nbr-1                           '  read each byte of buffer�        LastPrime = LastPrime + ( 2 * @H_ptr[B] )  '   compute next prime number�      NEXT                                         '�    WEND                                           '�    Start = LastPrime                              ' the next starting prime will end in a 7�    DO                                             ' so we search it out�      Start = Start + 2                            '�    LOOP UNTIL (Start MOD 10) <> 7                 '�  END IF                                           '�                                                   '�  Buf(1)  =  3                                     ' we'll start here�  Boff    =  1                                     ' working buffer offset�  Ok      = -1                                     ' prime found flag�                                                   '�  FOR N = 7 TO &h7FFFFFFFFFFFFFFF STEP 10          ' create working primes�    FOR Nbr = N TO (N + 6) STEP 2                  '  7, 9, 11, 13 skip numbers divisible by 5�      S = SQR(Nbr)                                 '  get sqr of N s�      FOR B = 1 TO Boff                            '  check previous primes against N�        IF Buf(B) > S THEN EXIT FOR                '   this prime > SQR(N) so we're done�        IF (Nbr MOD Buf(B)) = 0 THEN               '   this N divides equally by Prime(B)�          Ok = 0                                   '    turn off  'found' flag�          EXIT FOR                                 '    bail out of testing loop�        END IF                                     '�      NEXT                                         '�      IF Ok = 0 THEN                               '�          Ok = -1                                  '  This ain't a prime�        ELSE                                       '�          INCR Boff                                '   set last found prime flag�          Buf(Boff) = Nbr                          '   store found value in array�          IF Boff = %BufSize THEN EXIT, EXIT       '   the buffer is full�      END IF                                       '�    NEXT                                           '�  NEXT                                             '�                                                   '�  Count = SEEK(1)                                  '�  Hold  = CHR$(0,0,0,1)                            ' 1,2,3,5�  Hoff  =  3                                       ' hold buffer offset�  Hlast = %HoldSize - 4                            ' last hold buffer offset�  Ok    = -1                                       ' prime found flag�  Boff  =  3                                       ' working prime buffer offset for file input�                                                   '�  Etime = TIMER                                    ' start the timer�                                                   '�  FOR N = Start TO MaxNbr STEP 10                  ' This can be one HUMUMGUS! number�    FOR Nbr = N TO (N + 6) STEP 2                  '  7, 9, 11, 13 skip numbers divisible by 5�      S = SQR(Nbr)                                 '  get sqr of N s�      DO                                           '�        FOR B = 1 TO %BufSize                      '  check previous primes against N�          IF Buf(B) > S THEN EXIT, EXIT            '   this prime > SQR(N) so we're done�          IF (Nbr MOD Buf(B)) = 0 THEN             '   this N divides equally by Prime(B)�            Ok = 0                                 '    turn off 'found' flag�            EXIT, EXIT                             '    bail out of testing loop�          END IF                                   '�        NEXT                                       '�        Boff   = Boff + %BufSize                   '  we've run out of buffered primes�        Buf(0) = Buf(%BufSize)                     '  set last known prime�        GET #1, Boff, Bdata                        '  load in data�        FOR B = 0 TO %BufSize -1                   '  compute new prime set�          Buf(B+1) = Buf(B) + (@B_ptr[B] * 2)      '�        NEXT                                       '�      LOOP                                         '�                                                   '�      IF Boff > 3 THEN                             '  if we've loaded a new set of primes�        Buf(1) = 3                                 '   back up to 1st set of primes�        Buf(2) = 7                                 '   notice that 5 is skipped�        GET #1, 4, Bdata                           '   load 1st %BufSize primes�        FOR B = 2 TO %BufSize -1                   '   reset buffer values�          Buf(B+1) = Buf(B) + (@B_ptr[B] * 2)      '�        NEXT                                       '�        SEEK #1, Count                             '   replace file pointer to end�        Boff = 3                                   '   reset flag�      END IF                                       '�                                                   '�      IF Ok = 0 THEN                               '  no, this number isn't a prime�        Ok = -1                                    '�        ITERATE                                    '�      END IF                                       '�                                                   '�      Ok = (Nbr - LastPrime)                       ' difference between last 2 primes�      IF Ok > 510 THEN                             ' oops! Houston, we have a problem!�        PRINT "Difference Overflow at"; Nbr        '�        EXIT, EXIT                                 '�      END IF                                       '�      INCR Hoff                                    '�      SHIFT RIGHT Ok, 1                            ' \ difference by 2�      LastPrime    = Nbr                           ' set new last prime found�      @H_ptr[Hoff] = Ok                            ' store difference�    NEXT                                           '�                                                   '�    IF Hoff => Hlast THEN                          ' if hold buffer is full, write to disk�      INCR Hoff                                    ' this is outside the Nbr loop to make�      PUT$ #1, LEFT$(Hold, Hoff)                   '  restarting easier to compute�      Count = Count + Hoff                         '�      Hoff  = -1                                   '�      IF INSTAT THEN                               ' if keyboard action�        IF INKEY$ = CHR$(27) THEN EXIT FOR         '  if such action was <ESC>�      END IF                                       '�      #if %DisplayReports                          '�        LOCATE 1, 1                                '�        PRINT FORMAT$(Count, ",# Primes in");      '�        PRINT FORMAT$(Nbr  ," ,# Nmbrs at ");      '�        PRINT LEFT$(TIME$,5);                      '�      #endif                                       '�    END IF                                         '�  NEXT                                             '�                                                   '�  IF Hoff > -1 THEN                                '�    INCR Hoff                                      ' clear out remaining primes in Hold buffer�    PUT$ #1,  LEFT$(Hold,Hoff)                     '�    Count = SEEK(1)                                ' prime count�  END IF                                           '�  SETEOF 1                                         '�  CLOSE #1                                         '�  '------------------------------------------------'�  '------------------------------------------------'END OF FUNCTIONAL PORTION OF CODE�  '------------------------------------------------'�  Etime = TIMER - Etime                            '�  IF Etime < 0 THEN Etime = Etime + 86400          '�  LOCATE 1, 1                                      '�  PRINT FORMAT$(Count, ",# Primes in");            '�  PRINT FORMAT$(Nbr  ," ,# Numbers at ");          '�  PRINT LEFT$(TIME$,5);                            '�  PRINT                                            '�  PRINT FORMAT$(Etime,"ELAPSED TIME ,#.####sec")   '�  INPUT FLUSH                                      '�  WAITKEY$                                         '�                                                   '�END SUB                                            '�'�'-------------------------------------------------------------------------------�'�SUB PrimeView ( BYVAL FileSpec AS STRING )��  DIM Bytes          AS LOCAL QUAD                 '�  DIM D              AS LOCAL STRING               ' display string�  DIM Hold           AS LOCAL STRING * %HoldSize   ' found prime # stroage�  DIM H_ptr          AS LOCAL BYTE PTR             '�  DIM Hlast          AS LOCAL LONG                 '�  DIM Hoff           AS LOCAL LONG                 '�  DIM LastPrime      AS LOCAL QUAD                 '�                                                   '�  FileSpec = "TEST2.DAT"                           '�  H_ptr = VARPTR(Hold)                             '�                                                   '�  IF LEN(DIR$(FileSpec)) = 0 THEN                  '�    PRINT FileSpec; " has not been found."         '�    WAITKEY$                                       '�    EXIT SUB                                       '�  END IF                                           '�                                                   '�  OPEN FileSpec$ FOR BINARY AS #1                  '�    GET$ #1, 4, D                                  '�    IF D <> CHR$(0,0,0,1) THEN                     '�      CLOSE #1                                     '�      PRINT FileSpec; " is not our file."          '�      WAITKEY$                                     '�      EXIT SUB                                     '�    END IF                                         '�    SEEK #1, 4                                     '�    Bytes     = LOF(1) - 3                         '�    LastPrime = 3                                  '�  WHILE Bytes > 0                                  '�    Hlast = MIN(%HoldSize,Bytes)                   '�    GET$ #1, Hlast, Hold                           '�    FOR Hoff = 0 TO Hlast -1                       '�      LastPrime = LastPrime + ( @H_ptr[Hoff] * 2 ) '�      ' put print statement here                   '�    NEXT                                           '�    Bytes = Bytes - Hlast                          '�  WEND                                             '�  PRINT                                            '�  PRINT FORMAT$(LOF(1),   "COUNT: ,#")             '�  PRINT FORMAT$(LastPrime," LAST: ,#")             '�  CLOSE #1                                         '�  WAITKEY$                                         '�                                                   '�END SUB�Jerry Fielden                  COPY TEXT SCREEN FOR PBCC      fielden@pldi.net               04-16-00 (20:49)       PBCC                   190  7430     CCTXTGET.BAS  '----------------------------------------------------------�  '  Author: Jerry Fielden                  Date: 2000      |�  '                                                         |�  '---------------------------------------------------------- �  ' These SUBS are for PBCC. They copy Text screens and     |�  ' put them back in same or different locations with its   |�  ' original colors                                         |�  '----------------------------------------------------------��DECLARE SUB TextPutz (R1&, C1&, R2&, C2&, Area$(), TxClr$())�DECLARE SUB TextGetz (R1&, C1&, R2&, C2&, Area$(), TxClr$())�DECLARE SUB MakeBox()�DECLARE SUB LoadFmFile (Area$(), TxClr$(), TotalChar&, FileNames$)�DECLARE SUB SaveToFile (Area$(), TxClr$(), TotalChar&, FileNames$)��FUNCTION PBMAIN()��� DIM TxClr$(2000) : DIM  Area$(2000)�� MakeBox '.....................Call the box maker� SLEEP 500�� R1& = 1  '......................Starting row� C1& = 1  '......................Starting column� r2& = 6  '......................Ending row� c2& = 16  '.....................Ending column�� TextGetz R1&, C1&, R2&, C2&, Area$(),TxClr$()  'put it in arrays�� TextPutz 1, 34, 6, 49, Area$(), TxClr$()  'put it on the screen� SLEEP 500��'--------------- Put it into a file and load it back --------------�� FileNames$ = "Area96.BNY"                              ' Give it a name� TotalChar& = 96                                        ' Chars in area� SaveToFile Area$(), TxClr$(), TotalChar&, FileNames$   ' Save it� RESET Area$() : RESET TxClr$()'..........................Clear Arrays� LoadFmFile Area$(), TxClr$(), TotalChar&, FileNames$   ' Load it back���'---------------------- Paste it at the bottom of screen ---------� TextPutz 20, 34, 25, 49, Area$(), TxClr$()� SLEEP 500��'-------------------- Move it around ----------------� C1& = 1 : c2& = 16� FOR R1& = 1 TO 24 STEP 6�     r2& = r1& + 5�     TextPutz R1&, C1&, R2&, C2&, Area$(), TxClr$()�     C1& = C1& + 17�     c2& = c2& + 17�      SLEEP 500� NEXT R1&�� SLEEP 2000��� '--- Copying Full Screen, saving it in a file and loading it back�� TextGetz 1, 1, 25, 80, Area$(),TxClr$()                ' Copy full screen� FileNames$ = "Full2080.BNY"                            ' Give it a name� TotalChar& = 2000                                      ' Chars in screen� SaveToFile Area$(), TxClr$(), TotalChar&, FileNames$   ' Save it� COLOR 7, 0� RESET Area$() : RESET TxClr$() : CLS                  'Clear Arrays & screen� LOCATE 12, 1� PRINT "            Loading Full Screen from File and here it is "� SLEEP 3000� LoadFmFile Area$(), TxClr$(), TotalChar&, FileNames$   ' Load it back� TextPutz 1, 1, 25, 80, Area$(), TxClr$()               ' Put it on Screen� SLEEP 5000� COLOR 7, 0� CLS� KILL "Full2080.BNY"� KILL "AREA96.bny" '.........Get rid of temp files��END FUNCTION��  '--------------------------------------------------------------------�  ' TextGetz will copy any portion of the screen, even full |�  ' screen into Arrays                                      |�  '----------------------------------------------------------��  SUB TextGetz (R1&, C1&, R2&, C2&, Area$(), TxClr$())�     row& = R1&: col& = c1&�     RESET Area$() : RESET TxClr$()'....Clear from last time�     Wide& = C2& - C1& + 1'.............get columns wide�     Tall& = R2& - R1&'.................get rows tall�     FOR x& = 1 TO Tall& + 1�        FOR y& = 1 TO Wide&�           INCR nbr&�           TxClr$(nbr&) = CHR$(SCREENATTR(row&, col&))'..Read in color�           Area$(nbr&) = CHR$(SCREEN(row&, col&))'.......Read in a char.�           INCR Col&'............................Setup to do another char.�        NEXT y&�        col& = c1&'............................Setup column for next row�        INCR Row&'.................................Setup to do next row�     NEXT x&�  END SUB���  '---------------------------------------------------------------------�  ' TextPutz will put screen portions back in different       |�  ' locations if needed. Portions can be obtained by using    |�  ' SUBs, TextGetz or LoadFmFile. TextPutz uses PCOPY AND     |�  ' PAGE to speed up for standard SCREEN modes Printing       |�  '------------------------------------------------------------��  SUB TextPutz (R1&, C1&, R2&, C2&, Area$(), TxClr$())�    Col& = C1& : Row& = R1&          ' Get start column & row�    Wide& = C2& - C1& + 1            ' How wide is it�    Tall& = R2& - R1&                ' How tall is it�    PCOPY 1, 2 : PAGE 2, 1           '�    FOR x& = 1 TO Tall& + 1          ' Do the rows�      FOR y& = 1 TO wide&            ' Do the columns�        INCR nbr&�        ForGnd& = ASC(TxClr$(nbr&)) MOD 16&  'Get Forground color�        BackGnd& = ASC(TxClr$(nbr&)) \ 16&   'Get Background color�        COLOR ForGnd&, BackGnd&              'Change the colors�        LOCATE row&, Col&�        PRINT Area$(nbr&);                  ' Print a charecter�        INCR col&                           ' Moving to next column�      NEXT y&�      col& = c1& : INCR row&          ' Get start column & next row�    NEXT x&�    PCOPY 2, 1 : PAGE 1, 1            ' Make it visable�  END SUB������'----------------------------------------------------------------------�' SaveToFile saves Full Screen or portions that    |�' was acquired by TextGetz to a binary file which  |�' is also compatible with PBDOS POKE$ statements   |�'---------------------------------------------------��SUB SaveToFile (Area$(), TxClr$(), TotalChar&, FileNames$)� OPEN FileNames$ FOR BINARY AS #1'....Put it in a file�   FOR x& = 1 TO TotalChar&�     PUT$ #1, Area$(x&)'...........Save 1 char of area�     PUT$ #1, TxClr$(x&)'..........Save it's colors�   NEXT x&              '..........Do it again� CLOSE #1�END SUB���'---------------------------------------------------------------------�' LoadFmFile will Load a binary file into ARRAYs       |�' that can be used BY TextPutz to put on the screen.   |�' The file has to have alternating string charecters   |�' that represents color attributes like those that DOS |�' PB POKE$ uses.                                       |�'-------------------------------------------------------�� SUB LoadFmFile (Area$(), TxClr$(), TotalChar&, FileNames$)�  OPEN FileNames$ FOR BINARY AS #1�    FOR x& = 1 TO TotalChar&�      GET$ #1, 1, Area$(x&)'...........get 1 char�      GET$ #1, 1, TxClr$(x&)'..........get 1 color attribute�    NEXT x&'...........................Go Do it again�  CLOSE #1� END SUB��'----------------------------------------------------------�� SUB MakeBox()�  PCOPY 1, 2 : PAGE 2, 1�  COLOR 1, 11�  FOR r& = 1 TO 25                    'fill screen with chars .�    FOR c& = 1 TO 80�        PRINT CHR$(176);�    NEXT c&�  NEXT r&��   COLOR 14, 1 : LOCATE 1, 1                               'make a box�   PRINT CHR$(201, 205, 205, 205, 205, 205, 205, 205, 205, _�              205, 205, 205, 205, 205, 205, 187)�   PRINT CHR$(186) + "  This is an  " + CHR$(186)�   PRINT CHR$(186) + "  Example of  " + CHR$(186)�   COLOR 11, 4�   PRINT CHR$(186) + " Screen parts " + CHR$(186)�   PRINT CHR$(186) + " Copy & Save  " + CHR$(186)�   PRINT CHR$(200, 205, 205, 205, 205, 205, 205, 205, 205, _�              205, 205, 205, 205, 205, 205, 188)�   PCOPY 2, 1 : PAGE 1, 1� END SUB�Don Schullian                  KEEP MASKED CHARACTERS         d83@DASoftVSS.com              06-26-00 (07:45)       PBCC                   52   1748     KEEP.BAS    $IF 0�    ----------------------------                      PowerBASIC/cc v2.0� ---|          DASoft          |------------------------------------------�    ----------------------------    Copyright 2000      DATE: 2000-02-02�    | FILE NAME   Keep    .bas |          by�    | DIRECTORY   NBcc         |  Don Schullian, Jr.�    ----------------------------�   A license is hereby granted to the holder to use this source code in�   any program, commercial or otherwise,  without receiving the express�   permission of the copyright holder and without paying any royalties.� -------------------------------------------------------------------------�  PURPOSE: Retain only the characters from Text$ that are found in Mask$�   PARAMS: Text$ the working text�           Mask$ the list of characters to be kept�  RETURNS: string containing only the characters found in Mask$�     NOTE:� -------------------------------------------------------------------------�$ENDIF����FUNCTION fKeep ( BYVAL Text AS STRING, _�                 BYVAL Mask AS STRING  ) EXPORT AS STRING��  DIM Char  AS LOCAL BYTE�  DIM M_ptr AS LOCAL BYTE PTR�  DIM Mlen  AS LOCAL LONG�  DIM Moff  AS LOCAL LONG�  DIM Noff  AS LOCAL LONG�  DIM T_ptr AS LOCAL BYTE PTR�  DIM Tlen  AS LOCAL LONG�  DIM Toff  AS LOCAL LONG��  Mlen  = LEN(Mask) - 1 : IF Mlen < 0 THEN EXIT FUNCTION�  Tlen  = LEN(Text) - 1 : IF Tlen < 0 THEN EXIT FUNCTION�  M_ptr = STRPTR(Mask)�  T_ptr = STRPTR(Text)��  FOR Toff = 0 TO Tlen�    Char = @T_ptr[Toff]�    FOR Moff = Mlen TO 0 STEP -1�      IF Char = @M_ptr[Moff] THEN�        @T_ptr[Noff] = Char�        INCR Noff�        EXIT FOR�      END IF�    NEXT�  NEXT��  FUNCTION = LEFT$(Text,Noff)��END FUNCTION�Jerry Fielden                  BSAVE AND BLOAD FOR PBCC       fielden@pldi.com               07-01-00 (20:47)       PBCC                   136  5240     BSAVE.BAS   Coded by Jerry Fielden�Public Domain���I made a stab at writting some BSAVE and BLOAD type routines�for PBCC. Run the program to see how long it takes for different�screen modes..��Most Console Screen NON Standard modes I've tried worked properly�except 50x79 and only sometimes. I haven't tried them all yet.�All Standard modes seems to work well.��You are welcome to use the routines at your own risk.��� '-------------------------------------------------------------------� ' BSAVEs Copies the current screen to a file. It can be any screen� ' mode size, 50x80, 70x80, 20x20, etc. The number of Screen rows is� ' passed through the lRows Variable and the number of columns is� ' passed through the lColumns Variable. The Global Variables and� ' Global Arrays are used by both BLOADs and BSAVEs, they have to be� ' included in your code.� '� ' BLOADs will copy the screen from the file back to the Screen.� ' As with BSAVEs, you'll need to pass the Console Screen Size through� ' the lRows and lColumns variables.��� DECLARE SUB BSAVEs (FileNames$)� DECLARE SUB BLOADs (FileNames$)� DECLARE SUB MakeBox ()� FUNCTION PBMAIN�     DIM lRows AS GLOBAL LONG, lColumns AS GLOBAL LONG�     LOCATE 10, 1�     LINE INPUT "Enter the Screen Mode, 25x80, 26x75, etc. " Mode$�     lRows = VAL(LEFT$(Mode$, 2))     ' Get number of rows�     lColumns = VAL(RIGHT$(Mode$, 2)) ' Get number of columns�     Filenames$ = "Screens.bny"��     CONSOLE SCREEN lRows, lColumns   'Setting the Screen size��     DIM Colors(0 TO lRows*lColumns-1) AS GLOBAL LONG  'Arrays being�     DIM Area(0 TO lRows*lColumns-1) AS GLOBAL LONG    'pointed at�     MakeBox                                           ' Fill up the SCREEN��     starttime$ = FORMAT$(TIMER, "#.###")              'Time the routines�     BSAVEs(FileNames$)                                ' Save screen to file�     RESET Colors() : RESET Area()                     ' Clear the Arrays�     CLS                                               ' Clear the screen�     BLOADs (FileNames$)                               ' Put the screen back�     endtime$ = FORMAT$(TIMER, "#.###")                'How long did it take�     LOCATE 1, 1 : COLOR 0, 11�     PRINT "It took "FORMAT$((VAL(endtime$)-VAL(starttime$)), "#.###")" Seconds"��     SLEEP 7000�     KILL FileNames$�� END FUNCTION��'----------------------------------------------------------------------�' BSAVE Replacement for PBCC, it should do Most Console screen modes,  |�'----------------------------------------------------------------------��SUB BSAVEs (FileNames$)�  DIM ColorAddr AS LONG PTR, AreaAddr AS LONG PTR�  DIM nbr AS LONG, row AS LONG, col AS LONG�  ColorAddr = VARPTR(Colors(0))�  AreaAddr = VARPTR(Area(0))�  FOR row = 1 TO lRows�     FOR col = 1 TO lColumns�        @ColorAddr[nbr] = SCREENATTR(row, col)    'Put color into array�        @AreaAddr[nbr] = SCREEN(row, col)         'Put Character into Array�        INCR nbr�     NEXT col�  NEXT row�  OPEN FileNames$ FOR BINARY AS #1   '..........Put it in a file�    FOR x& = 0 TO lColumns*lRows-1�      PUT$ #1, CHR$(@AreaAddr[x&])   '..........Save a Character�      PUT$ #1, CHR$(@ColorAddr[x&])  '..........Save it's colors�    NEXT x&                          '..........Go do it again�   CLOSE #1�END SUB��'---------------------------------------------------------------�' BLOAD Replacement for PBCC, it should do most screen modes ?  |�'---------------------------------------------------------------�� SUB BLOADs (FileNames$)�   DIM ColorAddr AS LONG PTR, AreaAddr AS LONG PTR�   DIM nbr AS LONG, sColour AS STRING, sChar AS STRING�   DIM row AS LONG, col AS LONG�   ColorAddr = VARPTR(Colors(0))     ' Pointers for Arrays DIMed in Main�   AreaAddr = VARPTR(Area(0))�   OPEN FileNames$ FOR BINARY AS #1�      FOR nbr = 0 TO lColumns*lRows-1   '�       GET$ #1, 1, sChar : @AreaAddr [nbr] = ASC(sChar)�       GET$ #1, 1, sColour : @ColorAddr[nbr] = ASC(sColour)�      NEXT nbr�   CLOSE #1�   nbr=0�   PCOPY 1,2 : PAGE 2, 1�   FOR row = 1 TO lRows�      FOR col = 1 TO lColumns�         LOCATE row, col�         ForGnd& = @ColorAddr[nbr] MOD 16&�         BackGnd& = @ColorAddr[nbr] \ 16&�         COLOR ForGnd&, BackGnd&�         PRINT CHR$(@AreaAddr[nbr]);�         INCR nbr�      NEXT col�    NEXT row�    PCOPY 2, 1 : PAGE 1, 1� END SUB����� SUB MakeBox()� PCOPY 1, 2 : PAGE 2, 1�   COLOR 1, 11�   FOR x& = 1 TO lColumns*lRows�     PRINT CHR$(176);                              'Fill up screen�   NEXT x&�  SLEEP 500�   COLOR 14, 1 : LOCATE 8, 30                      'make a box�   PRINT CHR$(201, 205, 205, 205, 205, 205, 205, 205, 205, _�              205, 205, 205, 205, 205, 205, 205, 187)�   LOCATE 9, 30 :PRINT CHR$(186) + "  This is one  " + CHR$(186)�   LOCATE 10, 30 :PRINT CHR$(186) + "  Example of   " + CHR$(186)�   COLOR 11, 4�   LOCATE 11, 30 :PRINT CHR$(186) + " Bsaves and    " + CHR$(186)�   LOCATE 12, 30 :PRINT CHR$(186) + " Bloads        " + CHR$(186)�   LOCATE 13, 30 :PRINT CHR$(200, 205, 205, 205, 205, 205, 205, 205, 205, _�              205, 205, 205, 205, 205, 205, 205, 188)�    PCOPY 2, 1 : PAGE 1, 1� END SUB�Don Schullian                  CONVERT NUMBERS INTO WORDS     d83@DASoftVSS.com              10-14-00 (07:43)       PBCC                   83   4222     V2WRDCC.BAS '    ----------------------------                         PowerBASICcc v2�' ---|          DASoft          |------------------------------------------�'    ----------------------------    Public Domain       DATE: 2000-10-14�'    | FILE NAME   Val2Wrds.bas |       code by�'    | DIRECTORY                |  Don Schullian, Jr.�'    ----------------------------�'  PURPOSE: convert numbers into words for check printing, etc.�'   PARAMS: Number# incoming - any valid number�'  RETURNS: the number in text�'           eg: fValue2Words$ ( 100.10 ) returns�'              "ONE HUNDRED DOLLARS AND 10 CENTS"�'   NOTE: the function is not set-up to handle negative numbers as they�'          would not appear on a check�' -------------------------------------------------------------------------��DECLARE FUNCTION fValue2Words (BYVAL Number AS DOUBLE) AS STRING��FUNCTION fValue2Words ( BYVAL Number AS DOUBLE ) EXPORT AS STRING��  DIM Cma  AS LOCAL STRING�  DIM I    AS LOCAL LONG�  DIM Last AS LOCAL LONG�  DIM Nbr  AS LOCAL STRING�  DIM Pce  AS LOCAL LONG�  DIM Temp AS LOCAL STRING�  DIM V    AS LOCAL LONG��  Nbr  = FORMAT$( Number, "###############,.##" )         ' a number to work with�  I    = LEN(Nbr) - 2                                     ' decimal location�  IF ASC(Nbr,I) = 44 THEN Cma = "." ELSE Cma = ","        ' if decimal is a "." then.....�  Last = PARSECOUNT( Nbr, Cma )                           ' # of pieces�  '-------------------------------------------------------'�  FOR Pce = 1 TO Last                                     ' from left to right�    V = VAL( PARSE$(Nbr, Cma, Pce) )                      ' get the 000�    IF V = 0 THEN ITERATE                                 ' nada!�    IF V > 99 THEN                                        ' hundreds position�      I = ( V  \  100 )                                   '   # of hundreds�      V = ( V MOD 100 )                                   '   > 100�      Temp = Temp & READ$(I) & READ$(33)                  '   add words�    END IF                                                '�    IF ( V > 10 ) AND ( V < 20 ) THEN                     ' teens�        Temp = Temp & READ$(V)                            '   add words�      ELSEIF V > 0 THEN                                   ' anything left?�        IF V > 9 THEN                                     ' tens�          I = ( V  \  10 )                                '   # of tens - 1�          V = ( V MOD 10 )                                '   strip tens�          Temp = Temp & READ$(I+19)                       '   add words�        END IF                                            '�        IF V > 0 THEN Temp = Temp & READ$(V)              ' ones�    END IF                                                '�    IF Pce = Last THEN EXIT FOR                           ' all done�    Temp = Temp & READ$(Last - Pce + 28)                  ' thousands/mills/etc�  NEXT                                                    '�  '-------------------------------------------------------'�  IF LEN(Temp) = 0 THEN Temp = READ$(36)                  ' no ones!�  Temp = Temp & READ$(34) & RIGHT$(Nbr,2) & READ$(35)     ' add decimals�  '-------------------------------------------------------'-----------------------�  FUNCTION = Temp                                         ' RETURN STRING�                                                          '-----------------------�  DATA "ONE ", "TWO ", "THREE ", "FOUR ", "FIVE ", "SIX " '�  DATA "SEVEN ", "EIGHT ", "NINE ", "", "ELEVEN "         '�  DATA "TWELVE ", "THIRTEEN ", "FOURTEEN ", "FIFTEEN "    '�  DATA "SIXTEEN ", "SEVENTEEN ", "EIGHTEEN ", "NINETEEN " '�  DATA "TEN ", "TWENTY ", "THIRTY ", "FORTY ", "FIFTY "   '�  DATA "SIXTY ", "SEVENTY ", "EIGHTY ", "NINETY "         '�  DATA "THOUSAND ", "MILLION ", "BILLION ", "TRILLION "   '�  DATA "HUNDRED ", "DOLLARS AND ", " CENTS", "00 "        '��END FUNCTION�'�'---------------------------------------------------------------------------------�'�FUNCTION PBmain ()��  PRINT fValue2Words(32421009.34)�  PRINT�  PRINT fValue2Words(900132924462342.00)�  PRINT�  PRINT fValue2Words(123.10)��  WAITKEY$��END FUNCTION�Jerry Fielden                  Drop-down menu in PBCC                                        07-01-01 (  :  )       PBCC                   462  19767    conamenu.bas'This is a simple Drop Down Menu coded with PBCC. No APIs  used.�'Only 9 Drops and 9 Selections per Drop is possible with this menu.��'Public Domain�'Author: Jerry Fielden��DECLARE SUB GetSelection (RRow&, SelectNr&, DropNr&, Keynumber&, _�                          Lcol&, Rcol&, CCol&)�DECLARE SUB fillscreen()�DECLARE SUB GetKey (Keynumber&, char$, Rgt&, Lft&, RRow&, CCol&)�DECLARE SUB DropDownMenu(MenuCode&)�DECLARE SUB Exits()�DECLARE SUB MenuBar()�DECLARE SUB Drop(Dropnr&, nos&)��SUB DropDownMenu(MenuCode&)�   DIM DropName$(10) : DIM Select1$(10): DIM select3$(10):DIM Select5$(10)�   DIM Select4$(10):DIM Select5$(10):DIM Select6$(10):DIM Select7$(10)�   DIM select2$(10)��   GOSUB LoadArray�   PCOPY 1, 3                       ' Copy the original screen�   MenuBar                          ' Put top menu bar on screen.�   PCOPY 1, 4�   LOCATE 2, 3 : COLOR 15, 5�   DropNr&=1 : PRINT DropName$(DropNr&)��   DO��        IF GoDownArrow& THEN:GoDownArrow&=0:KeyNumber&=20480:GOTO HopGetKey��        GetKey Keynumber&, Char$, Rgt&, Lft&, RRow&, CCol&��HopGetKey:��        IF Rgt&  THEN Keynumber& = 27            'Right Mouse Button�        IF Lft& THEN                             'Left Mouse Button�           IF RRow& = 2 THEN                   'If On the Menu Bar.� GoAgain:                           'Another chance to click on Drop name�              PCOPY 4, 1�              SelectNr& = 0 : DropNr& = 0�              IF CCol& > 2 AND CCol& < 9 THEN   'checking for boundries�                Lcol& = 2 : Rcol& = 18          'Left and right Boundries�                DropNr& = 1 : Drop 1, 3             'print drop1 to screen�                GetSelection RRow&, SelectNr&, DropNr&, Keynumber&, _�                             Lcol&, Rcol&, CCol&�              ELSEIF CCol& > 12 AND CCol& < 22 THEN�                Lcol& = 13 : Rcol& = 34�                DropNr& = 2 : Drop 2, 4�                GetSelection RRow&, SelectNr&, DropNr&, Keynumber&, _�                             Lcol&, Rcol&, CCol&�              ELSEIF CCol& > 22 AND CCol& < 33 THEN�                Lcol& = 22 : Rcol& = 41�                DropNr& = 3 : Drop 3, 6�                GetSelection RRow&, SelectNr&, DropNr&, Keynumber&, _�                             Lcol&, Rcol&, CCol&�              ELSEIF CCol& > 32 AND CCol& < 43 THEN   ' Need to add more�                Lcol& = 32 : Rcol& = 58               ' of these if Drops�                DropNr& = 4 : Drop 4, 5                   ' are added.�                GetSelection RRow&, SelectNr&, DropNr&, Keynumber&, _�                             Lcol&, Rcol&, CCol&�              END IF�              IF RRow& = 2 AND DropNr& THEN GOTO GoAgain 'Drop was selected�          END IF                                         'instead of selection�        END IF��        IF Keynumber& = 50 THEN  ' Selected out of boundries was detected�            Keynumber& = 0�            ITERATE LOOP         ' Go try it again�        END IF��        SELECT CASE Keynumber&��          CASE 19712                          ' R I G H T    A R R O W�              IF DropNr& < 4 THEN '<--Change this to your number of drops�                 INCR DropNr&        ' To be used with Column Calculations�                 PCOPY 4, 1         ' Wipe previous drop and put new Drop�                 LOCATE 2, DropNr&*10-7  'Calc location of column & Locate�                 COLOR 15, 5�                 PRINT DropName$(DropNr&) 'Print Drop Name on MenuBar�              END IF�              SelectNr& = 0�              IF xfz& > 0 THEN�                 GoDownArrow& = 1      'Setup to prevent cross level GOTO�              ITERATE LOOP�           END IF��         CASE 19200                               ' L E F T    A R R O W�            IF DropNr& > 1 THEN�               DECR DropNr&�               PCOPY 4, 1�               LOCATE 2, DropNr& * 10 - 7�               COLOR 15, 5�               PRINT DropName$(DropNr&)         'Shows drop name using keys�           END IF�           SelectNr& = 0�           IF xfz& > 0 THEN�              GoDownArrow& = 1�              ITERATE LOOP�           END IF���        CASE 20480                                     ' DOWN ARROW�downx:�              IF DropNr& = 1 AND SelectNr& < 3 THEN�              IF SelectNr&=0 THEN         'Let it scroll the first time�                 drop 1, 3 : PCOPY 1, 5   'and PCopy, to be used with rest.�              ELSEIF SelectNr& > 0 THEN�                 PCOPY 5, 1�              END IF�              INCR SelectNr&               'Increase nr to go to new line�              LOCATE SelectNr&*2+2, 3        'Locate it on the correct row�              COLOR 15, 4�              PRINT Select1$(SelectNr&)�           ELSEIF DropNr& = 2 AND SelectNr& < 4 THEN�              IF SelectNr&=0 THEN         '   |_________________________�                 drop 2, 4 : PCOPY 1, 5   '   | These numbers must equal�              ELSEIF SelectNr& > 0 THEN   '   | the number of selections�                 PCOPY 5, 1               '   | for these Drops�              END IF                      '   |_________________________�              INCR SelectNr&�              LOCATE SelectNr&*2+2, 13�              COLOR 15, 4�              PRINT Select2$(SelectNr&)�           ELSEIF DropNr& = 3 AND SelectNr& < 6 THEN�              IF SelectNr&=0 THEN          '�                 drop 3, 6 : PCOPY 1, 5    '----------------------------�              ELSEIF SelectNr& > 0 THEN    ' If new Drops are added to�                 PCOPY 5, 1                ' this Menu then new ELSEIF�              END IF                       ' blocks like these are needed.�              INCR SelectNr&               ' One of the numbers need to�              LOCATE SelectNr&*2+2, 23     ' be changed and a new Drop#�              COLOR 15, 4                  ' will need to be created.�              PRINT Select3$(SelectNr&)    '-----------------------------�          ELSEIF DropNr& = 4 AND SelectNr& < 5 THEN�               IF SelectNr&=0 THEN   ' Do a slow drop down from MenuBar�                 drop 4, 5 : PCOPY 1, 5        ' Copy to page to use later�              ELSEIF SelectNr& > 0 THEN    ' if selection after #1�                 PCOPY 5, 1                ' Display fast drop�              END IF�              COLOR 15, 4�              INCR SelectNr&             ' Increase for Row Calculation�              LOCATE SelectNr&*2+2, 33     ' Calculate Row and Locate�              PRINT Select4$(SelectNr&) ' Print selection name on new Row��           END IF�           xfz& = SelectNr&       'store for use with left & right Arrows���       CASE 18432                                ' U P    A R R O W��             IF SelectNr& = 0 THEN PCOPY 4, 1 : ITERATE LOOP��             IF DropNr& = 1 THEN         ' Doing Drop 1 here�                DECR SelectNr&           'To be used for Row Calculations�                PCOPY 5, 1                     'Cover last Selection name�                COLOR 15, 4�                LOCATE SelectNr&*2+2, 3         'Calculate row and Locate�                PRINT Select1$(SelectNr&)     'Print Selection at new row�            ELSEIF DropNr& = 2 THEN               'If you Add a new Drop�                DECR SelectNr&                    'you would also need to�                PCOPY 5, 1                        'add one of these�                COLOR 15, 4                       'ELSEIF blocks and insert�                LOCATE SelectNr&*2+2, 13          'it at the bottom. You�                PRINT Select2$(SelectNr&)         'will also need to correct�                                                  'some of the numbers.�            ELSEIF DropNr& = 3 THEN           'Doing Drop 3 here�                DECR SelectNr&�                PCOPY 5, 1�                COLOR 15, 4�                LOCATE SelectNr&*2+2, 23�                PRINT Select3$(SelectNr&)�            ELSEIF DropNr& = 4 THEN           'Doing Drop 4 here�                DECR SelectNr&�                PCOPY 5, 1�                COLOR 15, 4�                LOCATE SelectNr&*2+2, 33�                PRINT Select4$(SelectNr&)�            END IF��            IF SelectNr& = 0 THEN�                PCOPY 4, 1 : LOCATE 2, DropNr& * 10 - 7�                COLOR 15, 5 :PRINT DropName$(DropNr&)�            END IF��             xfz& = SelectNr& - 1���           CASE 27�              MenuCode& = 0�              EXIT SUB                     ' Exit menu�           CASE 13�              DR$ = STR$(DropNr&) : SN$ = STR$(SelectNr&) 'Make into String�              Number$ = RTRIM$(DR$) + LTRIM$(SN$)         'To combine�              MenuCode& = VAL(Number$)                'And change to number��              IF MenuCode& = 13 THEN         ' See if  Exit was selected�                 Exits                         ' Call the exit routine�                 GetKey Keynumber&, char$, Rgt&, Lft&, RRow&, CCol&�                 IF char$ = "y"  OR char$ = "Y" THEN�                    EXIT SUB�                 ELSEIF CCol& > 5 AND CCol& < 11 THEN 'See if mouse is on yes�                    EXIT SUB                      'If he is exit sub�                 ELSE�                    MenuCode& = 0 : EXIT SUB�                 END IF�              END IF�              EXIT SUB�           CASE ELSE�        END SELECT�    LOOP��� LoadArray:�                                            ' Names on the Menu Bar�  DropName$(1) = " File "�  DropName$(2) = " Screen "�  DropName$(3) = " Area "�  DropName$(4) = " Misc "�  DropName$(5) = " Help "�� Select1$(1) = " Open     Alt-0 "           ' Names on the first Drop� Select1$(2) = " Save     Alt-S "� Select1$(3) = " Exit     Alt-X "�� Select2$(1) = " Clear Screen  Alt-C "       ' 2nd Drop� Select2$(2) = " Save Screen   Alt-A "� Select2$(3) = " Text Color    Alt-T "� Select2$(4) = " BG   Color    Alt-G "�� Select3$(1) = " Clear Area     F2 "           ' 3rd Drop� Select3$(2) = " Color Area     F5 "� Select3$(3) = " Flip Down      F6 "� Select3$(4) = " Flip Side      F7 "� Select3$(5) = " Copy Area      F9 "� Select3$(6) = " Paste Area    F10 "�� Select4$(1) = " Margin & Wordwrap  Alt-R "      ' 4th Drop� Select4$(2) = " Set Margin         Alt-M "� Select4$(3) = " Set Wordwrap       Alt-W "� Select4$(4) = " Shell to Dos       Alt-H "� Select4$(5) = " Extended ASCII     Alt-E "�� RETURN��END SUB���SUB MenuBar()�  PCOPY 1, 2 : PAGE 2, 1         'The top Menu bar can easily be�                                 'changed by Typing over the Drop names�  COLOR 1, 9 : LOCATE 1, 1�  PRINT STRING$(80, 220);�  COLOR 15, 4                  'If you don't like red stripe, change to 15,1�  PRINT "   File      Screen    Area      Misc                                           ";�  COLOR 1, 0�  PRINT STRING$(80, 223);       ' bottom  black shadow�  PCOPY 2,1 : PAGE 1, 1�END SUB���'-----------------------------------------------------------------------��'Insert new drops by adding more DATA��SUB Drop(Dropnr&, nos&)� PCOPY 1, 2 : PAGE 2, 1�� dRow& = 2� dNx$ = READ$(Dropnr&): nx&=VAL(dNx$)�� FOR x& = 1 TO nos&�    IF x& = 1 THEN                      'do number of selections on drop�       dWide$=READ$(nx&)                 'Read drop width from DATA�       INCR nx&: dCol$=READ$(nx&)        'Read starting column from DATA�    END IF�    INCR nx&: dSelection$=READ$(nx&)        'Get selection label from DATA�    INCR nx& : dFuncKey$ = READ$(nx&)       'Get function key label�    dRow& = dRow& + 2                           'setup row for selections�    LOCATE dRow&, VAL(dCol$):COLOR 0, 1: PRINT CHR$(177); 'Lft Side shadow�    COLOR 15, 1:PRINT dSelection$;:COLOR 12,1:PRINT dFuncKey$; 'print labels�    COLOR 0, 1: PRINT CHR$(177):LOCATE dRow&+1, VAL(dCol$) 'Rgt side shadow�    COLOR 0, 1:PCOPY 2, 1 : PAGE 1, 1:SLEEP 40:PAGE 2, 1     'put in pause�    PRINT CHR$(177) + STRING$(VAL(dWide$), 32) + CHR$(177) 'put in spaces�    IF x& = 5 THEN EXIT FOR                         'If last selection exit�    PCOPY 2, 1 : PAGE 1, 1:SLEEP 40:PAGE 2, 1     'Another delay�    dRow$ ="": dSelection$ = "" : dFuncKey$ = ""� NEXT x&�  LOCATE dRow&+2, VAL(dCol$)                             'Bottom shadow�  PRINT CHR$(177) + STRING$(VAL(dWide$), 220) + CHR$(177)�  PCOPY 2, 1 : PAGE 1, 1 : EXIT SUB                        'display drop��  DATA "5", "13", "23", "37"    'start READ nr for each drop��  DATA "16", "2", " Open     ", "Alt-O "," Save     ","Alt-S "   'Drop 1�  DATA " Exit     ","Alt-X "  '1st nr is drop width & 2nd nr is start col.��  DATA "21","12", " Clear Screen  ","Alt-C "," Save Screen   ", "Alt-R "�  DATA " Text Color    ","Alt-T "," BG   COLOR    ","Alt-G "   'Drop 2��  DATA "19", "22"�  DATA  " Clear Area  ", "   F2 ", " Color Area  ", "   F5 "    'Drop 3�  DATA  " Flip Down   ", "   F6 ", " Flip Side   ", "   F7 "�  DATA  " Copy Area   ", "   F9 ", " Paste Area  ", "   F10"��  DATA "26", "32", " Margin & Wordwrap  ", "Alt-P "              'Drop 4�  DATA " SET Margin         ", "Alt-M ", " Set Wordwrap       ", "Alt-W "�  DATA " Dos Shell          ", "Alt-H ", " Extended ASCII     ", "Alt-E "�END SUB���SUB GetKey (Keynumber&, char$, Rgt&, Lft&, RRow&, CCol&)� MOUSE ON� char$ = "": Keynumber& = 0 : RRow& = 0� Rgt& = 0 : Lft& = 0  : CCol& = 0�     char$ = WAITKEY$�     IF ASC(char$, 4) = 1 THEN Lft& = 1            'Get left mouse button�     IF ASC(char$, 4) = 2 THEN Rgt& = 2            'Get right mouse Button�     RRow& = MOUSEY : CCol& = MOUSEX          'Get mouse cursor location�     IF Rgt& OR Lft& THEN MOUSE OFF : EXIT SUB�     Keynumber& = CVI(char$ + CHR$(0))� MOUSE OFF�END SUB���SUB GetSelection (RRow&, SelectNr&,DropNr&, Keynumber&, Lcol&, Rcol&, CCol&)�   GetKey Keynumber&, char$, Rgt&, Lft&, RRow&, CCol&�   IF CCol& > Lcol& AND CCol& < Rcol& AND RRow& > 3 THEN   'Set boundries�      IF RRow& = 4 THEN�         SelectNr& = 1 : Keynumber& = 13     ' Gets selection number�      ELSEIF RRow& = 6 THEN�         SelectNr& = 2 : Keynumber& = 13  'If a Drop has more than 6�      ELSEIF RRow& = 8 THEN               'selections, you'll need to�         SelectNr& = 3 : Keynumber& = 13  'add more ELSEIFs to the bottom.�      ELSEIF RRow& = 10 THEN�         IF DropNr& = 1 THEN              'Drop 1 is the only drop that�            PCOPY 4, 1                    'has less than 4 selections, it�            Keynumber& = 50 : EXIT SUB    'would exit here�         END IF                         'The rest would get their select�         SelectNr& = 4: Keynumber& = 13 'numbers and traveling orders�      ELSEIF RRow& = 12 THEN�         IF DropNr& = 1 OR DropNr& = 2 THEN  'Both drop1 and drop2 here�             PCOPY 4, 1�             Keynumber& = 50 :EXIT SUB    ' Keynumber&=50 is a flag to let�         END IF                           ' the calling routine know a�         SelectNr& = 5: Keynumber& = 13   ' selection wasn't made.�      ELSEIF RRow& = 14 THEN�         IF DropNr&=1 OR DropNr&=2 OR DropNr&=4 THEN '3 of the 4 drops here.�            PCOPY 4, 1                  'Because all drops bottom boundries�            Keynumber& = 50 : EXIT SUB  'may be different, it exits on the�         END IF                         'ones that doesn't work.�         SelectNr& = 6: Keynumber& = 13   'Drop 3 is the only one that can�      ELSE                                'receive these numbers.�         PCOPY 4, 1�         Keynumber& = 50           'flag for out of bounds selections�      END IF�  ELSE�      Keynumber& = 50 : PCOPY 4, 1�  END IF�END SUB��                                    'Fill the Screen with charecters� SUB fillscreen()�  PCOPY 1, 2 :PAGE 2, 1�  COLOR 1, 11�  PRINT STRING$(2000, 176);�   SLEEP 500�   COLOR 14, 1 : LOCATE 10, 32                               'make a box�   LOCATE 11, 32 :PRINT CHR$(201) + STRING$(14, 205) + CHR$(187)�   LOCATE 12, 32:PRINT CHR$(186) + "   PBCC Drop  " + CHR$(186)�   LOCATE 13, 32:PRINT CHR$(186) + "   Down MENU  " + CHR$(186)�   COLOR 15, 4�   LOCATE 14, 32:PRINT CHR$(186) + " Click Right  " + CHR$(186)�   LOCATE 15, 32:PRINT CHR$(186) + " Mouse Button " + CHR$(186)�   LOCATE 16, 32 :PRINT CHR$(200) + STRING$(14, 205) + CHR$(188)�   PCOPY 2, 1 : PAGE 1, 1� END SUB����SUB Exits()� PCOPY 1, 2 : PAGE 2, 1                            ' exit box� COLOR 0, 1:� LOCATE 10, 2� PRINT CHR$(178, 177, 176) + "               " + CHR$(176,177,178)� LOCATE 11, 2:PRINT CHR$(178, 177, 176);: COLOR 15,1� PRINT "    E X I T    ";: COLOR 0, 1: PRINT CHR$(176,177,178)� LOCATE 12, 2� PRINT CHR$(178, 177, 176) + "               " + CHR$(176,177,178)� LOCATE 13, 2:PRINT CHR$(178, 177, 176);: COLOR 11,1� PRINT " Are you sure? ";: COLOR 0, 1: PRINT CHR$(176,177,178)� LOCATE 14, 2� PRINT CHR$(178, 177, 176) + "               " + CHR$(176,177,178)� LOCATE 15, 2� PRINT CHR$(178, 177, 176) + "               " + CHR$(176,177,178)� LOCATE 15,5: COLOR 4,11 :PRINT " Yes "� LOCATE 15, 14 : PRINT " No "� LOCATE 16, 2 : COLOR 0, 1� PRINT CHR$(178, 177, 176) + "               " + CHR$(176,177,178)� PCOPY 2, 1 : PAGE 1, 1�END SUB���'---------------------- M A I N  ----------------------------------------��FUNCTION PBMAIN()�  MOUSE 7, DOUBLE, DOWN�  CURSOR OFF�  fillscreen                             ' Fill the screen with charecters�� DO��    GetKey Keynumber&, char$, Rgt&, Lft&, RRow&, CCol&  'Click the mouse�                                                        'or hit a key��    IF Rgt& OR Keynumber& = 27 THEN          'Call menu with ESC Key or�         DropDownMenu MenuCode&                'right mouse button.�    END IF�    IF MenuCode& = 13 THEN EXIT FUNCTION     'If Exit was selected, bye�    PCOPY 3, 1                        'If not, put back Original screen�    LOCATE 24, 10��� 'MenuCode& is a two digit number that gives you the Drop number, which� 'is the 1st digit, the second digit is the Selection number. IF you� 'click ON EXIT, the number is 13, which is 1st Drop AND 3rd Selection.��                                             'Display MenuCode& on screen�    LOCATE 20, 30 : COLOR 1, 11�    PRINT " Drop "+ CHR$(196,196,191,218,196,196)+ " Selection "�    LOCATE 21, 38 : PRINT CHR$(25,25)�    LOCATE 22, 37 : PRINT MenuCode&��  LOOP�� END FUNCTION                                                                                                                                                                                                                                                  _���                                                                                                                                                                                                                                                     _������                                                                                                                                                                                                                                                               _��������                                                                                                                                                                                                                                                               _���������                                                                                                                                                                                                       �Jerry Fielden                  Lowest common denom                                           07-01-01 (  :  )       PBCC, PBDOS            47   1741     fraction.bas�'This function will devide and give the answers with a fraction thats�'reduced to it's lowest common denominator. It works in PBDOS and�'PBCC . To test, try numbers like 5655\5423, 2345678\16 or fractions that�'can be reduced. 18144/45360 is reduced to 2/5 here. If the fraction can't�'be reduced, you will get it back as an answer.�'�'Author: Jerry Fielden�'Public Domain��DEFLNG a-z�FUNCTION PBMAIN  '  <----------------------- Dos, delete this line.��   LINE INPUT " Enter Numerator or dividend  "; Numerator$�   PRINT�   LINE INPUT " Enter Denomator or divisor   "; Denomator$�   num = VAL(Numerator$)�   denom = VAL(Denomator$)�   whole = FIX(num/denom)                    'Get whole number.�   IF num > denom THEN num = num MOD denom   'Get new numerator.��   DO                                               'Start reducing�      FOR x = 2 TO num�        IF num MOD x = 0 AND denom MOD x = 0 THEN   'See if done.�          num = num / x : denom = denom / x    'Maybe final answer .�          x = 1                        'reset FOR/Next for further reduction�          IF denom MOD num  = 0 THEN   'See if num will divide denom�             denom = denom / num       'reduce the denomator�             num = 1                   'reduce the numerator to 1.�             EXIT DO�          END IF�        END IF�      NEXT x�      EXIT DO�   LOOP��   PRINT�   PRINT " The answer is  ";�   IF whole THEN PRINT  STR$(whole);                 'Print whole number.�   IF num THEN PRINT " " + STR$(num) + "/" + LTRIM$(STR$(denom))' fraction.��   WAITKEY$   ' <--------------------------------- Dos, delete this line.��   END FUNCTION  ' <------------------------------ Dos, delete this line.���  �Don Schullian, Jr.             Long Integer Retrieval         d83@DASoftVSS.com              06-16-02 (  :  )       PBCC                   67   2647     fExitKey.bas#IF 0�    ----------------------------                       PowerBASIC/cc v2+� ---|          DASoft          |------------------------------------------�    ----------------------------         Code           DATE: 2002-04-16�    | FILE NAME   fExitKey.bas |          by�    ----------------------------  Don Schullian, Jr.��              This code is released into the Public Domain�       ----------------------------------------------------------�        No guarantee as to the viability, accuracy, or safety of�         use of this code is implied, warranted, or guaranteed�       ----------------------------------------------------------�                         Use at your own risk!�       ----------------------------------------------------------�                  CONTACT AUTHOR AT d83@DASoftVSS.com� -------------------------------------------------------------------------� This function is to be used with the return values from fGetKey. The test� code, included, assumes that you have fGetKey.bas in the same directory.�� Its purpose is to quickly scan a string looking for an included LONG� INTEGER value.��#ENDIF��FUNCTION fExitKey ALIAS "fExitKey" ( BYVAL ExitKeys AS STRING, _�                                     BYVAL KeyPress AS LONG    ) EXPORT AS LONG��  #REGISTER NONE��  DIM Tlen AS LOCAL LONG��  Tlen = LEN(ExitKeys)��                ! push  edi                     ; save this for later�                ! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;�                ! mov   ecx, Tlen               ; set length of string to be searched�                ! shr   ecx, 2                  ; divide length by 4�                ! jecxz fExetDONE               ; oops! nothing to search for�                ';;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;�                ! mov   edi, ExitKeys           ; set string address�                ! mov   eax, KeyPress           ; set INTEGER being searched for�                ! repne scasd                   ; find 4byte string in Exet$�                ! jne   fExetDONE               ; if no match found then EXIT FUNCTION�                ! mov   FUNCTION, -1            ; RETURN TRUE�  fExetDONE:    ' ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;�                ! pop   edi                     ;��END FUNCTION���#INCLUDE "fGetKey.bas"��FUNCTION PBmain ()��  DIM ExitKeys AS LOCAL STRING�  DIM K        AS LOCAL LONG��  PRINT "Press different keys to see the return values."�  PRINT "Press <ESC> or <F-10> to end program.��  ExitKeys = $ESC_key & $F10_key�  DO�    K = fGetKey�    PRINT "&h" & HEX$(K,6)�  LOOP UNTIL fExitKey(ExitKeys,K)��END FUNCTION�Don Schullian, Jr.             Windows GetKey Function        d83@DASoftVSS.com              06-16-02 (  :  )       PBCC                   335  24070    fGetKey.bas #IF 0�    ----------------------------                        PowerBASIC/cc v2+� ---|          DASoft          |------------------------------------------�    ----------------------------         Code           DATE: 2002-04-16�    | FILE NAME    fGetKey.bas |          by�    ----------------------------  Don Schullian, Jr.��              This code is released into the Public Domain�       ----------------------------------------------------------�        No guarantee as to the viability, accuracy, or safety of�         use of this code is implied, warranted, or guaranteed�       ----------------------------------------------------------�                         Use at your own risk!�       ----------------------------------------------------------�                  CONTACT AUTHOR at d83@DASoftVSS.com� -------------------------------------------------------------------------� For years I've used and promoted my fGetKey function. This, the latest� version has been upgraded to return LONG INTEGERs instead of regular� (2 byte) INTEGERs. This should make your code much faster in the Windows'� environments. As those of you who use fGetKey will note all the scalar� equates have retained the same names so upgrading should be seamless.� The only exception would be in the return of the mouse's values. This� new set is much stronger than the old one and can actually be made to� return <CTRL>, <ALT> and <SHIFT> values as well as the mouse's values.�� As an addition I've also created a matching set of string equates for the� times when one needs to shovel values into a string. (e.g. for fExitKey)�� For those of you who have not, yet, run into fGetKey the theory is simple� enough: All key strokes pass through one centeralized location in the� program. This allows you, the programmer, to trap incoming values and� make decisions on them BEFORE you release them back to the calling� routine. There are 2 versions of fGetKey included in this file. One is a� 'plane Jane' version while the other one shows how I handle Greek in PBcc� and, at the same time disallow the pipe character "|", and return all� capitals.�� As you can see, fGetKey is more a concept than just a chunk of code that� you throw into your programs. Each program could, very well, require its� own special version of the routine.�� If you have questions, please feel free to drop me a note.�� Don�#ENDIF��                        %ALT_key       = &h100000 : %CTRL_key       = &h200000 : %SHIFT_key   = &h400000�%HOME_key  = &h004700 : %ALT_HOME      = &h104700 : %CTRL_HOME      = &h204700 : %SHIFT_HOME  = &h404700�%UP_key    = &h004800 : %ALT_UP        = &h104800 : %CTRL_UP        = &h204800 : %SHIFT_UP    = &h404800�%PGUP_key  = &h004900 : %ALT_PGUP      = &h104900 : %CTRL_PGUP      = &h204900 : %SHIFT_PGUP  = &h404900�%LEFT_key  = &h004B00 : %ALT_LEFT      = &h104B00 : %CTRL_LEFT      = &h204B00 : %SHIFT_LEFT  = &h404B00�%RIGHT_key = &h004D00 : %ALT_RIGHT     = &h104D00 : %CTRL_RIGHT     = &h204D00 : %SHIFT_RIGHT = &h404D00�%END_key   = &h004F00 : %ALT_END       = &h104F00 : %CTRL_END       = &h204F00 : %SHIFT_END   = &h404F00�%DOWN_key  = &h005000 : %ALT_DOWN      = &h105000 : %CTRL_DOWN      = &h205000 : %SHIFT_DOWN  = &h405000�%PGDN_key  = &h005100 : %ALT_PGDN      = &h105100 : %CTRL_PGDN      = &h205100 : %SHIFT_PGDN  = &h405100�%INS_key   = &h005200 : %ALT_INS       = &h105200 : %CTRL_INS       = &h205200 : %SHIFT_INS   = &h405200�%DEL_key   = &h005300 : %ALT_DEL       = &h105300 : %CTRL_DEL       = &h205300 : %SHIFT_DEL   = &h405300�%ENTER_key = &h00000D :                             %CTRL_ENTER     = &h20000A : %SHIFT_ENTER = &h40000D�%ESC_key   = &h00001B :                                                          %SHIFT_ESC   = &h40001B�%BKSPC_key = &h000008 : %ALT_BKSPC     = &h100008 : %CTRL_BKSPC     = &h20007F : %SHIFT_BKSPC = &h400008�%TAB_key   = &h000009 :                             %CTRL_TAB       = &h200F00 : %SHIFT_TAB   = &h400009�%F01_key   = &h003B00 : %ALT_F01       = &h103B00 : %CTRL_F01       = &h203B00 : %SHIFT_F01   = &h403B00�%F02_key   = &h003C00 : %ALT_F02       = &h103C00 : %CTRL_F02       = &h203C00 : %SHIFT_F02   = &h403C00�%F03_key   = &h003D00 : %ALT_F03       = &h103D00 : %CTRL_F03       = &h203D00 : %SHIFT_F03   = &h403D00�%F04_key   = &h003E00 : %ALT_F04       = &h103E00 : %CTRL_F04       = &h203E00 : %SHIFT_F04   = &h403E00�%F05_key   = &h003F00 : %ALT_F05       = &h103F00 : %CTRL_F05       = &h203F00 : %SHIFT_F05   = &h403F00�%F06_key   = &h004000 : %ALT_F06       = &h104000 : %CTRL_F06       = &h204000 : %SHIFT_F06   = &h404000�%F07_key   = &h004100 : %ALT_F07       = &h104100 : %CTRL_F07       = &h204100 : %SHIFT_F07   = &h404100�%F08_key   = &h004200 : %ALT_F08       = &h104200 : %CTRL_F08       = &h204200 : %SHIFT_F08   = &h404200�%F09_key   = &h004300 : %ALT_F09       = &h104300 : %CTRL_F09       = &h204300 : %SHIFT_F09   = &h404300�%F10_key   = &h004400 : %ALT_F10       = &h104400 : %CTRL_F10       = &h204400 : %SHIFT_F10   = &h404400�%F11_key   = &h005700 : %ALT_F11       = &h105700 : %CTRL_F11       = &h203B00 : %SHIFT_F11   = &h405700�%F12_key   = &h005800 : %ALT_F12       = &h105800 : %CTRL_F12       = &h203B00 : %SHIFT_F12   = &h405800�                        %ALT_0         = &h100030 : %CTRL_0         = &h200B00�                        %ALT_1         = &h100031 : %CTRL_1         = &h200200�                        %ALT_2         = &h100032 : %CTRL_2         = &h200300�                        %ALT_3         = &h100033 : %CTRL_3         = &h200400�                        %ALT_4         = &h100034 : %CTRL_4         = &h200500�                        %ALT_5         = &h100035 : %CTRL_5         = &h200600�                        %ALT_6         = &h100036 : %CTRL_6         = &h20F200�                        %ALT_7         = &h100037 : %CTRL_7         = &h200800�                        %ALT_8         = &h100038 : %CTRL_8         = &h200900�                        %ALT_9         = &h100039 : %CTRL_9         = &h200A00�                        %ALT_A         = &h101E00 : %CTRL_A         = &h200001�                        %ALT_B         = &h103000 : %CTRL_B         = &h200002�                        %ALT_C         = &h102E00 : %CTRL_C         = &h200003�                        %ALT_D         = &h102000 : %CTRL_D         = &h200004�                        %ALT_E         = &h101200 : %CTRL_E         = &h200005�                        %ALT_F         = &h102100 : %CTRL_F         = &h200006�                        %ALT_G         = &h102200 : %CTRL_G         = &h200007�                        %ALT_H         = &h102300 : %CTRL_H         = &h200008�                        %ALT_I         = &h101700 : %CTRL_I         = &h200009�                        %ALT_J         = &h102400 : %CTRL_J         = &h20000A�                        %ALT_K         = &h102500 : %CTRL_K         = &h20000B�                        %ALT_L         = &h102600 : %CTRL_L         = &h20000C�                        %ALT_M         = &h103200 : %CTRL_M         = &h20000D�                        %ALT_N         = &h103100 : %CTRL_N         = &h20000E�                        %ALT_O         = &h101800 : %CTRL_O         = &h20000F�                        %ALT_P         = &h101900 : %CTRL_P         = &h200010�                        %ALT_Q         = &h101000 : %CTRL_Q         = &h200011�                        %ALT_R         = &h101300 : %CTRL_R         = &h200012�                        %ALT_S         = &h101F00 : %CTRL_S         = &h200013�                        %ALT_T         = &h101400 : %CTRL_T         = &h200014�                        %ALT_U         = &h101600 : %CTRL_U         = &h200015�                        %ALT_V         = &h102F00 : %CTRL_V         = &h200016�                        %ALT_W         = &h101100 : %CTRL_W         = &h200017�                        %ALT_X         = &h102D00 : %CTRL_X         = &h200018�                        %ALT_Y         = &h101500 : %CTRL_Y         = &h200019�                        %ALT_Z         = &h102C00 : %CTRL_Z         = &h20001A�%PIPE_key  = &h00007C�%PLUS_key  = &h00002B�%MINUS_key = &h00002D : %ALT_MINUS     = &h10002D : %CTRL_MINUS     = &h200C00�%EQUAL_key = &h00003D : %ALT_EQUAL     = &h10003D : %CTRL_EQUAL     = &h200D00�                        %ALT_F_SLASH   = &h10002F : %CTRL_F_SLASH   = &h203500�                        %ALT_B_SLASH   = &h10005C : %CTRL_B_SLASH   = &h20001C�                        %ALT_TILDE     = &h100060 : %CTRL_TILDE     = &h202900�                        %ALT_QUOTE     = &h100027 : %CTRL_QUOTE     = &h202800�                        %ALT_COLON     = &h10003B : %CTRL_COLON     = &h202700�                        %ALT_COMMA     = &h10002C : %CTRL_COMMA     = &h203300�                        %ALT_PERIOD    = &h10002E : %CTRL_PERIOD    = &h203400�                        %ALT_L_BRACKET = &h10005B : %CTRL_L_BRACKET = &h20001B�                        %ALT_R_BRACKET = &h10005D : %CTRL_R_BRACKET = &h20001D�%GRAY5_key = &h004C00 : %ALT_GRAY5     = &h104C00 : %CTRL_GRAY5     = &h204C00�                        %ALT_GRAYPLUS  = &h104E00 : %CTRL_GRAYPLUS  = &h204E00�                                                    %CTRL_GRAYMINUS = &h204A00�                                                    %CTRL_GRAYSLASH = &h203500�                                                    %CTRL_GRAYSTAR  = &h203700�'---------------------------------------------------------------------------------------�%Mouse_Hit       = &h0000FFFF�%Mouse_Move      = &h0001FFFF��%Mouse_Double    = &h0002FFFF�%Mouse_Down      = &h0004FFFF�%Mouse_Up        = &h0008FFFF��%Mouse_Double_L  = &h0102FFFF�%Mouse_Down_L    = &h0104FFFF�%Mouse_Up_L      = &h0108FFFF��%Mouse_Double_R  = &h0202FFFF�%Mouse_Down_R    = &h0204FFFF�%Mouse_Up_R      = &h0208FFFF��%Mouse_Double_L2 = &h0402FFFF�%Mouse_Down_L2   = &h0404FFFF�%Mouse_Up_L2     = &h0408FFFF��%Mouse_Double_L3 = &h0802FFFF�%Mouse_Down_L3   = &h0804FFFF�%Mouse_Up_L3     = &h0808FFFF��%Mouse_Double_L4 = &h1002FFFF�%Mouse_Down_L4   = &h1004FFFF�%Mouse_Up_L4     = &h1008FFFF�'---------------------------------------------------------------------------�'------------  STRING VALUES FOR MKL$(fGetKey)  ----------------------------�'---------------------------------------------------------------------------�                               $ALT_key       = CHR$(0,000,016,0) : $CTRL_key       = CHR$(0,000,032,0) : $SHIFT_key   = CHR$(0,000,064,0)�$HOME_key  = CHR$(0,071,0,0) : $ALT_HOME      = CHR$(0,071,016,0) : $CTRL_HOME      = CHR$(0,071,032,0) : $SHIFT_HOME  = CHR$(0,071,064,0)�$UP_key    = CHR$(0,072,0,0) : $ALT_UP        = CHR$(0,072,016,0) : $CTRL_UP        = CHR$(0,072,032,0) : $SHIFT_UP    = CHR$(0,072,064,0)�$PGUP_key  = CHR$(0,073,0,0) : $ALT_PGUP      = CHR$(0,073,016,0) : $CTRL_PGUP      = CHR$(0,073,032,0) : $SHIFT_PGUP  = CHR$(0,073,064,0)�$LEFT_key  = CHR$(0,075,0,0) : $ALT_LEFT      = CHR$(0,075,016,0) : $CTRL_LEFT      = CHR$(0,075,032,0) : $SHIFT_LEFT  = CHR$(0,075,064,0)�$RIGHT_key = CHR$(0,077,0,0) : $ALT_RIGHT     = CHR$(0,077,016,0) : $CTRL_RIGHT     = CHR$(0,077,032,0) : $SHIFT_RIGHT = CHR$(0,077,064,0)�$END_key   = CHR$(0,079,0,0) : $ALT_END       = CHR$(0,079,016,0) : $CTRL_END       = CHR$(0,079,032,0) : $SHIFT_END   = CHR$(0,079,064,0)�$DOWN_key  = CHR$(0,080,0,0) : $ALT_DOWN      = CHR$(0,080,016,0) : $CTRL_DOWN      = CHR$(0,080,032,0) : $SHIFT_DOWN  = CHR$(0,080,064,0)�$PGDN_key  = CHR$(0,081,0,0) : $ALT_PGDN      = CHR$(0,081,016,0) : $CTRL_PGDN      = CHR$(0,081,032,0) : $SHIFT_PGDN  = CHR$(0,081,064,0)�$INS_key   = CHR$(0,082,0,0) : $ALT_INS       = CHR$(0,082,016,0) : $CTRL_INS       = CHR$(0,082,032,0) : $SHIFT_INS   = CHR$(0,082,064,0)�$DEL_key   = CHR$(0,083,0,0) : $ALT_DEL       = CHR$(0,083,016,0) : $CTRL_DEL       = CHR$(0,083,032,0) : $SHIFT_DEL   = CHR$(0,083,064,0)�$ENTER_key = CHR$(013,0,0,0) :                                      $CTRL_ENTER     = CHR$(010,0,032,0) : $SHIFT_ENTER = CHR$(013,0,064,0)�$ESC_key   = CHR$(027,0,0,0) :                                                                            $SHIFT_ESC   = CHR$(027,0,064,0)�$BKSPC_key = CHR$(008,0,0,0) : $ALT_BKSPC     = CHR$(008,0,016,0) : $CTRL_BKSPC     = CHR$(127,0,032,0) : $SHIFT_BKSPC = CHR$(008,0,064,0)�$TAB_key   = CHR$(009,0,0,0) :                                      $CTRL_TAB       = CHR$(0,015,032,0) : $SHIFT_TAB   = CHR$(009,0,064,0)�$F01_key   = CHR$(0,059,0,0) : $ALT_F01       = CHR$(0,059,016,0) : $CTRL_F01       = CHR$(0,059,032,0) : $SHIFT_F01   = CHR$(0,059,064,0)�$F02_key   = CHR$(0,060,0,0) : $ALT_F02       = CHR$(0,060,016,0) : $CTRL_F02       = CHR$(0,060,032,0) : $SHIFT_F02   = CHR$(0,060,064,0)�$F03_key   = CHR$(0,061,0,0) : $ALT_F03       = CHR$(0,061,016,0) : $CTRL_F03       = CHR$(0,061,032,0) : $SHIFT_F03   = CHR$(0,061,064,0)�$F04_key   = CHR$(0,062,0,0) : $ALT_F04       = CHR$(0,062,016,0) : $CTRL_F04       = CHR$(0,062,032,0) : $SHIFT_F04   = CHR$(0,062,064,0)�$F05_key   = CHR$(0,063,0,0) : $ALT_F05       = CHR$(0,063,016,0) : $CTRL_F05       = CHR$(0,063,032,0) : $SHIFT_F05   = CHR$(0,063,064,0)�$F06_key   = CHR$(0,064,0,0) : $ALT_F06       = CHR$(0,064,016,0) : $CTRL_F06       = CHR$(0,064,032,0) : $SHIFT_F06   = CHR$(0,064,064,0)�$F07_key   = CHR$(0,065,0,0) : $ALT_F07       = CHR$(0,065,016,0) : $CTRL_F07       = CHR$(0,065,032,0) : $SHIFT_F07   = CHR$(0,065,064,0)�$F08_key   = CHR$(0,066,0,0) : $ALT_F08       = CHR$(0,066,016,0) : $CTRL_F08       = CHR$(0,066,032,0) : $SHIFT_F08   = CHR$(0,066,064,0)�$F09_key   = CHR$(0,067,0,0) : $ALT_F09       = CHR$(0,067,016,0) : $CTRL_F09       = CHR$(0,067,032,0) : $SHIFT_F09   = CHR$(0,067,064,0)�$F10_key   = CHR$(0,068,0,0) : $ALT_F10       = CHR$(0,068,016,0) : $CTRL_F10       = CHR$(0,068,032,0) : $SHIFT_F10   = CHR$(0,068,064,0)�$F11_key   = CHR$(0,087,0,0) : $ALT_F11       = CHR$(0,087,016,0) : $CTRL_F11       = CHR$(0,059,032,0) : $SHIFT_F11   = CHR$(0,087,064,0)�$F12_key   = CHR$(0,088,0,0) : $ALT_F12       = CHR$(0,088,016,0) : $CTRL_F12       = CHR$(0,059,032,0) : $SHIFT_F12   = CHR$(0,088,064,0)�                               $ALT_0         = CHR$(048,0,016,0) : $CTRL_0         = CHR$(0,011,032,0)�                               $ALT_1         = CHR$(049,0,016,0) : $CTRL_1         = CHR$(0,002,032,0)�                               $ALT_2         = CHR$(050,0,016,0) : $CTRL_2         = CHR$(0,003,032,0)�                               $ALT_3         = CHR$(051,0,016,0) : $CTRL_3         = CHR$(0,004,032,0)�                               $ALT_4         = CHR$(052,0,016,0) : $CTRL_4         = CHR$(0,005,032,0)�                               $ALT_5         = CHR$(053,0,016,0) : $CTRL_5         = CHR$(0,006,032,0)�                               $ALT_6         = CHR$(054,0,016,0) : $CTRL_6         = CHR$(0,242,032,0)�                               $ALT_7         = CHR$(055,0,016,0) : $CTRL_7         = CHR$(0,008,032,0)�                               $ALT_8         = CHR$(056,0,016,0) : $CTRL_8         = CHR$(0,009,032,0)�                               $ALT_9         = CHR$(057,0,016,0) : $CTRL_9         = CHR$(0,010,032,0)�                               $ALT_A         = CHR$(0,030,016,0) : $CTRL_A         = CHR$(001,0,032,0)�                               $ALT_B         = CHR$(0,048,016,0) : $CTRL_B         = CHR$(002,0,032,0)�                               $ALT_C         = CHR$(0,046,016,0) : $CTRL_C         = CHR$(003,0,032,0)�                               $ALT_D         = CHR$(0,032,016,0) : $CTRL_D         = CHR$(004,0,032,0)�                               $ALT_E         = CHR$(0,018,016,0) : $CTRL_E         = CHR$(005,0,032,0)�                               $ALT_F         = CHR$(0,033,016,0) : $CTRL_F         = CHR$(006,0,032,0)�                               $ALT_G         = CHR$(0,034,016,0) : $CTRL_G         = CHR$(007,0,032,0)�                               $ALT_H         = CHR$(0,035,016,0) : $CTRL_H         = CHR$(008,0,032,0)�                               $ALT_I         = CHR$(0,023,016,0) : $CTRL_I         = CHR$(009,0,032,0)�                               $ALT_J         = CHR$(0,036,016,0) : $CTRL_J         = CHR$(010,0,032,0)�                               $ALT_K         = CHR$(0,037,016,0) : $CTRL_K         = CHR$(011,0,032,0)�                               $ALT_L         = CHR$(0,038,016,0) : $CTRL_L         = CHR$(012,0,032,0)�                               $ALT_M         = CHR$(0,050,016,0) : $CTRL_M         = CHR$(013,0,032,0)�                               $ALT_N         = CHR$(0,049,016,0) : $CTRL_N         = CHR$(014,0,032,0)�                               $ALT_O         = CHR$(0,024,016,0) : $CTRL_O         = CHR$(015,0,032,0)�                               $ALT_P         = CHR$(0,025,016,0) : $CTRL_P         = CHR$(016,0,032,0)�                               $ALT_Q         = CHR$(0,016,016,0) : $CTRL_Q         = CHR$(017,0,032,0)�                               $ALT_R         = CHR$(0,019,016,0) : $CTRL_R         = CHR$(018,0,032,0)�                               $ALT_S         = CHR$(0,031,016,0) : $CTRL_S         = CHR$(019,0,032,0)�                               $ALT_T         = CHR$(0,020,016,0) : $CTRL_T         = CHR$(020,0,032,0)�                               $ALT_U         = CHR$(0,022,016,0) : $CTRL_U         = CHR$(021,0,032,0)�                               $ALT_V         = CHR$(0,047,016,0) : $CTRL_V         = CHR$(022,0,032,0)�                               $ALT_W         = CHR$(0,017,016,0) : $CTRL_W         = CHR$(023,0,032,0)�                               $ALT_X         = CHR$(0,045,016,0) : $CTRL_X         = CHR$(024,0,032,0)�                               $ALT_Y         = CHR$(0,021,016,0) : $CTRL_Y         = CHR$(025,0,032,0)�                               $ALT_Z         = CHR$(0,044,016,0) : $CTRL_Z         = CHR$(026,0,032,0)�$PIPE_key  = CHR$(124,0,0,0)�$PLUS_key  = CHR$(043,0,0,0)�$MINUS_key = CHR$(045,0,0,0) : $ALT_MINUS     = CHR$(045,0,016,0) : $CTRL_MINUS     = CHR$(0,012,032,0)�$EQUAL_key = CHR$(061,0,0,0) : $ALT_EQUAL     = CHR$(061,0,016,0) : $CTRL_EQUAL     = CHR$(0,013,032,0)�                               $ALT_F_SLASH   = CHR$(047,0,016,0) : $CTRL_F_SLASH   = CHR$(0,053,032,0)�                               $ALT_B_SLASH   = CHR$(092,0,016,0) : $CTRL_B_SLASH   = CHR$(028,0,032,0)�                               $ALT_TILDE     = CHR$(096,0,016,0) : $CTRL_TILDE     = CHR$(0,041,032,0)�                               $ALT_QUOTE     = CHR$(039,0,016,0) : $CTRL_QUOTE     = CHR$(0,040,032,0)�                               $ALT_COLON     = CHR$(059,0,016,0) : $CTRL_COLON     = CHR$(0,039,032,0)�                               $ALT_COMMA     = CHR$(044,0,016,0) : $CTRL_COMMA     = CHR$(0,051,032,0)�                               $ALT_PERIOD    = CHR$(046,0,016,0) : $CTRL_PERIOD    = CHR$(0,052,032,0)�                               $ALT_L_BRACKET = CHR$(091,0,016,0) : $CTRL_L_BRACKET = CHR$(027,0,032,0)�                               $ALT_R_BRACKET = CHR$(093,0,016,0) : $CTRL_R_BRACKET = CHR$(029,0,032,0)�$GRAY5_key = CHR$(0,076,0,0) : $ALT_GRAY5     = CHR$(0,076,016,0) : $CTRL_GRAY5     = CHR$(0,076,032,0)�                               $ALT_GRAYPLUS  = CHR$(0,078,016,0) : $CTRL_GRAYPLUS  = CHR$(0,078,032,0)�                                                                    $CTRL_GRAYMINUS = CHR$(0,074,032,0)�                                                                    $CTRL_GRAYSLASH = CHR$(0,053,032,0)�                                                                    $CTRL_GRAYSTAR  = CHR$(0,055,032,0)�'---------------------------------------------------------------------------------------�$Mouse_Hit       = CHR$(255,255,000,000)�$Mouse_Move      = CHR$(255,255,001,000)��$Mouse_Double    = CHR$(255,255,002,000)�$Mouse_Down      = CHR$(255,255,004,000)�$Mouse_Up        = CHR$(255,255,008,000)��$Mouse_Double_L  = CHR$(255,255,002,001)�$Mouse_Down_L    = CHR$(255,255,004,001)�$Mouse_Up_L      = CHR$(255,255,008,001)��$Mouse_Double_R  = CHR$(255,255,002,002)�$Mouse_Down_R    = CHR$(255,255,004,002)�$Mouse_Up_R      = CHR$(255,255,008,002)��$Mouse_Double_L2 = CHR$(255,255,002,004)�$Mouse_Down_L2   = CHR$(255,255,004,004)�$Mouse_Up_L2     = CHR$(255,255,008,004)��$Mouse_Double_L3 = CHR$(255,255,002,008)�$Mouse_Down_L3   = CHR$(255,255,004,008)�$Mouse_Up_L3     = CHR$(255,255,008,008)��$Mouse_Double_L4 = CHR$(255,255,002,016)�$Mouse_Down_L4   = CHR$(255,255,004,016)�$Mouse_Up_L4     = CHR$(255,255,008,016)��#if 1�  FUNCTION fGetKey ALIAS "fGetKey" () AS LONG��    DIM I AS LOCAL  LONG                                   '�    DIM K AS LOCAL  LONG                                   '�                                                           '�    K = CVL(WAITKEY$)                                      '�    I = (INSHIFT AND &b011111)                             ' ALT, CTRL & SHIFT�                                                           '�    IF (I AND  3) THEN BIT SET K, 20                       ' etiher ALT keys�    IF (I AND 12) THEN BIT SET K, 21                       ' either CTRL keys�                                                           '�    IF (K <  31) OR (K > 255) THEN                         ' if not a letter key�      IF (I AND 16) THEN BIT SET K, 22                     '  set either SHIFT keys�    END IF                                                 '�                                                           '�    FUNCTION = K                                           '�                                                           '�  END FUNCTION                                             '�#else�  FUNCTION fGetKey ALIAS "fGetKey" () AS LONG��    DIM English AS STATIC LONG                             '�    DIM I       AS LOCAL  LONG                             '�    DIM K       AS LOCAL  LONG                             '�                                                           '�    DO                                                     '�      K = CVL(WAITKEY$)                                    '�      I = (INSHIFT AND &b011111)                           ' ALT, CTRL & SHIFT�                                                           '�      IF (I AND  3) THEN BIT SET K, 20                     ' etiher ALT keys�      IF (I AND 12) THEN BIT SET K, 21                     ' either CTRL keys�                                                           '�      IF (K <  31) OR (K > 255) THEN                       ' if not a letter key�          IF (I AND 16) THEN BIT SET K, 22                 '  set either SHIFT keys�        ELSE                                               '�          IF (K > 96) AND (K < 123) THEN BIT RESET K, 5    ' UCASE the English letters�          IF (English = 0) AND (K > 64) AND (K < 91) THEN  ' if using non-English language�            K = ASC("���������������� ���������",K-64)     '�          END IF                                           '�      END IF                                               '�                                                           '�      SELECT CASE K                                        '�        CASE %CTRL_ENTER : BIT TOGGLE English,0            '�        CASE %PIPE_key   : ITERATE                         '�        CASE ELSE        : EXIT LOOP                       '�      END SELECT                                           '�    LOOP                                                   '�                                                           '�    FUNCTION = K                                           '��  END FUNCTION�#endif��#if 0�FUNCTION PBmain ()��  DIM K AS LOCAL LONG��  PRINT "Press different keys to see the return values."�  PRINT "Press <ESC> to end program.��  DO�    K = fGetKey�    PRINT "&h" & HEX$(K,6)�  LOOP UNTIL K = %ESC_key��END FUNCTION�#endif�Fred Buffington                Simple Input Function          oasys@sbcglobal.net            12-22-02 (  :  )       pbcc                   104  2538     smplinpt.bas'Fred Buffington�'Simple Input routine�'PBCC��$COMPILE EXE � � DECLARE FUNCTION Linput(xpos%,ypos%,L%,df$) AS STRING �'------------------------------------------------ �'Linput input routine print brackets around input �'L% is length allow for the input routine �'xpos,ypos initial position on screen �'df$ is the default value �'------------------------------------------------ � FUNCTION PBMAIN() �   CONSOLE SCREEN 26,80 � �   dflt$="TEST" �   COLOR 15,1 �   CLS �   xvar$=linput(5,10,5,dflt$) � �   LOCATE 12,5:PRINT xvar$;"<here" 'test to show result �   WHILE INKEY$="":WEND � END FUNCTION � � FUNCTION Linput(x%,y%,L%,df$) AS STRING �   LOCAL del$,lft$,rit$,zend$,hom$ � �   del$=CHR$(0)+CHR$(83)  'delete key �   Lft$=CHR$(0)+CHR$(75)  'left arrow �   rit$=CHR$(0)+CHR$(77)  'right arrow �   zend$=CHR$(0)+CHR$(79) 'end key �   hom$=CHR$(0)+CHR$(71)  'home key �   position%=0 �'   LOCATE y%,x%-1:PRINT "[";SPACE$(L%);"]"; �'  above can be used to put brackets around the input �   var$=df$ �   LOCATE y%,x%:PRINT var$; �   LOCATE y%,x% �   DO � �       xinp$ = INKEY$ � �'checkmouse here � �       IF xinp$=zend$ THEN position%=l%-1 � �       IF xinp$=Hom$ THEN position%=0 � �       IF xinp$=lft$ THEN xinp$=CHR$(8) 'making 8  �nondestructive � �       IF xinp$>CHR$(30) THEN �              IF position%+1>LEN(var$) THEN � �                  var$=var$+xinp$:position%=position%+1 �              ELSE �                  MID$(var$,position%+1,1)=xinp$:position%=position%+1 � �              END IF � �        END IF � �        IF xinp$=CHR$(8) THEN � �'if you want descructive backspace then set xinp$ = del$ and rem position%=position%-1 � �             position%=position%-1 � �             IF position%<0 THEN position%=0 � �        END IF � �        IF xinp$ = del$ THEN � �            IF position%>0 THEN � �               var$=MID$(var$,1,position%)+MID$(var$,position%+2) � �            ELSE � �                 IF LEN(var$)>1 THEN � �                    var$=MID$(var$,2):position%=0 � �                 ELSE �  �                    var$="":position%=0 � �                 END IF � �            END IF � �        END IF � �        IF xinp$=rit$ THEN position%=position%+1 � �        IF position%>=L% THEN position%=L%-1 � �        IF xinp$<>"" THEN LOCATE y%,x%:PRINT SPACE$(L%);:LOCATE y%,x%:PRINT var$;:LOCATE y%,x%+position%:CURSOR ON � �   LOOP UNTIL xinp$=CHR$(13) OR xinp$=CHR$(27) �   linput=var$ � END FUNCTION �Jerry_Fielden                  List Box in PBCC               fielden@pldi.net               12-22-02 (  :  )       PBCC                   138  5458     PBlstbox.bas'Jerry_Fielden Email:  fielden@pldi.net �'PBCC ListBox�'PBCC��#COMPILE EXE �   #REGISTER NONE �   #INCLUDE "C:\PBDLL61\WinAPI\win32api.inc" �    GLOBAL sText AS STRING � �         ' Create Main window �   FUNCTION DialogNew (hWndParent AS DWORD, Title AS ASCIIZ, x AS LONG, _ �  y AS LONG, cx AS LONG, cy AS LONG, style AS DWORD, _ �  exStyle AS DWORD, lpDlgProc AS DWORD) AS LONG � � LOCAL hDlg AS DWORD � DIM sDlgTemplateEx AS STRING � sDlgTemplateEx = MKWRD$(1) + MKWRD$(&HFFFF) + MKDWD$(0) + _ �    MKDWD$(exStyle) + MKDWD$(style OR %DS_SETFONT OR %DS_FIXEDSYS) _ �    + MKWRD$(0) + MKI$(x) + MKI$(y) + MKI$(cx) + MKI$(cy) + MKI$(0) + MKI$(0) � FUNCTION = DialogBoxIndirectParam (GetModuleHandle(""), _ � BYVAL STRPTR(sDlgTemplateEx), hWndParent, lpDlgProc, 0) � �   END FUNCTION � �         ' Create Child windows �   FUNCTION ControlAdd (lpClassName AS ASCIIZ, hDlg AS DWORD, Id AS LONG, _ �    Title AS ASCIIZ, x AS LONG, y AS LONG, _ � cx AS LONG, cy AS LONG, style AS DWORD, exStyle AS DWORD) AS DWORD � � LOCAL rc AS RECT, hWnd AS DWORD   ' Window sizes � rc.nLeft = x: rc.nRight = x + cx � rc.nTop = y: rc.nBottom = y + cy � MapDialogRect hDlg, rc �          ' Create and get handle � hWnd = CreateWindowEx (exStyle, lpClassName, Title, style, rc.nLeft, _ � rc.nTop, rc.nRight - rc.nLeft,  rc.nBottom - rc.nTop, hDlg, Id, _ � GetModuleHandle(""), BYVAL 0) �   END FUNCTION � � �   FUNCTION DlgProc (BYVAL hDlg AS DWORD, BYVAL wMsg AS DWORD, BYVAL wParam _ � AS DWORD, BYVAL lParam AS LONG) AS LONG � � LOCAL x AS LONG, hLbox AS LONG, nLength AS LONG, nIndex AS LONG � DIM arr(0:15) AS STRING, hCBox AS LONG � � IF wMsg = %WM_INITDIALOG THEN     ' Initialize child window, Label �  ControlAdd "static" , hDlg, 104, "Click on a Color", 30, 4, 60, 12, _ �       %WS_CHILD OR %WS_VISIBLE , 0 �               ' a Button �  ControlAdd "Button", hDlg, %IDOK, "&Ok", 30, 175, 50, 12, %WS_CHILD _ �       OR %WS_VISIBLE OR %WS_TABSTOP OR %BS_PUSHBUTTON, 0 �               ' a ListBox �  ControlAdd "ListBox", hDlg, 105, "", 22, 18, 68, 60, _ �       %WS_CHILD OR %WS_TABSTOP OR %WS_VISIBLE OR %LBS_NOTIFY OR _ �       %LBS_HASSTRINGS OR %LBS_USETABSTOPS, %WS_EX_CLIENTEDGE �               ' a Combo Box �  ControlAdd "ComboBox", hDlg, 106, "The Rest", 22, 80, 68, 100,  _ �       %WS_CHILD OR %WS_TABSTOP OR %WS_VISIBLE OR %CBS_DROPDOWN OR _ �       %CBS_AUTOHSCROLL OR %CBS_HASSTRINGS, 0 � � �   arr(0)  = "0 Black"   : arr(1)  = "1 Blue" �   arr(2)  = "2 Green"   : arr(3)  = "3 Cyan" �   arr(4)  = "4 Red"     : arr(5)  = "5 Magenta" �   arr(6)  = "6 Brown"   : arr(7)  = "7 Light Gray" �   arr(8)  = "8 Gray"    : arr(9)  = "9 Light Blue" �   arr(10) = "10 Light Green" : arr(11) = "11 Light Cyan" �   arr(12) = "12 Light Red"   : arr(13) = "13 Light Magenta" �   arr(14) = "14 Yellow" : arr(15) = "15 Bright White" � �   FOR x = 0 TO 15      ' Load Array into boxes �     IF x < 7 THEN      ' Load half in Listbox �    hLBox = GetDlgItem( hDlg, 105 ) �    SendMessage hLBox, %LB_ADDSTRING, 0, STRPTR(arr(x)) �     ELSE �    hCBox = GetDlgItem( hDlg, 106 )     ' and half in Combo box �    SendMessage hCBox, %CB_ADDSTRING, 0, STRPTR(arr(x)) �     END IF � �   NEXT x �   SendMessage hCBox, %CB_SETCURSEL, 0, 0    ' Get Combo default text �   GOSUB GetComboText � �   SetForegroundWindow hDlg � � ELSEIF wMsg = %WM_COMMAND THEN     ' End the Dialog �   IF HIWRD(wParam) = %Bn_CLICKED AND LOWRD(wParam) = %IDOK THEN �    EndDialog hDlg, 0 �           ' Get selected ListBox text �   ELSEIF LOWRD(wParam) = 105 AND HIWRD(wParam) = %LBN_SELCHANGE THEN �       hLBox = GetDlgItem( hDlg, 105 ) �       nIndex = SendMessage( hLBox, %LB_GETCURSEL, 0, BYVAL 0& ) �       IF nIndex < 0 THEN EXIT FUNCTION �       nLength = SendMessage( hLBox, %LB_GETTEXTLEN, nIndex, BYVAL 0& ) �       IF nLength < 1 THEN EXIT FUNCTION �       sText = STRING$( nLength, 0 ) �       SendMessage hLBox, %LB_GETTEXT, nIndex, BYVAL STRPTR( sText ) �       MessageBox GetActiveWindow(), BYVAL STRPTR( sText ),"You picked", 0 OR %MB_TASKMODAL �             ' Get selected Combo text �   ELSEIF LOWRD(wParam) = 106 AND HIWRD(wParam) = %CBN_SELCHANGE THEN �       GOSUB GetComboText �       MessageBox GetActiveWindow(), BYVAL STRPTR( sText ),"You picked", 0 OR %MB_TASKMODAL �  END IF � ELSEIF wMsg = %WM_CLOSE  THEN �   EndDialog hDlg,0 � END IF � � EXIT FUNCTION � � GetComboText: �    hCBox = GetDlgItem( hDlg, 106 ) �    nIndex = SendMessage( hCBox, %CB_GETCURSEL, 0, BYVAL 0& ) �    IF nIndex < 0 THEN EXIT FUNCTION �    nLength = SendMessage( hCBox, %CB_GETLBTEXTLEN, nIndex&, BYVAL 0& ) �    IF nLength < 1 THEN EXIT FUNCTION �    sText = STRING$( nLength, 0 ) �    SendMessage hCBox,  %CB_GETLBTEXT, nIndex, BYVAL STRPTR( sText ) � RETURN � �  END FUNCTION � � �  FUNCTION PBMAIN AS LONG �     LOCAL sTitle AS STRING , nStyle AS LONG � �     CALL DialogNew (0, "", 0, 0, 110, 200, %DS_MODALFRAME OR %DS_CENTER OR _ �     %WS_VISIBLE OR %WS_OVERLAPPEDWINDOW, 0, CODEPTR(DlgProc)) � �     COLOR 4, VAL(LEFT$(sText, 2)) : CLS � �     IF sText <> "" THEN sText = MID$(sText,3 ) �     IF sText = "" THEN sText = " You picked nothing "  ELSE sText = _ �     "Your final Pick is " & sText : sTitle = "   It looks like" � �     MessageBox GetActiveWindow(), BYVAL STRPTR( sText ), BYVAL STRPTR( sTitle ), nStyle OR %MB_TASKMODAL � �  END FUNCTION �