home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
database
/
litebar.zip
/
PROC.PRG
< prev
next >
Wrap
Text File
|
1991-08-08
|
73KB
|
1,846 lines
*-- PROGRAM.....: PROC.PRG
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer, (KENMAYER on ATBBS)
*-- Date........: 07/07/1991
*-- Notes.......: This is a procedure file I have been using for awhile,
*-- modified for the dUFLP and dHUNG standards on the Ashton-
*-- Tate Bulletin Board System (ATBBS). dUFLP is the dBASE Users
*-- Function Library Project. dHUNG is the dBASE HUNGarian
*-- notation (a modified version of the HUNGARIAN programming
*-- notation which can be found elsewhere on the ATBBS).
*--
*-- To use this procedure file in toto, the program must contain
*-- the line in it stating:
*-- SET PROCEDURE TO PROC
*-- To use any of the individual functions and/or procedures see
*-- the documentation for each function or procedure.
*-- Rev. History: This has gone through so many revisions, some of it being
*-- suggestions from users on ATBBS, and some in trying to set
*-- it up for dUFLP, that it's too much to go into here ... <g>
*-- Any procedures/functions here that were modified just for
*-- the dHUNG/dUFLP notations show "None" for Rev. History ...
*===============================================================================
PROCEDURE SetPrint
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/24/1991
*-- Notes.......: Used to set the the appropriate default settings.
*-- (Can be modified easily for other printers ...)
*-- If you want "letter quality" print on some printers,
*-- you can take the * out from the one line below. Note
*-- that some printer drivers don't have a "letter quality" mode,
*-- and dBASE will spit out an error message if you try to
*-- force it (by using _pquality). I use this routine for
*-- various systems, and only use _pquality for my dot matrix
*-- at home. Change the printer driver below to the one you
*-- are using.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do setprint
*-- Example.....: do setprint
*-- Returns.....: None
*-- Parameters..: None
*--------------------------------------------------------------------------
_pdriver = "HPLAS2I" && printer driver
_ppitch = "PICA" && printer pitch (10 CPI)
_box = .t. && make sure we can print boxes/line draw
_ploffset = 0 && page offset (left side) to 0
_lmargin = 0 && left margin (also set to 0)
_rmargin = 80 && right margin set to 80
_plength = 66 && page length
_peject = "NONE" && don't send extra blank pages . . .
* _pquality = .t. && set print quality to high -- not available
&& for some printers
RETURN
*-- EoP: SetPrint
PROCEDURE PrintErr
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/24/1991
*-- Notes.......: Used to display a printer error for STAND-ALONE
*-- systems. (The dBASE function PRINTSTATUS() doesn't work
*-- on a Network with Print Spoolers ...)
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: SHADOW (procedure in proc.prg)
*-- Called by...: Any
*-- Usage.......: do printerr
*-- Example.....: do setprint && if it hasn't been done
*-- if .not. printstatus()
*-- DO PRINTERR
*-- endif
*-- * or
*-- do while .not. printstatus() && my preference ... loop!
*-- DO PRINTERR
*-- enddo
*-- Returns.....: None
*-- Parameters..: None
*--------------------------------------------------------------------------
if iscolor() && if we're using a color monitor, use yellow on red
cColor = "RG+/R,RG+/R,RG+/R"
else && otherwise, use black on white
cColor = "N/W,N/W,N/W"
endif
define window wPErr from 7,15 to 16,57 double color &cColor
save screen to sPErr && store current screen
do shadow with 7,15,16,57 && shadow box!
activate window wPErr && here we go ..
cCursor=set("CURSOR") && save cursor setting
set cursor off && turn cursor off
&& display message
do center with 0,40,"",chr(7) + "*** PRINTER ERROR ***"
do center with 2,40,""," The printer is not ready. Please check:"
do center with 3,40,"","1) that the printer is ON, "
do center with 4,40,"","2) that the printer is ONLINE, and"
do center with 5,40,"","3) that the printer has paper. "
do center with 7,40,"","Press any key to continue . . ."
x=inkey(0) && wait for user to press a key ...
set cursor &cCursor && set cursor to original setting ...
deactivate window wPErr && cleanup
release window wPErr
restore screen from sPErr
release screen sPErr
RETURN
*-- EoP: PrintErr
PROCEDURE SetColor
*--------------------------------------------------------------------------
*-- Programmer..: Phil Steele
*-- Date........: 05/23/91
*-- Notes.......: Used to set the screen colors for a system. It
*-- checks to see if a color monitor is attached (ISCOLOR()),
*-- and sets system variables, that can be used in SET COLOR OF
*-- commands. You must define the memvars as PUBLIC, see Example
*-- below -- otherwise nothing will work.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain
*-- program) and commented a bit more, minor modifications by
*-- Ken Mayer (Kenmayer).
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do setcolor
*-- Example.....: in a menu or setup program:
*-- PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,;
*-- cl_entry,cl_stand,cl_menu,cl_warn
*-- DO setcolor
*-- by declaring the variables PUBLIC before calling SETCOLOR
*-- they should be globally available throughout, unless you
*-- use a CLEAR ALL or CLOSE ALL command ...
*-- Returns.....: None
*-- Parameters..: None
*--------------------------------------------------------------------------
if file("COLOR.MEM")
restore from Color.mem additive && if color.mem exists, restore from it
else && otherwise, create it
lC = iscolor() && remember -- foreground/background
cl_Blank = "n/n,n/n,n" && black on black on black ...
cl_Func = "n/w" && function keys (used in CLRSHOW)
* if iscolor() = true, define color, otherwise black/white
cl_Help = iif(lC,"n/g,g/n,n" , "w+/n,n/w,n") && help
cl_Data = iif(lC,"rg+/gb,gb/rg,n" , "w+/n,n/w,n") && data entry fields
cl_Error = iif(lC,"rg+/r,w/n,n" , "w/n,n/w,n") && error messages
cl_Entry = iif(lC,"n/w,w/n,n" , "n/w,w/n,n") && data entry??
cl_Stand = iif(lC,"w+/b,b/w,n" , "w+/n,n/w,n") && standard screen
cl_Menu = iif(lC,"rg+/b,b/w,n" , "w+/n,n/w,n") && menus
cl_Warn = iif(lC,"rg+/r,w/n,n" , "w/n,n/w,n") && warning messages
save to color all like cl_* && create COLOR.MEM
endif
*-- change current color settings to these ...
set color to &cl_stand && default
set color of fields to rg+/gb && yellow/cyan
set color of messages to rg+/gb && yellow/cyan
set color of box to rg+/n && yellow/black
RETURN
*-- EoP: SetColor
FUNCTION ExtrClr
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/24/1991
*-- Notes.......: Used to extract the first parameter of the MEMVARS
*-- created from SETCOLOR above. The SET COLOR OF commands can
*-- only use the first parameter.
*-- It is recommended that you run SetColor (above) first,
*-- although if you define your own color memvars, this will work
*-- just as well.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: extrclr(<cMemVar>)
*-- Example.....: set color of highlight to &extrclr(cl_stand)
*-- Returns.....: "W+/B"
*-- Parameters..: cMemVar = color memory variable to have colors extracted from
*--------------------------------------------------------------------------
parameters cMemVar
RETURN substr(cMemVar,1,(at(",",cMemVar)-1))
*-- EoF: ExtrClr
FUNCTION InvClr
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/23/1991
*-- Notes.......: Used to set an inverse color, using value(s) returned
*-- from extrclr above, or from a single color memvar.
*-- Inverted colors may give odd results -- RG+ (yellow) is
*-- not a background color, for example, and will appear as
*-- RG (brown) -- this may not be what you wanted ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: invclr(<cMemVar>)
*-- Example.....: set color of highlight to &invclr(extrclr(cl_stand))
*-- or
*-- x = extrclr(cl_stand)
*-- set color of highlight to &invclr(x)
*-- Returns.....: "B/W+"
*-- Parameters..: cMemVar = color variable containing colors to be inverted
*--------------------------------------------------------------------------
parameters cMemVar
cTemp1 = substr(cMemVar,1,(at("/",cMemVar)-1))
cTemp2 = substr(cMemVar,(at("/",cMemVar)+1),len(cMemVar))
RETURN cTemp2+"/"+cTemp1
*-- EoF: InvClr
PROCEDURE Open_Screen
*--------------------------------------------------------------------------
*-- Programmer..: Rick Price (Hammett)
*-- Date........: 05/24/1991
*-- Notes.......: Used to give a texture to the background of the screen
*-- I got this from Rick when he uploaded it as part of his
*-- original entry to a Color Contest on the ATBBS. It is
*-- kinda nice to have that texture on the screen, keeps it
*-- from being monotonous.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do open_screen
*-- Example.....: do open_screen
*-- Returns.....: None
*-- Parameters..: None
*--------------------------------------------------------------------------
clear
nRow=0
cBackdrp = chr(176) && chr(176) = "░", chr(177) = "▒", chr(178) = "▓"
do while nRow < 3
@nRow,0 to nRow+3,79 cBackdrp && fill this section of the screen
nHoldRow = nRow
nRow = nRow + 6
@nRow,0 to nRow+3,79 cBackdrp
nRow = nRow + 6
@nRow,0 to nRow+3,79 cBackdrp
nRow = nRow + 6
@nRow,0 to nRow+3,79 cBackdrp
nRow = nHoldRow + 1
enddo
@24,0 to 24,79 cBackdrp
RETURN
*-- EoP: OpenScreen
FUNCTION Do_Wait
*--------------------------------------------------------------------------
*-- Programmer..: Rick Price (Hammett)
*-- Date........: 05/24/91
*-- Notes.......: This function can replace the WAIT command with a message
*-- in the usual Message line. This is useful for situations
*-- where the user is used to messages at row 24 on the screen,
*-- and this will handle it. It uses the default message of
*-- "Press any key to continue ...", unless you pass your own
*-- message to it. If you want the default, use nul (""), other-
*-- wise dBASE will get annoyed.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Do_Wait("<cMessage>")
*-- Example.....: lc_wait = do_wait("message")
*-- Returns.....: numeric value of key pressed by user to exit Wait (inkey())
*-- Parameters..: cMessage = Message to display at bottom of screen
*--------------------------------------------------------------------------
parameters cMessage
cWaitCur = set("CURSOR") && save status of cursor
set cursor off
** If the passed parameter (message_to_display) is null, use a generic
** message.
cMessage = ;
iif(""=cMessage," Press any key to continue . . . ",cMessage)
* center/truncate message
nMesLen = len(cMessage) && get length of message
* if message length is greater than 80, truncate it to 80
cMessage = iif(nMesLen>80,LEFT(cMessage,80),cMessage)
nMesLen = len(cMessage) && reset if message was longer than 80
* center message on row 24 of screen
@24,int((80-nMesLen)/2) say cMessage
* return whatever key was pressed by user, in case you need it ...
cRetStr=chr(Inkey(0))
set cursor &cWaitCur && reset cursor state to what it was before ...
RETURN cRetStr
*-- EoF: Do_Wait
PROCEDURE JazClear
*--------------------------------------------------------------------------
*-- Programmer..: Rick Price (Hammett)
*-- Date........: 05/24/1991
*-- Notes.......: Used to clear the screen from the middle out --
*-- could be used with OpenScreen, above. I got this
*-- from Rick at the same time I got the other two routines
*-- above ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do jazclear
*-- Examples....: do jazclear
*-- Returns.....: None
*-- Parameters..: None
*--------------------------------------------------------------------------
nWinR1 = 0 && row 1
nWinR2 = 24 && row 2
nWinC1 = 0 && column 1
nWinC2 = 79 && column 2
nStep = 1 && amount to increment by
* set starting point
mnWinC1 = int((nWinC2-nWinC1)/2)+nWinC1
mnWinC2 = mnWinC1+1
mnWinR1 = int((nWinR2-nWinR1)/2)+nWinR1
mnWinR2 = mnWinR1+1
** Adjust step offset values: nColOff & nRowOff
** Vertical steps: nWinR1-nWinR1
nTmpAdjR = int((nWinR2 - nWinR1)/2)
nTmpAdjC = int((nWinC2 - nWinC1)/2)
nAdjRow = ;
iif(nTmpAdjC > nTmpAdjR, nTmpAdjR/nTmpAdjC,1) * nStep
nAdjCol = ;
iif(nTmpAdjR > nTmpAdjC, nTmpAdjC/nTmpAdjR,1) * nStep
ncolleft = nWinC1
ncolrite = nWinC2
nRowTop = nWinR1
nRowBot = nWinR2
nWinC1 = mnWinC1
nWinC2 = mnWinC2
nWinR1 = mnWinR1
nWinR2 = mnWinR2
do while (nWinC1#nColLeft .or. nWinC2#nColRite .or. ;
nWinR1 # nRowTop .or. nWinR2 # nRowBot)
* Adjust coordinates for the clear (moving out from the middle)
nWinR1 = ;
nWinR1-iif(nRowTop<nWinR1-nAdjRow,nAdjRow,nWinR1-nRowTop)
nWinR2 = ;
nWinR2+iif(nRowBot>nWinR2+nAdjRow,nAdjRow,nRowBot-nWinR2)
nWinC1 = ;
nWinC1-iif(nColLeft<nWinC1-nAdjCol,nAdjCol,nWinC1-nColLeft)
nWinC2 = ;
nWinC2+iif(nColRite>nWinC2+nAdjCol,nAdjCol,nColRite-nWinC2)
* Perform the clear
@nWinR1,nWinC1 clear to nWinR2,nWinC2
@nWinR1,nWinC1 to nWinR2,nWinC2
enddo
clear
RETURN
*-- EoP: JazClear
PROCEDURE Center
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/24/1991
*-- Notes.......: Centers text on the screen with @says
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: This and all other procedures/functions listed in this
*-- file attributed to Miriam Liskin came from "Liskin's
*-- Programming dBASE IV Book". Very good, worth the money.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>"
*-- Example.....: do center with 5,65,"RG+/GB","WARNING! This will blow up!"
*-- Note that the color field may be blank: ""
*-- Returns.....: None
*-- Parameters..: nLine = Line or Row for @/Say
*-- nWidth = Width of screen
*-- cColor = Colors to be used ("Forg/Back") (may be nul "", in
*-- order to use the default colors of window/screen)
*-- cText = Message to center on screen
*--------------------------------------------------------------------------
parameters nLine,nWidth,cColor,cText
nCol = (nWidth - len(cText)) /2
@nLine,nCol say cText color &cColor.
RETURN
*-- EoP: Center
FUNCTION Center2
*--------------------------------------------------------------------------
*-- Programmer..: Jeff Riedl (Student)
*-- Date........: 05/24/1991
*-- Notes.......: centers text, only two parameters and is a function.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: center2(<nWidth>,"<cText>")
*-- Example.....: @row,center2(80,"Center this text") say "Center this text"
*-- or
*-- @row,center2(80,"&MemVar") say MemVar
*-- Returns.....: centered text
*-- Parameters..: nWidth = Width of screen
*-- cText = Text to be centered
*--------------------------------------------------------------------------
parameters nWidth,cText
RETURN (nWidth - len(cText)) / 2
*-- EoF: Center2
FUNCTION Surround
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/24/1991
*-- Notes.......: Displays a message surrounded by a box anywhere on
*-- the screen
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 - Modified by Ken Mayer (Kenmayer) to a function
*-- from original procedure
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: surround(<nLine>,<nColumn>,"<cColor>","<cText>")
*-- Example.....: lc_Dummy = surround(5,12,"RG+/GB",;
*-- "Processing ... Do not Touch!")
*-- Returns.....: Nul/""
*-- Parameters..: nLine = Line to display "surrounded" message at
*-- nColumn = Column for same (X,Y coordinates for @SAY)
*-- cColor = Color variable/colors
*-- cText = Text to be displayed inside box
*--------------------------------------------------------------------------
parameters nLine,nColumn,cColor,cText
cText = " " + trim(cText) + " " && add spaces around text
@nLine-1,nColumn-1 to nLine+1,nColumn+len(cText) double;
color &cColor. && draw box
@nLine,nColumn say cText color &cColor. && disp. text
RETURN ""
*-- EoF: Surround
FUNCTION Message1
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/24/1991
*-- Notes.......: Displays a message, centered at whatever line you give,
*-- pauses until user presses a key.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 Modified by Ken Mayer (Kenmayer) from Miriam's
*-- procedure to function
*-- Calls.......: CENTER (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: message1(<nLine>,<nWidth>,"<cColor>","<cText>")
*-- Example.....: lc_Dummy = Message1(5,12,"RG+/GB","All Done.")
*-- Returns.....: numeric value of key pressed by user (cUser)
*-- Parameters..: nLine = Line to display message
*-- nWidth = Width of screen
*-- cColor = Colors for display
*-- cText = Text to be displayed.
*--------------------------------------------------------------------------
parameters nLine,nWidth,cColor,cText
@nLine,0
cCursor = set("CURSOR") && store current state of CURSOR
set cursor off && turn it off
do center with nLine,nWidth,cColor,cText
wait "" to cUser
set cursor &cCursor && set cursor to original state
@nLine,0 && erase line ...
RETURN cUser
*-- EoF: Message1
FUNCTION Message2
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Displays a message in a window, pauses for user to
*-- press key
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 - Modified by Ken Mayer (Kenmayer) to a function
*-- 04/29/1991 - Modified by Ken Mayer (Kenmayer) to add shadow
*-- Calls.......: SHADOW (procedure in PROC.PRG)
*-- CENTER (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: message2("<cText>","<cColor>")
*-- Example.....: lc_Dummy = message2("Finished Processing!",;
*-- "RG+/GB,,RG+/GB")
*-- Returns.....: numeric value of key pressed by user (cUser)
*-- Parameters..: cText = Text to be displayed in window
*-- cColor = Colors for window
*--------------------------------------------------------------------------
parameters cText,cColor
cCursor = set("CURSOR")
set cursor off
save screen to sMessage
define window wMessage from 10,10 to 14,70 double color &cColor.
do shadow with 10,10,14,70
activate window wMessage
do center with 1,60,"",cText
wait "" to cUser
set cursor &cCursor
deactivate window wMessage
release window wMessage
restore screen from sMessage
release screen sMessage
RETURN cUser
*-- EoF: Message2
FUNCTION Message3
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Displays a message in a window, pauses for user,
*-- will wrap a long message inside the window.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 - Modified by Ken Mayer (Kenmayer) to a function
*-- 04/29/1991 - Modified to Ken Mayer (Kenmayer) add shadow
*-- Calls.......: SHADOW (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: Message3("<cText>","<cColor>")
*-- Example.....: lc_Dummy = Message3("This is a long message that will be"+;
*-- "wrapped around inside the window.","rg+/gb,,rg+/gb")
*-- Returns.....: numeric value of key used to exit window (cUser)
*-- Parameters..: cText = Text to be displayed
*-- cColor = Colors for window
*--------------------------------------------------------------------------
parameters cText,cColor
nLines = int(len(cText) / 38) + 5 && set # of lines for window
cCursor = set("CURSOR")
set cursor off
save screen to sMessage
define window wMessage from 8,20 to 8+nLines,60 double color &cColor.
do shadow with 8,20,8+nLines,60
activate window wMessage
nLmargin = _lmargin
nRmargin = _rmargin
cAlignment = _alignment
lWrap = _wrap
_lmargin = 1
_rmargin = 38
_alignment = "CENTER"
_wrap = .t.
?cText
?
wait " Press any key to continue . . ." to cUser
_lmargin = nLmargin
_rmargin = nRmargin
_alignment = cAlignment
_wrap = lWrap
set cursor &cCursor
deactivate window wMessage
release window wMessage
restore screen from sMessage
release screen sMessage
RETURN cUser
*-- EoF: Message3
FUNCTION Message4
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Displays a 2-line message in a predefined window
*-- and pauses
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 - Modified by Ken Mayer (Kenmayer) to a function
*-- 04/29/1991 - Modified to Ken Mayer (Kenmayer) add shadow
*-- Calls.......: SHADOW (procedure in PROC.PRG)
*-- CENTER (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: message4("<cText1>","<cText2>","<cColor>")
*-- Example.....: lc_Dummy = message4("Finished processing.","There are ";
*-- +ltrim(str(reccount()))+" Records in this file.",;
*-- "rg+/rg,rg+/rg,rg+/rg")
*-- Returns.....: numeric value of key pressed by user to exit window (cUser)
*-- Parameters..: cText1 = First line of message
*-- cText2 = Second line of message
*-- cColor = Colors for window
*--------------------------------------------------------------------------
parameters cText1,cText2,cColor
cCursor = set("CURSOR")
set cursor off
save screen to sMessage
define window wMonitor from 10,10 to 17,70 double color &cColor.
do shadow with 10,10,17,70
activate window wMonitor
nLmargin = _lmargin
nRmargin = _rmargin
lWrap = _wrap
_lmargin = 1
_rmargin = 58
_wrap = .t.
do center with 1,58,"",cText1
do center with 2,58,"",cText2
do center with 4,58,"","Press any key to continue . . ."
wait "" to cUser
_lmargin = nLmargin
_rmargin = nRmargin
_wrap = lWrap
set cursor &cCursor
deactivate window wMonitor
release window wMonitor
restore screen from sMessage
release screen sMessage
RETURN cUser
*-- EoF: Message4
PROCEDURE Monitor
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Displays a status message to monitor a long-running
*-- operation that operates on multiple records . . .
*-- Should be used with MONITOROFF (below) to cleanup.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/29/1991 - Modified by Ken Mayer (Kenmayer) to add shadow
*-- Calls.......: SHADOW (procedure in PROC.PRG)
*-- CENTER (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: do monitor with "<cText>","<cColor>"
*-- Example.....: do monitor with "Processing REPORT.DBF","rg+/gb,rg+/gb,rg+/gb"
*-- ln_recnum = 0
*-- do while && (or SCAN)
*-- stuff -- process records
*-- ln_recnum = ln_recnum + 1
*-- @4,30 display ltrim(str(ln_recnum)) && current record
*-- && in window MONITOR
*-- enddo && (or endscan)
*-- do monitoroff && procedure to clean-up after this one
*-- Returns.....: None
*-- Parameters..: cText = Text to display
*-- cColor = Colors for window
*--------------------------------------------------------------------------
parameters cText,cColor
save screen to sMonitor
define window wMonitor From 10,10 to 18,70 double color &cColor.
do shadow with 10,10,18,70
activate window wMonitor
do center with 1,60,"",cText
do center with 2,60,"","Please do not interrupt"
@4,10 say "Working on record of " + ltrim(str(reccount(),5))
RETURN
*-- EoP: Monitor
PROCEDURE MonitorOff
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/23/1991
*-- Notes.......: Used to deal with ending routines for MONITOR
*-- procedure above.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Routine using MONITOR (procedure in PROC.PRG)
*-- Usage.......: do monitoroff
*-- Example.....: do monitoroff
*-- Returns.....: None
*-- Parameters..: None
*--------------------------------------------------------------------------
deactivate window wMonitor
release window wMonitor
restore screen from sMonitor
release screen sMonitor
RETURN
*-- EoP: MonitorOff
FUNCTION ScrnHead
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Displays a heading on the screen in a box 2
*-- spaces wider than the text, with a custom border (double
*-- line top, single the rest)
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 4/29/1991 - Modified by Ken Mayer (Kenmayer) to add shadow
*-- Calls.......: SHADOW (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: scrnhead("<cColor>","<cText>")
*-- Examples....: lc_Dummy = ScrnHead("rg+/gb","Print Financial Report")
*-- Returns.....: nul/""
*-- Parameters..: cColor = Colors to display box/text in
*-- cText = text to be displayed.
*--------------------------------------------------------------------------
parameters cColor,cText
cText = " "+trim(cText)+" " && ad spaces to left and right
cTextstart = (80-len(trim(cText)))/2
do shadow with 1,cTextstart-1,3,81-cTextstart
@1,cTextstart-1 to 3,81-cTextstart 205,196,179,179,213,184,192,217;
color &cColor. && display box
@2, cTextstart say cText color &cColor. && display text
RETURN ""
*-- EoF: ScrnHead
FUNCTION YesNo
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Asks a yes/no question in a dialog window/box
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
*-- 04/29/1991 - Modified to Ken Mayer add shadow
*-- 05/13/1991 - Modified to Ken Mayer remove need for extra
*-- procedures (YES/NO) that were used for returning
*-- values from Menu
*-- (suggested by Clinton L. Warren (VBCES on ATBBS))
*-- Calls.......: SHADOW (procedure in PROC.PRG)
*-- CENTER (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: yesno(<lAnswer>,"<cMess1>","<cMess2>","<cMess3>","<cColor>")
*-- Example.....: if YesNo(.t.,"Do You Really Wish To Delete?",;
*-- "This will destroy the data";
*-- "in this record.";
*-- "rg+/gb,n/w,rg+/gb")
*-- delete
*-- else
*-- skip
*-- endif
*--
*-- The middle set of colors should be different, as they
*-- will be the colors of the YES/NO selections ...
*-- Options may be blank by using nul values ("")
*-- Returns.....: .t./.f. depending on user's choice from menu
*-- Parameters..: lAnswer = default value (Yes or No) for menu
*-- cMess1 = First line of Message
*-- cMess2 = Second line of message
*-- cMess3 = Third line of message
*-- cColor = Colors for window/menu/box
*--------------------------------------------------------------------------
parameter lAnswer,cMess1,cMess2,cMess3,cColor
save screen to sYesno
define window wYesno from 8,20 to 15,60 double color &cColor.
define menu mYesno
define pad pYes of mYesno Prompt "[Yes]" at 5,10
define pad pNo of mYesno Prompt "[No]" at 5,25
on selection pad pYes of mYesno deactivate menu
on selection pad pNo of mYesno deactivate menu
do shadow with 8,20,15,60
activate window wYesno
nLmargin = _lmargin && store system values
nRmargin = _rmargin
lWrap = _wrap
_lmargin = 2 && set local values
_rmargin = 38
_wrap = .t.
do center with 0,38,"",cMess1 && center the text
do center with 2,38,"",cMess2
do center with 3,38,"",cMess3
if lAnswer
activate menu mYesno pad pYes
else
activate menu mYesno pad pNo
endif
_lmargin = nLmargin && reset system values
_rmargin = nRmargin
_wrap = lWrap
deactivate window wYesno
release window wYesno
restore screen from sYesno
release screen sYesno
release menu mYesno
RETURN iif(pad()="PYES",.t.,.f.)
*-- EoF: YesNo
FUNCTION ErrorMsg
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/23/1991
*-- Notes.......: Display an error message in a Window:
*-- ** ERROR [#] **
*--
*-- Message 1
*-- Message 2
*-- Press any key to continue ...
*--
*-- colors should be VIVID, since it's an error message.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: SHADOW (procedure in PROC.PRG)
*-- CENTER (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: ErrorMsg("<cErr>","<cMess1>","<cMess2>","<cColor>")
*-- Example.....: lc_Dummy = errormsg("3","This record","already exists!",;
*-- "rg+/r,rg+/r,rg+/r")
*-- where "errornum" is an error number or nul,
*-- message2 and 3 should be 36 characters or less ...
*-- Colors should include foreground/background,;
*-- foreground/background,foreground/background
*-- Returns.....: numeric value of keystroke user presses (cUser)
*-- Parameters..: cErr = Error # (can be blank, but use "" for blank)
*-- cMess1 = Error message line 1
*-- cMess2 = Error message line 2
*-- cColor = Colors for text/window/border
*--------------------------------------------------------------------------
parameters cErr,cMess1,cMess2,cColor
save screen to sErr
define window wErr from 8,20 to 15,60 double color &cColor.
do shadow with 8,20,15,60
activate window wErr
cCursor = set("CURSOR")
set cursor off
if len(trim(cErr)) > 0 && if there's an error number ...
do center with 0,38,"","** ERROR "+alltrim(cErr)+" **"
else && otherwise, don't display errornumber
do center with 0,38,"","** ERROR **"
endif
do center with 2,38,"",cMess1
do center with 3,38,"",cMess2
do center with 5,38,"","Press any key to continue ..."
cUser=inkey(0)
set cursor &cCursor
deactivate window wErr
release window wErr
restore screen from sErr
release screen sErr
RETURN cUser
*-- EoF: ErrorMsg
FUNCTION DateText
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Display date in format Month, day year (e.g., July 1,1991)
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: DateText(<dDate>)
*-- Example.....: ? datetext(date())
*-- Returns.....: July 1, 1991
*-- Parameters..: dDate = date to be converted
*--------------------------------------------------------------------------
parameters dDate
RETURN CMONTH(dDate)+" "+ltrim(str(day(dDate),2))+", "+;
str(year(dDate),4)
*-- EoF: DateText
FUNCTION DateText2
*--------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/23/1991
*-- Notes.......: Display date in format day-of-week, Month day, year
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: DateText2(<dDate>)
*-- Example.....: ? DateText2(date())
*-- Returns.....: Thursday, July 1, 1991
*-- Parameters..: dDate = date to be converted
*--------------------------------------------------------------------------
parameters dDate
RETURN CDOW(dDate)+", "+cmonth(dDate)+" "+;
ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
*-- EoF: DateText2
FUNCTION IsUnique
*--------------------------------------------------------------------------
*-- Programmer..: Clinton L. Warren (VBCES)
*-- Date........: 07/23/1991
*-- Notes.......: Checks to see if an index key already exists in the current
*-- selected database. This function was inspired by Tom
*-- Woodward's Chk4Dup UDF.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: May 15, 1991 Version 1.1 Added check for zero record database
*-- May 7, 1991 Version 1.0 Initial 'release'.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsUnique(<xValue>,<cOrder>)
*-- Example.....: @x,y SAY "SSN: " GET SSN PICTURE "999-99-9999";
*-- valid required IsUnique(SSN, SSN);
*-- message "Enter a new SSN";
*-- error chr(7)+"SSN must be unique!"
*-- Returns.....: .T./.F.
*-- Parameters..: xValue = Value (any non-memo type) to check for uniqueness
*-- cOrder = MDX Tag used to order the database. Must be set for
*-- field being checked.
*--------------------------------------------------------------------------
parameters xValue, cOrder
nRecNo = recno() && store current record number
nRecCnt = reccount() && count records in database
if nRecCnt = 0 && empty database, cValue MUST be unique
return .t.
endif
cSetNear = set('NEAR') && store status of NEAR flag
set near off && set it off
c_SetDel = set('DELETE') && store status of DELETE
set delete on && Delete must be ON for this to work
lIsDeleted = deleted() && is current record deleted?
delete && set delete flag for current record
cSetOrder = order() && store current MDX tag
set order to (cOrder) && set tag to that sent to function
if seek(xValue) && does it exist already?
lIsUnique = .f. && if so, it's not unique
else && otherwise,
lIsUnique = .t. && it is.
endif
set order to (cSetOrder) && restore changed settings to original settings
set delete &cSetDel
set near &cSetNear
if nRecNo > nRecCnt && if called during an append
go bottom && goto the bottom of the database,
skip 1 && plus one record (the new one)
else
go nRecNo && otherwise, goto the current record number
endif
if .not. lIsDeleted && was record 'deleted' before?
recall && if not, undelete it ... (turn flag off)
endif
RETURN (lIsUnique)
*-- EoF: IsUnique
FUNCTION Proper
*------------------------------------------------------------------------------
*-- Programmer..: Clinton L. Warren (VBCES/CLW)
*-- Date........: 07/10/1991
*-- Notes.......: Returns cBaseStr converted to proper case. Converts
*-- : "Mc", "Mac", and "'s" as special cases. Inspired by
*-- : A-T's CCB Proper function. cBaseStr isn't modified.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 07/10/1991 1.0 - Original version (VBCES/CLW)
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Proper(<cArg>)
*-- Example.....: Proper("mcdonald's") returns "McDonald's"
*-- Returns.....: Propertized string (e.g. "Test String")
*-- Parameters..: cArg = String to be propertized
*------------------------------------------------------------------------------
PARAMETERS cBaseStr
private nPos, cDeli, cWrkStr
cWrkStr = lower(cBaseStr) + ' ' && space necessary for 's process
nPos = at('mc', cWrkStr) && "Mc" handling
do while nPos # 0
cWrkStr = stuff(cWrkStr, nPos, 3, upper(substr(cWrkStr, nPos, 1)) ;
+ lower(substr(cWrkStr, nPos + 1, 1)) ;
+ upper(substr(cWrkStr, nPos + 2, 1)))
nPos = at('mc', cWrkStr)
enddo
nPos = at('mac', cWrkStr) && "Mac" handling
do while nPos # 0
cWrkStr = stuff(cWrkStr, nPos, 4, upper(substr(cWrkStr, nPos, 1)) ;
+ lower(substr(cWrkStr, nPos + 1, 2)) ;
+ upper(substr(cWrkStr, nPos + 3, 1)))
nPos = at('mac', cWrkStr)
enddo
cWrkStr = stuff(cWrkStr, 1, 1, upper(substr(cWrkStr, 1, 1)))
nPos = 2
cDeli = [ -.'"\/`] && standard delimiters
do while nPos <= len(cWrkStr) && 'routine' processing
if substr(cWrkStr,nPos-1,1) $ cDeli
cWrkStr = stuff(cWrkStr, nPos, 1, upper(substr(cWrkStr,nPos,1)))
endif
nPos = nPos + 1
enddo
nPos = at("'S ", cWrkStr) && 's processing
do while nPos # 0
cWrkStr = stuff(cWrkStr, nPos, 2, lower(substr(cWrkStr, nPos, 2)))
nPos = at('mac', cWrkStr)
enddo
RETURN (cWrkStr)
*-- EoF: Proper()
FUNCTION AllTrim
*--------------------------------------------------------------------------
*-- Programmer..: Phil Steele (from PCSDEMO.PRG -- Public Domain)
*-- Date........: 5/23/1991
*-- Notes.......: Complete trims edges of field (left and right)
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: alltrim(<cString>)
*-- Example.....: ? alltrim(" Test String ")
*-- Returns.....: Trimmed string, i.e.:"Test String"
*-- Parameters..: cString = string to be trimmed
*--------------------------------------------------------------------------
parameters cString
RETURN ltrim(rtrim(cString))
*-- EoF: AllTrim
PROCEDURE Shadow
*--------------------------------------------------------------------------
*-- Programmer..: Ashton-Tate
*-- Date........: 5/23/1991
*-- Notes.......: Creates a shadow for a window (taken from the dBASE IV
*-- picklist functions)
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do shadow with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
*-- Example.....: save screen to sc_Main
*-- define window w_Error from 5,15 to 15,65 double color;
*-- rg+/r,rg+/r,rg+/r
*-- do shadow with 5,15,15,65
*-- activate window W_Error
*-- && perform actions in window
*-- deactivate window W_Error
*-- release window W_Error
*-- restore screen from sc_Main
*-- release screen sc_Main
*-- Returns.....: None
*-- Parameters..: nULRow = Upper Left Row position
*-- nULCol = Upper Left Column position (x,y)
*-- nBRRow = Bottom Right Row position
*-- nBRCol = Bottom Right Column position (x2,y2)
*--------------------------------------------------------------------------
parameters nULRow,nULCol,nBRRow,nBRCOL
nTempRow = nBRRow+1
nTempCol = nBRCol+2
nIncRow = 1
nIncCol = (nBRCol-nULCol) / (nBRRow-nULRow)
do while nTempRow <> nULRow .or. nTempCol <> nULCol+2
@ nTempRow,nTempCol fill to nBRRow+1,nBRCol+2 color n+/n
nTempRow = iif(nTempRow<>nULRow,nTempRow - nIncRow,nTempRow)
nTempCol = iif(nTempCol<>nULCol+2,nTempCol - nIncCol,nTempCol)
nTempCol = iif(nTempCol<nULCol+2,nULCol+2,nTempCol)
enddo
RETURN
*-- EoP: Shadow
PROCEDURE FullWin
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/23/91
*-- Notes.......: Overlays menus or another screen with a full window,
*-- so that processing is done in the window, and one can return
*-- directly to the menus, without redrawing screen and such.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do fullwin with <cColor>,<cWinName>,<cScreen>
*-- Example.....: do fullwin with "w+/b","w_Edit","sc_Main"
*-- * perform whatever actions are needed in the window
*-- deactivate window w_Edit
*-- release window w_Edit
*-- restore screen from sc_Main
*-- release screen sc_Main
*-- Returns.....: None
*-- Parameters..: cColor = Colors for window
*-- cWinName = Name of window
*-- cScreen = Name of screen
*--------------------------------------------------------------------------
parameters cColor,cWinName,sScreen
define window &cWinName from 0,0 to 23,79 none color &cColor.
save screen to &sScreen.
activate window &cWinName.
RETURN
*-- EoP: FullWin
FUNCTION DosRun
*--------------------------------------------------------------------------
*-- Programmer..: Michael P. Dean (Ashton-Tate)
*-- Date........: 05/23/1991
*-- Notes.......: A routine to run a DOS program, checks to see if a
*-- window is active -- if so, it avoids the inevitable
*-- "Press any key to continue" and the subsequent messing
*-- up of the screen display.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Pulled from A-T BBS
*-- 05/13/1991 - modified by Ken Mayer (Kenmayer) to use the DBASE
*-- RUN() function, rather than the ! or RUN commands,
*-- which allows the return of DOS exit codes ... (suggested
*-- by Clinton L. Warren (VBCES).)
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: DosRun(<cCmd>)
*-- Example.....: lc_dummy = dosrun("DIR /W /P")
*-- * or
*-- lc_dummy = dosrun(memvar) && where memvar contains dos
*-- && command and parameters ...
*-- Returns.....: NUMERIC value of the DOS exit code (nRun)
*-- Parameters..: cCmd = Command (and parameters) to be executed
*--------------------------------------------------------------------------
parameter cCmd
wWindow = window() && grab window name of current window
if len(trim(wWindow)) > 0 && if there's a window,
deactivate window &wWindow && deactivate it
endif
set console off && don't display to screen
nRun = run("&cCmd") && place DOS exit code in NRUN
set console on && ok, display to screen
if len(trim(wWindow)) > 0 && if there's a window,
activate window &wWindow && reactivate it
endif
RETURN nRun
*-- EoF: DosRun
*-------------------------------------------------------------------------------
*-- The next four functions are used for FRPGs (Fantasy Role-Playing Games)
*-------------------------------------------------------------------------------
FUNCTION Dice
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 05/23/1991
*-- Notes.......: A small function used to determine a random number from
*-- 1 to x. Used for gaming purposes.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any/MultDice() (Function in PROC.PRG)
*-- Usage.......: Dice(<nSides>)
*-- Example.....: ln_val = Dice(4)
*-- Returns.....: Random # between 1 and <nSides>
*-- Parameters..: nSides = # of sides of die to be cast ... (RPG dice
*-- include 4, 6 (standard), 8, 10, 12, 20, 100 ...
*--------------------------------------------------------------------------
parameters nSides
nSeed = (val(substr(time(),1,2))+val(substr(time(),4,2))+;
val(substr(time(),7,2))) * val(substr(time(),7,2))
RETURN int(rand(nSeed) * nSides) + 1
*-- EoF: Dice
FUNCTION MultDice
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Kenmayer)
*-- Date........: 06/12/1991
*-- Notes.......: Function like above, used to determine a random #,
*-- but for multiple dice, of x# of sides.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Originally this called DICE for each iteration, but it
*-- turned out that calling that routine more than once
*-- was resetting the randomizer seed to a similar or same
*-- value, and we got (quite often) the exact same number
*-- for each iteration. SO, now this routine calls DICE once,
*-- which sets the seed, and if we want more than one die,
*-- we loop and call RAND without a new seed. It works.
*-- Calls.......: DICE() (Function in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: MultDice(<nNum>,<nSides>)
*-- Example.....: ln_val = MultDice(3,6)
*-- Returns.....: Random value of 1 to x (x being number of sides),
*-- for each iteration (nNum), totalled. For example,
*-- value returned would be the total of 3 six-sided die
*-- rolled, the number would be anywhere from 3 to 18.
*-- Parameters..: nNum = Number of dice to be "rolled"
*-- nSides = # of sides to the dice (see Dice() above)
*--------------------------------------------------------------------------
parameters nNum,nSides
nTotal = dice(nSides) && call DICE and set RAND seed
nCount = 1 && set counter
do while nCount < nNum && loop for number of dice
nNewval = int(rand() * nSides) + 1 && get new random value
nTotal = nTotal + nNewval && add to total
nCount = nCount + 1 && increment counter
enddo
RETURN nTotal
*-- EoF: MultDice
FUNCTION ValiDice
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (KenMayer)
*-- Date........: 07/09/1991
*-- Notes.......: Used to ask user for input of a number within a range
*-- based on gaming dice. Programmer supplies # of dice,
*-- and number of sides to function, it returns the input
*-- from the user (and only allows valid input).
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: SHADOW (procedure in PROC.PRG)
*-- CENTER (procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: ValiDice(<nNum>,<nDice>,"<cMessage>","<cColor>")
*-- Example.....: replace STRENGTH with ValiDice(3,6,"Strength",;
*-- "rg+/gb,w/n,rg+/gb") && 3 6-sided
*-- Returns.....: Valid user input
*-- Parameters..: nNum = Number of dice
*-- nSides = Number of sides
*-- cMessage = Message for line 0
*-- cColor = Colors for window
*--------------------------------------------------------------------------
PARAMETERS nNum, nDice, cMessage, cColor
save screen to sDice
define window wDice from 8,20 to 14,60 double color &cColor
do shadow with 8,20,14,60
activate window wDice
nUpper = nNum * nDice && upper limit
do center with 0,40,"","&cMessage"
do center with 1,40,"","Enter a value from "+ltrim(str(nNum))+" to "+;
ltrim(str(nUpper))
do center with 2,40,"","("+ltrim(str(nNum))+"d"+ltrim(str(nDice))+")"
nUser = 0
@4,18 get nUser picture "999" valid required nUser => nNum .and.;
nUser =< nUpper;
error chr(7)+"Enter a valid number!"
read
deactivate window wDice
release window wDice
restore screen from sDice
release screen sDice
RETURN nUser
*-- EoF: ValiDice
FUNCTION DiceChoose
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer
*-- Date........: 07/09/1991
*-- Notes.......: This is another FRPG routine -- It is used to give the
*-- user a choice of three die roles. The computer will
*-- randomly generate a die roll three times so the user
*-- has a choice. It uses DICE (above) to do so.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: MULTDICE() (Function in PROC.PRG)
*-- DICE() (Function in PROC.PRG)
*-- SHADOW (Procedure in PROC.PRG)
*-- CENTER (Procedure in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: DiceChoose(<nNum>,<nSides>,"<nMessage>","<cColor>")
*-- Example.....: replace STRENGTH with DiceChoose(3,6,;
*-- "To determine your character's Strength",;
*-- "rg+/gb,w/n,rg+/gb")
*-- Returns.....: The value of one of the choices displayed for the user,
*-- which will be a value from nNum to nNum*nSides + nNum+nPlus.
*-- Parameters..: nNum = number of dice to be rolled
*-- nSides = number of sides for each dice
*-- cMessage = Message to be displayed at line 0 (max 40 Char)
*-- cColor = Colors for the window
*--------------------------------------------------------------------------
PARAMETERS nNum, nSides, cMessage, cColor
*-- here we determine the three values for the user (roll the dice) --
*-- The problem with using MULTDICE function above for all three values, is
*-- that it calls DICE each time, which resets the random number table,
*-- and will give the exact same value for each of the three below.
*-- By copying the logic from MultDice() for the second two values,
*-- we only call DICE once, the values should all be random, instead of
*-- the same values (from the same random # table).
*-- value 1 -- use MultDice above for this one
nVal1 = MultDice(nNum,nSides) && call MULTDICE and set RAND # Table
*-- value 2 -- DON'T use MultDice, but use the same logic ...
nVal2 = 0 && init nVal2
nCount = 0 && set counter
do while nCount < nNum && loop for number of dice
nNewVal = int(rand() * nSides) + 1 && get new random value
nVal2 = nVal2 + nNewval && add to total
nCount = nCount + 1 && increment counter
enddo
*-- value 3 -- same as value 2
nVal3 = 0 && init nVal3
nCount = 0 && set counter
do while nCount < nNum && loop for number of dice
nNewVal = int(rand() * nSides) + 1 && get new random value
nVal3 = nVal3 + nNewval && add to total
nCount = nCount + 1 && increment counter
enddo
*-- now we have the three values we need, define windows/menu ...
define window wDice from 8,20 to 17,60 double color &cColor
save screen to sDice
define menu mDice && as it says, define the menu
define pad pChoice1 of mDice prompt ltrim(str(nVal1)) at 3,18
define pad pChoice2 of mDice prompt ltrim(str(nVal2)) at 4,18
define pad pChoice3 of mDice prompt ltrim(str(nVal3)) at 5,18
on selection pad pChoice1 of mDice deactivate menu
on selection pad pChoice2 of mDice deactivate menu
on selection pad pChoice3 of mDice deactivate menu
*-- activate it all for user ...
do shadow with 8,20,17,60 && display shadow
activate window wDice && startup the window
*-- display info in Window
do center with 0,40,"","&cMessage"
do center with 1,40,"","Choose a value from below:"
@3,15 say "1)"
@4,15 say "2)"
@5,15 say "3)"
do center with 7,40,"","Use Arrow keys, <Enter> to choose"
activate menu mDice && startup menu
do case && determine value to be returned
case pad() = "PCHOICE1"
nUser = nVal1
case pad() = "PCHOICE2"
nUser = nVal2
case pad() = "PCHOICE3"
nUser = nVal3
endcase
*-- cleanup
release menu mDice
deactivate window wDice
release window wDice
restore screen from sDice
release screen sDice
RETURN nUser
*-- EoF: DiceChoose
*--------------------------------------------------------------------------
*-- These next two are ones I created for the SCA (Society for Creative
*-- Anachronism) -- they deal with SCA dates, which start at May 1, 1966.
*-- One goes from SCA dates to Real dates (i.e., 05/01/66 versus May 1, AS I)
*-- and the other goes back to SCA dates from real dates ...
*--------------------------------------------------------------------------
PROCEDURE SCA_Real
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Hirsch von Henford)
*-- Date........: 07/23/1991
*-- Notes.......: This procedure was designed to handle data entered into
*-- the Order of Precedence of the Principality of the Mists.
*-- The problem is, my usual sources of data give only SCA
*-- dates, and in order to sort properly, I need real dates.
*-- This procedure will handle it, and goes hand-in-hand with
*-- the function Real_SCA, to translate real dates to SCA
*-- dates ... This procedure assumes that you have set the
*-- F1 Key (see Example below). If you use a different F key,
*-- you will want to modify the ON KEY LABEL commands ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 07/29/1991 -- modified it to stuff a character directly into
*-- a date field (was having to do a CTOD in the program),
*-- and added use of ESC to escape out, instead of killing
*-- the procedure and the program calling it ...
*-- Calls.......: Center (Procedure in PROC.PRG)
*-- Shadow (Procedure in PROC.PRG)
*-- Arabic() (Function in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: do SCA_Real
*-- Example.....: on key label f1 do sca_real
*-- store {} to t_date && initialize as a date
*-- && or you could STORE datefield to t_date
*-- && if you have a date field ...
*-- clear
*-- @5,10 say "Enter a date:" get t_date;
*-- message "Press <F1> to convert from SCA date to real date"
*-- read
*-- on key label f1 && clear out that command ...
*-- Returns.....: real date, forced into field ...
*-- Parameters..: None
*--------------------------------------------------------------------------
cEscape = set("ESCAPE")
set escape off && so we can handle the Escape Key
cExact = set("EXACT")
set exact on && VERY important ...
on key label F1 ?? chr(7) && make it beep, rather than call this procedure
&& again, which causes wierdnesses ...
*-- first let's popup a window to ask for the information ...
save screen to sDate
define window wDate from 8,20 to 15,60 color rg+/gb,n/g,rg+/gb
do shadow with 8,20,15,60
activate window wDate
*-- set the memvars ...
cYear = space(8)
cMonth = space(3)
cDay = space(2)
do center with 0,40,"","Enter SCA Date below:"
do while .t.
@2,14 say "Month: " get cMonth ;
picture "@M JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC";
message "Enter first letter of month, <Space> to scroll through, "+;
"<Enter> to choose" color rg+/gb,n/g
@3,14 say " Day: " get cDay picture "99";
message "Enter 2 digits for day of the month, if blank will assume 15";
color rg+/gb,n/g
@4,14 say " Year: " get cYear picture "!!!!!!!!" ;
message "Enter year in AS roman numeral format";
valid required len(trim(cYear)) > 0;
error chr(7)+"This is no good without a year ..." color rg+/gb,n/g
read
if lastkey() = 27 && if user wants out by pressing <Esc>
deactivate window wDate
release window wDate
restore screen from sDate
release screen sDate
set escape &cEscape
set exact &cExact
on key label F1 do SCA_Real && reset it ...
return
endif
if lastkey() < 0 && function key F1 through Shift F9 was pressed
?? chr(7) && beep at user
loop && don't let 'em get away with that -- try again
endif
*-- check for valid roman numerals
cYear = trim(cYear) && trim it
nYearLen = len(cYear) && get length
nCount = 0
do while nCount < nYearLen && loop through length of year
nCount = nCount + 1 && increment
if .not. substr(cYear,nCount,1) $ "IVXLC" && if it's not here
do center with 5,40,"rg+/r","** ERROR -- Invalid Year **"
lError = .t. && set error flag
exit && exit internal loop
else
lError = .f. && make sure this is false
endif
enddo && end of internal loop
if lError && if error,
loop && go back ...
endif
@5,0 clear && clear out any error message ...
do center with 5,40,"rg+/r","Converting Date ..."
*-- First (and most important) is conversion of the year
nYear = Arabic(cYear)
*-- AS Years start at May ... if the month for a specific year is
*-- Jan through April it's part of the next "real" year ...
if cMonth = "JAN" .or. cMonth = "FEB" .or. cMonth = "MAR" .or.;
cMonth = "APR"
nYear = nYear + 1
endif
nYear = nYear + 65 && SCA dates start at 66 ...
if nYear > 99 && this thing doesn't handle turn of the century
@5,0 clear
do center with 5,40,"rg+/r","No dates past XXXIV, please"
loop
endif
*-- set numeric value of month ...
do case
case cMonth = "JAN"
nMonth = 1
case cMonth = "FEB"
nMonth = 2
case cMonth = "MAR"
nMonth = 3
case cMonth = "APR"
nMonth = 4
case cMonth = "MAY"
nMonth = 5
case cMonth = "JUN"
nMonth = 6
case cMonth = "JUL"
nMonth = 7
case cMonth = "AUG"
nMonth = 8
case cMonth = "SEP"
nMonth = 9
case cMonth = "OCT"
nMonth = 10
case cMonth = "NOV"
nMonth = 11
case cMonth = "DEC"
nMonth = 12
endcase
*-- if the day field is empty, assume the middle of the month, so we
*-- have SOMETHING to go by ...
if len(alltrim(cDay)) = 0
nDay = 15
else
nDay = val(cDay)
endif
*-- Check for valid day of the month ...
if nDay > 29 .and. nMonth = 2 .or. (nDay = 31 .and. (nMonth = 4 .or.;
nMonth = 6 .or. nMonth = 9 .or. nMonth = 11))
do center with 5,40,"rg+/r",chr(7)+"INVALID DATE -- Try again ..."
loop
endif
exit && out of loop -- if here, we're done
enddo && end of loop
*-- Convert it
cDate = transform(nMonth,"@L 99")+transform(nDay,"@L 99")+;
transform(nYear,"@L 99")
*-- force this 'character' date into the date field on the screen ...
keyboard cDate clear && put it into the field, and clear out
&& keyboard buffer first ...
*-- deal with cleanup ...
deac wind wDate
release wind wDate
restore screen from sDate
release screen sDate
set escape &cEscape
set exact &cExact
on key label F1 do SCA_Real && reset for user
RETURN
*-- EoP: SCA_Real
FUNCTION Real_SCA
*--------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (Hirsch von Henford)
*-- Date........: 07/23/1991
*-- Notes.......: This procedure was designed to handle data entered into
*-- the Order of Precedence of the Principality of the Mists.
*-- For the purpose of printing the Order of Precedence, it
*-- is necessary to convert real dates to SCA dates. I needed
*-- to store the data as real dates, but I want it to print with
*-- SCA dates ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: Roman() (Function in PROC.PRG)
*-- Called by...: Any
*-- Usage.......: Real_SCA(<dDate>)
*-- Example.....: @nLine,25 say Real_SCA(CA) && print SCA date for Corolla
*-- && Aulica
*-- Returns.....: SCA Date based on dDate
*-- Parameters..: dDate = date to be converted
*--------------------------------------------------------------------------
PARAMETERS dDate && a real date, to be converted to an SCA date ...
nYear = year(dDate) - 1900 && remove the century
nMonth = month(dDate)
cMonth = substr(cmonth(dDate),1,3) && grab only first three characters
cDay = ltrim(str(day(dDate))) && convert day to character
*-- First (and most important) is conversion of the year
*-- this is set to the turn of the century ... (AS XXXV)
*-- AS Years start at May ... if the month for a specific year is
*-- Jan through April it's part of the previous SCA year
*-- (April '67 = April AS I, not II)
if nMonth < 5
nYear = nYear - 1
endif
nYear = nYear - 65 && SCA dates start at 66
cYear = Roman(nYear)
RETURN cMonth+" "+cDay+", "+"AS "+cYear
*-- EoF: Real_SCA
FUNCTION Roman
*-------------------------------------------------------------------------------
*-- Programmer..: Nick Carlin
*-- Date........: 04/13/1988
*-- Notes.......: A function designed to return a Roman Numeral based on
*-- an Arabic Numeral input ...
*-- Written for.: dBASE III+
*-- Rev. History: 07/25/1991 -- Modified by Ken Mayer for 1) dBASE IV, 1.1,
*-- 2) updated to a function, and 3) the procedure
*-- GetRoman was done away with (combined into the
*-- function).
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Roman(<nArabic>)
*-- Example.....: ? Roman(32)
*-- Returns.....: Roman Numeral (character string) equivalent of Arabic numeral
*-- passed to it. In example: XXXII
*-- Parameters..: nArabic = Arabic number to be converted to Roman
*-------------------------------------------------------------------------------
parameters nArabic
private nCounter,nValue
cRoman = "" && this is the returned value
nCounter = 0 && init counter
do while nCounter < 4 && loop four times, once for thousands, once
&& four hundreds, tens and singles ...
nCounter = nCounter + 1 && increment counter
do case && determine roman numerals to use
case nCounter = 1 && first time through the loop
nDiv = 1000 && divide by 1000
cSmall = "M" && smallest value
cMid = "W" && next up ...
cBig = "Y" && largest passed with this ... 10,000s
case nCounter = 2
nDiv = 100
cSmall = "C"
cMid = "D"
cBig = "M"
case nCounter = 3
nDiv = 10
cSmall = "X"
cMid = "L"
cBig = "C"
case nCounter = 4
nDiv = 1
cSmall = "I"
cMid = "V"
cBig = "X"
endcase
nValue = mod(int(nArabic/nDiv),10)
do case
case nValue = 0
&& do nothing
case nValue = 1
cRoman = cRoman + cSmall && 1 = I
case nValue = 2
cRoman = cRoman + cSmall + cSmall && 2 = II
case nValue = 3
cRoman = cRoman + cSmall + cSmall + cSmall && 3 = III
case nValue = 4
cRoman = cRoman + cSmall + cMid && 4 = IV
case nValue = 5
cRoman = cRoman + cMid && 5 = V
case nValue = 6
cRoman = cRoman + cMid + cSmall && 6 = VI
case nValue = 7
cRoman = cRoman + cMid + cSmall + cSmall && 7 = VII
case nValue = 8
cRoman = cRoman + cMid + cSmall + cSmall + cSmall && 8 = VIII
case nValue = 9
cRoman = cRoman + cSmall + cBig && 9 = IX
endcase
enddo && while nCounter < 4
RETURN cRoman
*-- EoF: Roman()
FUNCTION Arabic
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer
*-- Date........: 07/25/1991
*-- Notes.......: This function converts a Roman Numeral to an arabic one.
*-- It parses the roman numeral into an array, and checks each
*-- character ... if the previous character causes the value to
*-- subtract (for example, IX = 9, not 10) we subtract that value,
*-- and then set the previous value to 0, otherwise we would get
*-- some odd values in return.
*-- So far, it works fine.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: ver. 1 07/25/1991
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Arabic(<cRoman>)
*-- Example.....: ?Arabic("XXIV")
*-- Returns.....: Arabic number (from example, 24)
*-- Parameters..: cRoman = character string containing roman numeral to be
*-- converted.
*-------------------------------------------------------------------------------
parameters cRoman
private nCounter
cRoman = upper(cRoman) && convert to all caps in case ...
declare cChar[15],nNum[15] && hopefully no string will be sent that large ...
nMax = 0 && counter for later on ..
nCounter = 0 && parse cRoman into the array, one character per
do while nCounter < 15 && array element ...
nCounter = nCounter + 1
if len(trim(substr(cRoman,nCounter,1))) > 0 && if something's there
cChar[nCounter] = substr(cRoman,nCounter,1)
nMax = nMax + 1 && set max times through NEXT loop
else
exit
endif
enddo
*-- Now that it's in an array ... we need to look at it ... and convert
*-- each character to an arabic number
nCounter = 0
do while nCounter < nMax
nCounter = nCounter + 1
do case
case cChar[nCounter] = "I" && 1
nNum[nCounter] = 1
case cChar[nCounter] = "V" && 5
if nCounter > 1 .and. cChar[nCounter - 1] = "I"
nNum[nCounter] = 4 && IV = 4
nNum[nCounter - 1] = 0 && don't add anything later ...
else
nNum[nCounter] = 5 && otherwise we have 5
endif
case cChar[nCounter] = "X" && 10
if nCounter > 1 .and. cChar[nCounter - 1] = "I"
nNum[nCounter] = 9 && IX = 9
nNum[nCounter - 1] = 0 && same ... don't add this ...
else
nNum[nCounter] = 10 && X = 10
endif
case cChar[nCounter] = "L" && 50
if nCounter > 1 .and. cChar[nCounter - 1] = "X"
nNum[nCounter] = 40 && XL = 40
nNum[nCounter - 1] = 0
else
nNum[nCounter] = 50 && L = 50
endif
case cChar[nCounter] = "C" && 100
if nCounter > 1 .and. cChar[nCounter -1] = "X"
nNum[nCounter] = 90 && XC = 90
nNum[nCounter - 1] = 0
else
nNum[nCounter] = 100
endif
case cChar[nCounter] = "D" && 500
if nCounter > 1 .and. cChar[nCounter - 1] = "C"
nNum[nCounter] = 400 && CD = 400
nNum[nCounter - 1] = 0
else
nNum[nCounter] = 500
endif
case cChar[nCounter] = "M" && 1,000
if nCounter > 1 .and. cChar[nCounter - 1] = "C"
nNum[nCounter] = 900 && CM = 900
nNum[nCounter - 1] = 0
else
nNum[nCounter] = 1000
endif
case cChar[nCounter] = "W" && 5,000
if nCounter > 1 .and. cChar[nCounter - 1] = "M"
nNum[nCounter] = 4000 && MW = 4000
nNum[nCounter - 1] = 0
else
nNum[nCounter] = 5000
endif
case cChar[nCounter] = "Y" && 10,000
if nCounter > 1 .and. cChar[nCounter - 1] = "M"
nNum[nCounter] = 9000 && MY = 9000
nNum[nCounter - 1] = 0
else
nNum[nCounter] = 10000
endif
&& that's plenty big ...
endcase
enddo
*-- Add it all together ... it SHOULD give us the proper arabic value
nArabic = 0
nCounter = 0
do while nCounter < nMax
nCounter = nCounter + 1
nArabic = nArabic + nNum[nCounter]
enddo
RETURN nArabic
*-- EoF: Arabic()
*-------------------------------------------------------------------------------
*-- End of Procedure File -- PROC.PRG
*-------------------------------------------------------------------------------