home *** CD-ROM | disk | FTP | other *** search
- {$v-}
- unit Fieldio;
-
- interface { FIELDIO.TPU a Turbo Pascal (R) unit }
- { for field input and output }
- uses
- Crt, { version 1.0 }
- Dos; { Copyright (c) 1988 by W. Lee Passey }
- { All rights reserved
-
-
-
- FieldIO is a separately compiled unit for Turbo Pascal ver. 4.0 from
- Borland International, Inc. FieldIO may be linked to a user's source pro-
- grams, and will provide routines for "Bullet Proof" data entry.
- What follows is a copy of the FieldIO interface section, with each
- procedure and significant variable annotated as to its function and use.
- }
-
- type
- String5 = string[5];
- String10 = string[10];
- String15 = string[15];
- String20 = string[20];
- String25 = string[25];
- String30 = string[30];
- String35 = string[35];
- String40 = string[40];
- String45 = string[45];
- String50 = string[50];
- String55 = string[55];
- String60 = string[60];
- String65 = string[65];
- String70 = string[70];
- String75 = string[75];
- String80 = string[80];
- String85 = string[85];
- String90 = string[90];
- String130 = string[130];
- String150 = string[150];
- datetype = string[9];
-
- setofchar = set of char;
-
- wordpointer = ^wordheap; { These are the variable types }
- wordheap = record { for a linked list of words or }
- NextWord, { phrases on the heap. They }
- PrevWord : wordpointer; { used by the 'DisplayWords' }
- Word : string[25]; { and 'GetList' routines. }
- end;
-
- TextRec = record { This is the record type for }
- NextRec : longint; { the help file. Record zero }
- case byte of { contains a header array for }
- 0 : (Text { the first 30 help screens (0 }
- : string[123]); { is unused in the first header,}
- 1 : (Header
- : array [0 .. 30] of longint);
- end;
- { although it is in subsequent }
- { headers) where each element }
- { in the array is the first }
- { record of of the correspond- }
- { ing help screen. For header }
- { records, 'NextRec' points to }
- { the next header and for text }
- { records it points to the next }
- { text. Text is automatically }
- { word wrapped when displayed, }
- { so all text records, except }
- { the last on each screen, }
- { should be packed with a full }
- { 123 bytes. }
-
- const { constants for cursor control keys - mostly self- }
- Up = ^E; { explanatory }
- Down = ^X;
- Right = ^D;
- Left = ^S;
- WdRt = ^F;
- WdLt = ^A;
- ScUp = ^Z;
- ScDn = ^W;
- Ret = ^M;
- InLin = ^N;
- PgUp = ^R;
- PgDn = ^C;
- Reform = ^B;
- Esc = #27;
- Del = #127;
- DelFd = ^G;
- DelWd = ^T;
- DelLn = ^Y;
- Space = #32;
- Null = #0;
- Tab = ^I;
- BkSp = ^H;
- HelpKey = #187; { These three numbers are the return codes for }
- Home = #199; { these keys with the high bit set. GetChar sets }
- EndKey = #207; { the high bit for all extended key codes. }
-
- TB : char = #205; { These characters are used to create the top, }
- SID : char = #186; { bottom (TB), sides (SID) and each of the four }
- TLC : char = #201; { corners (TLC, TRC, BLC, BRC) of the help window }
- TRC : char = #187; { border. They can be changed to whatever you }
- BLC : char = #200; { like. These values make a double border. }
- BRC : char = #188;
-
- AllChars : setofchar = [' ' .. '}'];
- ControlSet : setofchar = [^A .. ^Z, Esc, Del];
- NumChars : setofchar = ['0' .. '9'];
- NameChars : setofchar = ['A' .. 'Z', 'a' .. 'z', '-', '.', '_'];
- SpaceChars : setofchar = [' ', '-', '/', ','];
-
- BeepOnError : boolean = false; { When this variable is true, }
- { an unacceptable response, }
- { e.g. a letter in a number }
- { field, will cause the speaker }
- { to beep. }
-
- NoFuture : boolean = false; { When this variable is true, }
- { the GetDateStr routine will }
- { not accept a future date, }
- { i.e. one in advance of the }
- { 'TodaysDate', which is init- }
- { ialized by this unit to the }
- { system date. }
-
- InsertOn : boolean = false; { When this variable is true, }
- { newly added characters will }
- { be inserted into the field at }
- { the cursor position. When }
- { false, overwriting occurs. }
-
- Escape : boolean = false; { This variable will be set to }
- { true whenever the escape key }
- { is pressed, and reset to }
- { false whenever any other key }
- { is pressed. Note: most of }
- { following routines stop col- }
- { lecting characters and return }
- { when this occurs. }
-
- ErrMsg : boolean = false; { This variable will be set to }
- { true if an error message was }
- { printed on the last line of }
- { the screen. These messages }
- { get cleared upon the next }
- { key-press. }
-
- Reference : boolean = false; { When this variable is true, }
- { the last sentence of a help }
- { screen is considered to be a }
- { reference (to the manual, }
- { etc.) and will be printed in }
- { the lower right corner of the }
- { help screen. If the last }
- { sentence is the single char- }
- { acter '#', the number of the }
- { help screen will be displayed.}
-
- RefMark : string15 = '#-'; { If the option to print help }
- { screen numbers is selected, }
- { this short string will be }
- { displayed on the last help }
- { line, immediately before the }
- { help screen number. }
-
- Hercules : boolean = true; { This variable is used to in- }
- { dicate the presence of a Mono }
- { graphics adapter in the sys- }
- { tem (not necessarily Herc- }
- { ules). When true, the saved }
- { portion of the screen is }
- { saved in extra memory on the }
- { card, beginning at offset }
- { $1000, rather than in main }
- { memory. This storage will }
- { always take place for CGA }
- { cards, regardless of the }
- { value of this variable. Set }
- { this to true for EGA cards. }
-
- StartField : char = '>'; { Characters used to mark a }
- EndField : char = '<'; { field when selected for input }
-
- HelpFG : byte = 7; { Foreground color for the help }
- { windows. }
- HelpBG : byte = 0; { Background color for help. }
- BordFG : byte = 7; { Forground color for the help }
- { window border. }
- BordBG : byte = 0; { Border background color. }
- { Defaults are for monochrome }
- var
- TodaysDate : datetype;
- HelpFileName : string15; { Store here the name of your }
- { help file, before calling }
- { Help. }
-
- ScreenWidth : byte absolute $0040:$004A; { the screen width }
- { as set by mode. }
-
- screenlength : byte; { This variable is initialized }
- { by this unit to 25. }
-
- (************************************************************************
- * *
- * CHARSTRING *
- * *
- * This function returns a string of the character passed having a *
- * length equal to the Number passed. *
- * *
- ************************************************************************)
-
- function CharString (Character : char;
- Number : byte) : String;
-
-
- (************************************************************************
- * *
- * TRIMLENGTH *
- * *
- * This function returns the length of a string, not including *
- * trailing spaces or carriage returns. *
- * *
- ************************************************************************)
-
- function TrimLength (line : string) : byte;
-
-
- (************************************************************************
- * *
- * ALLCAPS *
- * *
- * This function returns a string identical to the string passed, *
- * except that all lower case letters are converted to upper case. *
- * *
- ************************************************************************)
-
- function AllCaps (CapsStr : String) : String;
-
-
- (*************************************************************************
- * *
- * LASTSPACE *
- * *
- * This procedure searches the 'Line' passed, backward, starting at *
- * 'SpacePos', for a space, comma, slash or hyphen. The position of *
- * the space character in the string is returned in 'SpacePos'. *
- * *
- *************************************************************************)
-
- procedure LastSpace ( Line : String;
- var SpacePos : byte);
-
-
- (*************************************************************************
- * *
- * HELP *
- * *
- * This procedure creates a bordered window of 5 lines on the top *
- * half of the screen if the current cursor location is in the bottom *
- * half, or vice-versa, then opens the file specified by HelpFileName *
- * in the current directory, reads a linked list of text records on *
- * to the heap, and then displays them in the help window. if more *
- * than 5 lines of help are available, the user can scoll or page *
- * the window, or use Home or End to go to the beginning or end of *
- * the help screen. RETurn or ESCape will restore the prior screen *
- * and in addition ESCape will set the variable Escape to true. If *
- * 'HelpNum' is zero, the routine will return with no response. *
- * *
- *************************************************************************)
-
- procedure Help (HelpNum : word);
-
-
- (*************************************************************************
- * *
- * MESSAGE *
- * *
- * This procedure prints the text passed on the bottom line of the *
- * currently active window. If 'Error' is true, 'ErrMsg' is set to *
- * treu, and if 'BeepOnError' is true it also beeps. *
- * *
- *************************************************************************)
-
- procedure Message (Error : boolean;
- text : string80);
-
-
- (************************************************************************
- * *
- * SHOWYESNO *
- * *
- * This procedure writes 'Yes' or 'No' on the screen at position *
- * (x,y) depending on whether the default passed is true or false. *
- * If 'flen' (field length) is less than 3, 'Y' or 'N' will be *
- * displayed. *
- * *
- ************************************************************************)
-
- procedure ShowYesNo (x, y, flen : byte;
- default : boolean);
-
-
- (*************************************************************************
- * *
- * DISPSTRING *
- * *
- * This procdure goes to position 'x', 'y' on the screen and dis- *
- * plays 'OutStr' in a field which is 'FldLnth' characters wide. *
- * All unused parts of the field are cleared. If 'RightJust' is *
- * true 'OutStr' is right justified in the field. *
- * *
- *************************************************************************)
-
- procedure DispString (x, y,
- FldLnth : byte;
- RightJust : boolean;
- OutStr : string80);
-
-
- (************************************************************************
- * *
- * DISPLAYWORDS *
- * *
- * This procedure displays a list of words from a linked list on *
- * the heap, on a single line beginning at 'X', 'Y'. If there are *
- * more words in the list than can be displayed on a single line, *
- * the procedure will display all possible and then print '[MORE]'. *
- * If the space character is included in 'ExtraChars' then each *
- * word (or phrase) will be separated by a comma and a space, *
- * otherwise they will be separated only by a space. *
- * *
- ************************************************************************)
-
- procedure DisplayWords (WordPtr : wordpointer;
- X, Y : integer;
- ExtraChars : setofchar);
-
-
- (*************************************************************************
- * *
- * ADDCOMMAS *
- * *
- * This procedure takes the string passed, 'NumStr', which should *
- * consist only of numerals, a decimal point, and a leading '+' or *
- * '-' and adds a comma every three characters in front of the right- *
- * most decimal point. *
- * *
- *************************************************************************)
-
- procedure AddCommas (var NumStr : string30);
-
-
- (*************************************************************************
- * *
- * DISPREAL *
- * *
- * This procedure displays a real number at position 'X', 'Y' in a *
- * field which is 'FldLnth' characters wide. Zeros are added or *
- * the number is truncated, as needed, to display 'Decimals' number *
- * of digits past the decimal point. Commas are added as needed. *
- * If RightJust is true, the number is right-justified in the field. *
- * *
- *************************************************************************)
-
- procedure DispReal (x, y,
- FldLnth,
- Decimals : byte;
- RightJust : boolean;
- OutReal : real);
-
-
- (*************************************************************************
- * *
- * DISPINTEGER *
- * *
- * This procedure displays any integer number at position 'X', 'Y' *
- * in a field which is 'FldLnth' characters wide. Commas are added *
- * as needed. If RightJust is true, the number is right-justified *
- * in the field. *
- * *
- *************************************************************************)
-
- procedure DispInteger (x, y,
- FldLnth : byte;
- RightJust : boolean;
- OutInt : longint);
-
-
- (*************************************************************************
- * *
- * DATETOSTR *
- * *
- * This function returns a date string from a variable of type *
- * 'datetype' according to a requested format. Format '0' is *
- * MM/DD/YYYY, format '1' is DD MON YYYY, and Format '2' is *
- * Month DD, YYYY. *
- * *
- *************************************************************************)
-
- function DateToStr (DateStr : datetype;
- format : byte) : string20;
-
-
- (*************************************************************************
- * *
- * MAKEFRACTION *
- * *
- * This function converts a the decimal part of a real number to a *
- * fraction, e.g. if the decimal portion is .25, .33, .50., .67, or *
- * .75 (as well as some others) the string returned will be a space *
- * and then 1/4, 1/3, 1/2, etc. as appropriate. If the number *
- * cannot be converted to a fraction the decimal part will be return *
- * as a decimal point followed by a two digit string. The function *
- * will convert everything within two one-hundredths of the target. *
- * *
- *************************************************************************)
-
- function MakeFraction (IOReal : real) : String5;
-
-
- (************************************************************************
- * *
- * GETCHAR *
- * *
- * This function repeatedly reads a character from the keyboard, *
- * until the character is in the set of acceptable characters. *
- * ESCape is always acceptable. If the pre-defined help key is *
- * pressed, the appropriate help message is displayed. When a *
- * valid key is pressed, it is returned. *
- * *
- ************************************************************************)
-
- function GetChar ( OKSet : setofchar;
- HelpNum : word) : char;
-
-
- (************************************************************************
- * *
- * GETYESNO *
- * *
- * This procedure goes to position 'x', 'y' on the screen and waits *
- * for a keyboard response of Y, N, or Ret. It returns true for *
- * yes, or false for no. If a Return or Escape is pressed it *
- * returns the value of the default. The input is displayed by *
- * ShowYesNo, so a field length must be passed. *
- * *
- ************************************************************************)
-
- function GetYesNo (x, y, flen : byte;
- HelpNum : word;
- default : boolean) : boolean;
-
-
- (************************************************************************
- * *
- * CORRECT *
- * *
- * This function goes to position (x,y) on the screen and asks if *
- * the above is correct. If the response is yes, the function *
- * returns true, otherwise it returns false. *
- * *
- ************************************************************************)
-
- function Correct (x, y, flen : byte;
- HelpNum : word;
- default : boolean) : boolean;
-
-
- (************************************************************************
- * *
- * EDITLINE *
- * *
- * This procedure allows editing of the 'Line' passed. The routine *
- * will first write the line at 'X', 'Y', clearing the remainder *
- * of the field. Only those characters included in OKSet will be *
- * accepted. The routine will end upon receipt of any character *
- * included in ExitSet or by pressing ESCape or RETurn, or when the *
- * cursor position in the line exceeds the field length. Pressing *
- * the Help key (usually F1, but can be changed) will display the *
- * help screen specified by 'HelpNum.' 'Cursor' contains the *
- * position of the cursor in the field, and can be used to start *
- * the editing at greater than position 1. If Upper is true, each *
- * character entered will be forced to upper case. If FieldIn is *
- * true, the procedure will not terminate when the 'Line' length *
- * becomes longer than the specified 'FldLnth', rather, 'Line' will *
- * be truncated to fit. In addition, pressing Ctrl-left arrow, *
- * Ctrl-right arrow, Ctrl-A or Ctrl-F will terminate the procedure. *
- * If FieldIn is false, these actions will not be taken, and in *
- * addition, the row and cursor numbers, and insert status will be *
- * displayed on the last line of the screen. The tab key (or ^I) *
- * will move the cursor to the next multiple of 5, and if 'InsertOn' *
- * is true, spaces will be added. Key will return the control *
- * character which caused the routine to terminate, or #1F if the *
- * cursor moved past the end of the field. *
- * *
- ************************************************************************)
-
- procedure EditLine (var Line : String90;
- X, Y,
- FldLnth : byte;
- OKSet,
- ExitSet : setofchar;
- HelpNum : word;
- var Cursor : byte;
- UpperC,
- FieldIn : Boolean;
- var control : char);
-
-
- (*************************************************************************
- * *
- * SELECTFIELD *
- * *
- * Calling this procedure will mark the field starting at 'X', 'Y' *
- * and having length 'FldLnth' with the characters stored in *
- * 'StartField' and 'EndField', or, if StartField is in the range *
- * 0 .. 8, will set the BackGround color to ORD (StartField), and *
- * the foreground color to ORD (EndField). The field will be cleared *
- * and set to the background color. Note that if characters are used *
- * to mark the field, they will be placed at X - 1 and X + FldLnth + *
- * 1, so X must never be less than 2 and X + FldLnth must not be *
- * allowed to exceed the screen width. If MarkField is false, the *
- * field will be cleared, but not marked. *
- * *
- *************************************************************************)
-
- procedure SelectField (x, y,
- FldLnth : byte;
- MarkField : boolean);
-
-
- (*************************************************************************
- * *
- * DESELECTFIELD *
- * *
- * This procedure will remove the markings left at 'X', 'Y' by *
- * 'SelectField', and restore the prior background color. If the *
- * field was marked by SelectField, be sure that MarkField is true. *
- * *
- *************************************************************************)
-
- procedure DeselectField (x, y,
- fldlnth : byte;
- MarkField : boolean);
-
-
- (*************************************************************************
- * *
- * GETFIELD *
- * *
- * This function will return a string input into a field at 'X', 'Y'. *
- * 'FldLnth' is the length of the field, 'MinLnth' is the minimum *
- * acceptable length for the input, 'StrtPos' is the starting posi- *
- * tion for the cursor, and 'HelpNum' is the number of the help *
- * screen associated with this field. If 'UpperCase' is true all *
- * input will be forced to upper case, and if 'RightJust' is true *
- * the input will be right justified in the field when the function *
- * returns. 'OKSet' contains the characters which are acceptable as *
- * input and 'MarkField' is true if you want the field marked. *
- * 'Contents' contains the string to be edited, if any, and 'Key' *
- * returns the control key which terminated the function; these *
- * keys are Up, Down, Right, Left, PgUp, PgDn, Home, EndKey, WdRt, *
- * WdLt, Ret and Esc (see the type declaration for control-key *
- * equivilencies). *
- * *
- *************************************************************************)
-
- function GetField ( x, y,
- FldLnth,
- MinLnth,
- StrtPos : byte;
- HelpNum : word;
- UpperCase,
- RightJust : boolean;
- OKSet : setofchar;
- MarkField : boolean;
- Contents : string;
- var control : char) : String;
-
-
- (*************************************************************************
- * *
- * GETLIST *
- * *
- * This routine gets or edits a words on a single line, which are *
- * contained on a linked list on the heap. Each word is marked as *
- * it is edited, and cannot exceed 25 characters. Only those *
- * characters contained in NameChars and ExtraChars are acceptable *
- * input. A comma or a space will end a word, as well as RETurn or *
- * ESCape, so long as either is NOT in ExtraChars. *
- * *
- *************************************************************************)
-
- procedure GetList ( x, y,
- WordLen : byte;
- HelpNum : word;
- UpperCase : boolean;
- ExtraChars : setofchar;
- var WordPtr : wordpointer;
- var control : char);
-
-
- (*************************************************************************
- * *
- * GETREAL *
- * *
- * This function inputs a real number in a manner similar to that of *
- * 'GetField.' 'Min' and 'Max' are the minimum and maximum accep- *
- * table values for this field, and 'Decimals' is the number of *
- * decimal places accepted. IOReal is the beginning value. *
- * *
- *************************************************************************)
-
- function GetReal ( X, Y,
- FldLnth : byte;
- HelpNum : word;
- Min, Max : real;
- Decimals : byte;
- RightJust,
- MarkField : boolean;
- IOReal : real;
- var Control : char) : real;
-
-
- (*************************************************************************
- * *
- * GETINTEGER *
- * *
- * This function inputs any integer number in a manner similar to *
- * that of 'GetField.' 'Min' and 'Max' are the minimum and maximum *
- * acceptable values for this field. IOInteger is the beginning *
- * value for the field. *
- * *
- *************************************************************************)
-
- function GetInteger ( X, Y,
- FldLnth : byte;
- Help : word;
- Min, Max : longint;
- RightJust,
- MarkField : boolean;
- IOInteger : longint;
- var Control : char) : longint;
-
-
- (*************************************************************************
- * *
- * GETDATESTR *
- * *
- * This function reads a date string in almost any format and con- *
- * verts to a value of type 'datetype.' 'Format' specifies how the *
- * date will be displayed when the function ends. If 'Precise' is *
- * true, approximate dates (dates containing question marks) will *
- * not be allowed, and if 'NoFuture' is true, dates beyond *
- *' 'TodaysDate' will not be allowed. 'DateStr' passes the default. *
- * *
- *************************************************************************)
-
- function GetDateStr ( X, Y,
- FldLnth,
- format : byte;
- helpNum : word;
- precise : boolean;
- Markfield : boolean;
- DateStr : datetype;
- var Control : char) : datetype;
-
-
- (*************************************************************************
- * *
- * GETFRACTION *
- * *
- * This function gets a string of numbers, which may contain a *
- * fraction, and converts it to a real number. IOReal passes the *
- * default, which is converted to a string containing a fraction for *
- * input, if possible. *
- * *
- *************************************************************************)
-
- function GetFraction ( X, Y : byte;
- HelpNum : word;
- RightJust,
- MarkField : boolean;
- IOReal : real;
- var Control : char) : real;
-
-
- (*************************************************************************
- * *
- * MENUOPTION *
- * *
- * This function goes to 'X', 'Y' and prints: *
- * *
- * 'Enter your selection > <, or press ESC to exit.' *
- * *
- * It then waits for the user to enter one of the characters included *
- * in 'Options', which is converted to upper case and returned, or *
- * ESCape if that key was pressed in response. *
- * *
- *************************************************************************)
-
- function MenuOption (x, y : byte;
- HelpNum : word;
- Options : setofchar ) : char;
-
-
-
- { FieldIO is shareware, which means that it, like most shareware, may
- be freely copied and distributed so long as no consideration is required
- for its distribution, except a copying and media charge not to exceed
- $3.00, including the cost of the means of distribution (i.e., diskette).
- Users who find the program of value to them should consider sending a
- donation to Pass-Key Software.
-
- Users sending a donation of $25.00 or more are registered, will
- receive notification of upgrades and modifications to this product, and
- are entitled to receive source code and future updates, upon request, for
- the cost of a diskette and postage. Non-registered users may not incor-
- porate this unit into any commercially distributed software, including
- shareware, while registered users may do so freely.
-
- FieldIO is a copyrighted program, and is protected by the laws of
- the United States and each of its several states, as well as interna-
- tional treaties and conventions. A licence is hereby granted to all
- persons to use this program according to the terms and restrictions con-
- tained herein. All programs which incorporate all or any part of this
- program must include the following phrase both in the source code and in
- any accompanying documentation:
-
- Portions of this program Copyright (c) 1988 by W. Lee Passey.
- This program is distributed as is, and by its use each person agrees
- to the terms and conditions of this license, and acknowledges that W. Lee
- Passey and Pass-Key Software have made no warranties, either express or
- implied, concerning the performance of this software, including warran-
- ties of merchantability or fitness for a particular purpose.
-
- Please send all comments, suggestions, information regarding pos-
- sible bugs, donations and registration information to:
-
- Pass-Key Software
- 119 MacArthur Ave.
- Salt Lake City, UT 84115or use your modem to call The Motherboard, (801) 485-7211, 8 data,
- 1 stop, no parity, 300/1200/2400 baud, 24 hours/day, 7 days/week (except
- when I'm using the computer).
- I am also looking for a job in the data processing field, and this
- unit is a good example of my programming skills. If any employers are
- interested in using me as an employee, please contact me in the same way.
-
- }