home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Media Share 9
/
MEDIASHARE_09.ISO
/
dbase
/
new194.zip
/
NEW194.PRG
< prev
next >
Wrap
Text File
|
1993-02-18
|
72KB
|
1,783 lines
*-------------------------------------------------------------------------------
*-- Program...: NEW194.PRG
*-- Programmer: Kenneth J. Mayer (CIS: 71333,1030)
*-- Date......: 02/16/1993
*-- Notes.....: The purpose of this file is to provide the routines that have
*-- been updated or are new in LIB194 from LIB193. This is so that
*-- people aren't required to download the whole procedure library
*-- to obtain the new routines.
*-- See WHATS.NEW attached to this.
*-- WARNING...: If you use WordStar 5.5 (or WordStar in general), the
*-- upper half of the ASCII character set is not well-liked.
*-- Do not save changes unless you want to wipe out some of the
*-- documentation in DIACRIT and NEWBORDER routines below.
*-------------------------------------------------------------------------------
================================================================================
*-- In STRINGS.PRG
================================================================================
PROCEDURE WordWrap
*-------------------------------------------------------------------------------
*-- Programmer..: David Frankenbach (CIS: 72147,2635)
*-- Date........: 01/14/1993 (Version 1.1)
*-- Notes.......: Wraps a long string, breaking it into strings that have
*-- a maximum length of nWidth. The first output is displayed
*-- @nRow, nCol. Words are not split ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/06/1993 -- Original Release (Version 1.0)
*-- 01/14/1993 -- Version 1.1 -- Corrected side-effect of
*-- destroying string arg, added test for
*-- string[nWidth+1] = " "
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do WordWrap with <nRow>, <nCol>, <cString>, <nWidth>
*-- Example.....: do WordWrap with 2,2,cText,38
*-- Returns.....: None
*-- Parameters..: nRow = Row to display first line at
*-- nCol = Left side of area to display text at
*-- cString = text to wrap
*-- nWidth = Width of area to wrap text in
*-------------------------------------------------------------------------------
parameters nRow, nCol, cString, nWidth
private cTemp, nI, cStr
cStr = cString && work with a COPY of input, to avoid
&& destroying original
do while len(cStr) > 0 && while there's something to work on
if (nWidth < len(cStr))
nI = nWidth && look for last " " in first nWidth
if substr(cStr,nI+1,1) # " "
do while ( (nI > 0) .and. (substr(cStr,nI,1) # " ") )
nI = nI - 1
enddo
endif
if nI = 0 && no spaces
nI = nWidth && get first nWidth characters
endif
else
nI = len(cStr) && use the rest of the string
endif
cTemp = left(cStr,nI) && get the part we're going to display
if nI < len(cStr) && remove that part
cStr = ltrim(substr(cStr,nI + 1))
else
cStr = ""
endif
*-- display it
@nRow,nCol say cTemp
*-- move to next row
nRow = nRow + 1
enddo
RETURN
*-- EoP: WordWrap
*===============================================================================
*-- In SCREEN.PRG
*===============================================================================
FUNCTION NewBorder
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
*-- Date........: 01/20/1993
*-- Notes.......: Will save current border setting (the returned value),
*-- and set a new one with one of a set of pre-defined
*-- borders. This will create a new variable if it doesn't
*-- already exist, called: c_Border, which is a PUBLIC Character
*-- variable. The purpose is so that you can keep using this
*-- string for other purpose (i.e., DEFINE WINDOW and such ...)
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: NewBorder("<cStyle>")
*-- Example.....: cOldBorder = NewBorder("K")
*-- @5,10 to 15,60 && draw box with new "border" setting
*-- *-- define a window with new "border" setting
*-- define window wTest from 10,20 to 20,60 &c_Border
*-- set border to &cOldBorder && reset border to original
*-- Returns.....: Current border setting
*-- Parameters..: cStyle = Style from one of the following:
*-- A = Double
*-- ╔════╗
*-- ║ ║
*-- ╚════╝
*-- B = Single
*-- ┌────┐
*-- │ │
*-- └────┘
*-- C = Panel
*-- ██████
*-- █ █
*-- ██████
*-- D = None
*-- E = Double Top, Single Left, Right, and Bottom
*-- ╒════╕
*-- │ │
*-- └────┘
*-- F = Single Top, Double Left, Right and Bottom
*-- ╓────╖
*-- ║ ║
*-- ╚════╝
*-- G = Double Top, Left, Right, Single Bottom
*-- ╔════╗
*-- ║ ║
*-- ╙────╜
*-- H = Single Top, Left, Right, Double Bottom
*-- ┌────┐
*-- │ │
*-- ╘════╛
*-- I = Double Top, Single Left and Right, Double Bottom
*-- ╒════╕
*-- │ │
*-- ╘════╛
*-- J = Single Top, Double Left and Right, Single Bottom
*-- ╓────╖
*-- ║ ║
*-- ╙────╜
*-- K = Single Top and Left, Double Right and Bottom
*-- ┌────╖
*-- │ ║
*-- ╘════╝
*-- L = Single Top, Double Left, Single Right, Dbl Bottom
*-- ╓────┐
*-- ║ │
*-- ╚════╛
*-- M = Double Top and Left, Single Right and Bottom
*-- ╔════╕
*-- ║ │
*-- ╙────┘
*-- N = Double Top, Single Left, Double Right, Sgl Bottom
*-- ╒════╗
*-- │ ║
*-- └────╜
*-- O = Double Top, Single Left, Double Right and Bottom
*-- ╒════╗
*-- │ ║
*-- ╘════╝
*-- P = Double Top, Left, Single Right, Double Bottom
*-- ╔═════╕
*-- ║ │
*-- ╚═════╛
*-- Q = Single Top, Double Left, Single Right and Bottom
*-- ╓─────┐
*-- ║ │
*-- ╙─────┘
*-- R = Single Top and Left, Double Right, Single Bottom
*-- ┌─────╖
*-- │ ║
*-- └─────╜
*-- S = Panel (sort of) -- more room inside the border.
*-- ▐▀▀▀▀▀▌
*-- ▐ ▌
*-- ▐▄▄▄▄▄▌
*-------------------------------------------------------------------------------
parameters cStyle
cReturn = set("BORDER") && current border -- if version of dBASE is
&& less than 1.5, comment this out ...
if type("c_Border") = "U" && if this is undefined
public c_Border && declare it as public
endif
*-- here we go ...
do case
case cStyle = "A"
c_Border = "DOUBLE" && pre-defined
case cStyle = "B"
c_Border = "SINGLE" && pre-defined
case cStyle = "C"
c_Border = "PANEL" && pre-defined
case cStyle = "D"
c_Border = "NONE" && pre-defined
case cStyle = "E"
*-- items are: top line, bottom line, left line, right line,
*-- upper left corner, upper right corner, bottom left corner,
*-- bottom right corner
c_Border = "205,196,179,179,213,184,192,217"
case cStyle = "F"
c_Border = "196,205,186,186,214,183,200,188"
case cStyle = "G"
c_Border = "205,196,186,186,201,187,211,189"
case cStyle = "H"
c_Border = "196,205,179,179,218,191,212,190"
case cStyle = "I"
c_Border = "205,205,179,179,213,184,212,190"
case cStyle = "J"
c_Border = "196,196,186,186,214,183,211,189"
case cStyle = "K"
c_Border = "196,205,179,186,218,183,212,188"
case cStyle = "L"
c_Border = "196,205,186,179,214,191,200,190"
case cStyle = "M"
c_Border = "205,196,186,179,201,184,211,217"
case cStyle = "N"
c_Border = "205,196,179,186,213,187,192,189"
case cStyle = "O"
c_Border = "205,205,179,186,213,187,212,188"
case cStyle = "P"
c_Border = "205,205,186,179,201,184,200,190"
case cStyle = "Q"
c_Border = "196,196,186,179,214,191,211,217"
case cStyle = "R"
c_Border = "196,196,179,186,218,183,192,189"
case cStyle = "S"
c_Border = "223,220,222,221,222,221,222,221"
endcase
set border to &c_Border
RETURN cReturn
*-- EoF: NewBorder
FUNCTION VidRow
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 01/28/1993
*-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
*-- to return the ABSOLUTE position of the current ROW on the
*-- screen, despite any active windows, etc.
*-- This is based on original routines by David Frankenbach,
*-- but includes the load/release in one routine, rather
*-- than requiring three functions to perform this ...
*-- ***************************
*-- ** REQUIRES VDCURSOR.BIN **
*-- ***************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: None
*-- Calls.......: VDCURSOR.BIN
*-- Called by...: Any
*-- Usage.......: VidRow()
*-- Example.....: ?VidRow()
*-- Returns.....: Numeric ROW position for current row on screen
*-- Parameters..: None
*-------------------------------------------------------------------------------
private cX
cX = space(2) && define argument memvar
load vdcursor && load the .BIN file
call vdcursor with cX && call it with the memvar
release module vdcursor && release from memory
RETURN (asc(substr(cX,2))-1) && return the value of the absolute cursor position
*-- EoF: VidRow()
FUNCTION VidCol
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 01/28/1993
*-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
*-- to return the ABSOLUTE position of the current COLUMN on the
*-- screen, despite any active windows, etc.
*-- This is based on original routines by David Frankenbach,
*-- but includes the load/release in one routine, rather
*-- than requiring three functions to perform this ...
*-- ***************************
*-- ** REQUIRES VDCURSOR.BIN **
*-- ***************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: None
*-- Calls.......: VDCURSOR.BIN
*-- Called by...: Any
*-- Usage.......: VidCol()
*-- Example.....: ?VidCol()
*-- Returns.....: Numeric COLUMN position for current Col on screen
*-- Parameters..: None
*-------------------------------------------------------------------------------
private cX
cX = space(2) && define argument memvar
load vdcursor && load the .BIN file
call vdcursor with cX && call it with the memvar
release module vdcursor && release from memory
RETURN (asc(substr(cX,1))-1) && return the value of the absolute cursor position
*-- EoF: VidCol()
FUNCTION PwdMask
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer
*-- Date........: 01/29/1993
*-- Notes.......: Designed to display a mask on the screen when a user is
*-- entering a password, rather than a blank surface. Should
*-- handle backspaces to delete ... ASSUMES <cField> is a
*-- memvar.
*-- ***************************
*-- ** REQUIRES VDCURSOR.BIN **
*-- ***************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: None
*-- Calls.......: VidRow() Function in SCREEN.PRG
*-- VidCol() Function in SCREEN.PRG
*-- Called by...: Any
*-- Usage.......: PwdMask("<cField>"[,<nMaskChar>])
*-- Example.....: @5,10 get password when PwdMask("Password");
*-- valid required .not. isblank(password);
*-- error chr(7)+"Password cannot be blank)
*-- Returns.....: .T., and field will have password placed in it when done.
*-- Parameters..: cField = name of the field
*-- nMaskChar = ASCII code for mask character. OPTIONAL parameter.
*-- if not provided, will use asterisk. Suggested
*-- characters include: 176,177,178,219,248,249,254
*-------------------------------------------------------------------------------
parameters cField, nMaskChar
private nLength, nChar, nX
*-- deal with mask character
if type("NMASKCHAR") = "L"
nMaskChar = 42 && *
endif
lCursor = set("CURSOR") = "ON"
set cursor off && rather than have the cursor in the way ...
nLength = len(&cField.) && get length of current field
nChar = 0 && input character
nRow = vidrow() && get absolute cursor location
nCol = vidcol() && ditto
cTemp = "" && initialize temp memvar
do while len(cTemp) < nLength .and. nChar # 13
&& loop until we hit end of field
&& or user presses <Enter>
nChar = inkey(0) && wait for user to enter something
do case
case nChar = 127 && <BackSpace>
if isblank(cTemp) && if empty, don't delete anything
?? chr(7) && instead, BEEP
else
cTemp = left(cTemp,len(cTemp)-1) && backup one
endif
case (nChar => 65 .and. nChar <= 90) .or.;
(nChar => 97 .and. nChar <= 122) && alphabetic input only
cTemp = cTemp + chr(nChar) && add character
case nChar = 13 && <Enter>
exit
otherwise
?? chr(7) && otherwise, BEEP
loop
endcase
*-- create the current "mask", padding with spaces ...
cMask = replicate(chr(nMaskChar),len(cTemp)) + space(nLength-len(cTemp))
*-- display it in same color as the current "GET"
@nRow,nCol get cMask
clear gets
*-- put password into current memvar
store cTemp to &cField.
enddo
*-- turn cursor on if it was prior to this routine
if lCursor
set cursor on
endif
keyboard chr(13) && send a final <Enter> to exit this GET
RETURN .T.
*-- EoF: PwdMask()
FUNCTION MsgExp
*-------------------------------------------------------------------------------
*-- Programmer..: Adam Menkes (Borland)
*-- Date........: 02/05/1993
*-- Notes.......: Allows you to display message (or error message), centered
*-- like SET MESSAGE ... with added utility. Does not use
*-- "(Press Space)", which can be annoying. The message and the
*-- line on which it is displayed will be the same color.
*-- Taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 09/xx/1991 -- Original routine
*-- 02/05/1993 -- Modified by Lee Hite to handle a string that
*-- is greater than 80 characters (this can be
*-- a real problem if the message is in row 24!)
*-- Usage.......: MsgExp("<cExp>")
*-- Example.....: MsgExp("This is a message")
*-- Returns.....: Message displayed (centered) on screen
*-- Parameters..: cExp = Message to be displayed
*-------------------------------------------------------------------------------
parameters cMsg
private nLen
nLen = (80-len(trim(cMsg)))/2
RETURN space(nLen) + trim(cMsg) + space(nLen+0.5)
*-- EoF: MsgExp
FUNCTION YesNoCan
*-------------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 02/01/1993
*-- Notes.......: Asks a yes/no/cancel 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))
*-- 01/20/1992 - Modified by Martin Leon (HMan) to handle user
*-- pressing 'Y' or 'N' keys (with ON KEY ...).
*-- 06/11/1992 - Modified by Joey Carroll (JOEY) to allow
*-- answer choices to be "Yes", "No", or "Cancel"
*-- or to allow for parameters to pass the contents
*-- of the prompts. If none are passed, they default
*-- to "Yes", "No", "Cancel". Further modified to
*-- allow specification of location by row if
*-- desired. Window size now varies as parameters
*-- dictate.
*-- 09/21/1992 - Modified by JOEY to fix bug caused if leading
*-- blanks in parameters cPrompt1,cPrompt2,cPrompt3
*-- Corrected example - case pad()="PPAD1"
*-- instead of case pad()=PPAD1
*-- 02/01/1993 - Mods by Lee Hite: Routine would not wait for
*-- user response if "default" answer did not match
*-- one of the prompts. Now first prompt becomes
*-- default if no match is found on invocation.
*-- Also, match is no longer case sensitive. Also
*-- made window height variable if message
*-- lines 2 and/or 3 are null strings. Finally,
*-- added "confirmation" parameter which when set
*-- true will force user to press [Enter] before
*-- function returns.
*-- Calls.......: SHADOW Procedure in PROC.PRG
*-- CENTER Procedure in PROC.PRG
*-- ISBLANK() Function in MISC.PRG, Internal in 1.5
*-- Called by...: Any
*-- Usage.......: YesNoCan("<cAnswer>","<cMess1>","<cMess2>","<cMess3>",;
*-- "<cPrompt1>","<cPrompt2>","<cPrompt3>",;
*-- <nTopRow>,"<cColor>",[lConfirm])
*-- Example.....: cAnswer="Y"
*-- cAnswer=YesNoCan(cAnswer,"*** Warning ***",;
*-- "A serious error has occured.",;
*-- "Choose carefully.","Proceed",;
*-- "Retry","Cancel",10,;
*-- "w+/r,n/w,w+/r")
*-- do case
*-- case cAnswer="Y" && OR case pad()="PPAD1"
*-- * do your thing
*-- case cAnswer="N" && OR case pad()="PPAD2"
*-- skip
*-- case cAnswer="C" && OR case pad()="PPAD3"
*-- * e.g. - return
*-- endcase
*--
*-- 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.....: First character of selected pad
*-- Parameters..: cAnswer = default value (Yes or No or Cancel) for menu
*-- cMess1 = First line of Message
*-- cMess2 = Second line of message
*-- cMess3 = Third line of message
*-- cPrompt1 = Optional prompt for left pad
*-- cPrompt2 = Optional prompt for middle pad
*-- cPrompt3 = Optional prompt for right pad
*-- nTopRow = Optional top row of window
*-- cColor = Optional colors for window/menu/box
*-- lConfirm = Optional "confirmation" parameter -- if true
*-- user must press [Enter], otherwise pressing
*-- a valid prompt key automatically returns
*-------------------------------------------------------------------------------
parameter cAnswer,cMess1,cMess2,cMess3,;
cPrompt1,cPrompt2,cPrompt3,nTopRow,cColor,lConfirm
private nLMargin,nRMargin,lWrap,nTopRowMax,cKey1,cKey2,cKey3,nWinWidth, ;
cConfirm, nWinHgth, nMsgRow
private cPrompt1,cPrompt2,cPrompt3
*-- save screen so we can restore ...
save screen to sYesNoCan
* locate top row of window
nTopRowMax = iif(set("STATUS") = "OFF",17,14) && protect Status Line
nTopRow = iif(isblank(nTopRow),14,nTopRow) && no parameter passed
nTopRow = min(nTopRowMax,nTopRow)
* set pad prompts if none passed
cPrompt1 = iif(isblank(cPrompt1),"Yes",cPrompt1)
cPrompt2 = iif(isblank(cPrompt2),"No",cPrompt2)
cPrompt3 = iif(isblank(cPrompt3),"Cancel",cPrompt3)
cAnswer = iif(isblank(cAnswer),cPrompt1,cAnswer)
* program bombs if prompts passed contain leading blanks
cPrompt1 = ltrim(trim(cPrompt1))
cPrompt2 = ltrim(trim(cPrompt2))
cPrompt3 = ltrim(trim(cPrompt3))
* determine how wide the window needs to be
nWinWidth = max(19,len(cPrompt1 + cPrompt2 + cPrompt3) +13)
nWinWidth = max(nWinWidth,len(cMess1)+4)
nWinWidth = max(nWinWidth,len(cMess2)+4)
nWinWidth = max(nWinWidth,len(cMess3)+4)
* and how high it needs to be
nWinHgth = iif(""=cMess2,7,8)
nWinHgth = iif(""=cMess3,nWinHgth-1,nWinHgth)
* and center it
define window wYesNoCan from nTopRow,40-(nWinWidth+2)/2 ;
to nTopRow+nWinHgth-1,40+(nWinWidth+2)/2 double color &cColor.
define menu mYesNoCan
define pad pPad1 of mYesNoCan Prompt "["+cPrompt1+"]" ;
at nWinHgth-3,02
* center middle prompt between other two, not center of window
define pad pPad2 of mYesNoCan Prompt "["+cPrompt2+"]" at nWinHgth-3, ;
((nWinWidth-len(cPrompt2))/2+(len(cPrompt1)-len(cPrompt3))/2)
define pad pPad3 of mYesNoCan Prompt "["+cPrompt3+"]" ;
at nWinHgth-3,(nWinWidth-3)-(len(cPrompt3))
on selection pad pPad1 of mYesNoCan deactivate menu
on selection pad pPad2 of mYesNoCan deactivate menu
on selection pad pPad3 of mYesNoCan deactivate menu
activate screen
do shadow with nTopRow,40-(nWinWidth+2)/2,nTopRow+nWinHgth-1, ;
40+(nWinWidth+2)/2
activate window wYesNoCan
do center with 0,nWinWidth,"",cMess1 && center the text
*-- deal with blank message lines
nMsgRow = 2
if "" <> cMess2
do center with nMsgRow,nWinWidth,"",cMess2
nMsgRow = nMsgRow + 1
endif
if "" <> cMess3
do center with nMsgRow,nWinWidth,"",cMess3
endif
*-- deal with user pressing first key of prompt
cKey1 = left(cPrompt1,1)
cKey2 = left(cPrompt2,1)
cKey3 = left(cPrompt3,1)
*-- set [CR] at end of keyboard command depending on "confirm" parameter
cConfirm = iif(lConfirm,"",chr(13))
on key label &cKey1. keyboard iif( PAD() = "PPAD1", "", ;
iif(pad() = "PPAD2", chr(19),CHR(4) )) + cConfirm
on key label &cKey2. keyboard iif( PAD() = "PPAD2", "", ;
iif(pad() = "PPAD1",CHR(4),chr(19) )) + cConfirm
on key label &cKey3. keyboard iif( PAD() = "PPAD3", "", ;
iif(pad() = "PPAD2", CHR(4),chr(19))) + cConfirm
clear typeahead
*-- otherwise deal with regular "menu" abilities
do case
case upper(cAnswer)=upper(cKey1)
activate menu mYesNoCan pad pPad1
case upper(cAnswer)=upper(cKey2)
activate menu mYesNoCan pad pPad2
case upper(cAnswer)=upper(cKey3)
activate menu mYesNoCan pad pPad3
otherwise
activate menu mYesNoCan pad pPad1
endcase
*-- clear out ON KEY settings ...
on key label &cKey1.
on key label &cKey2.
on key label &cKey3.
*-- reset environment
deactivate window wYesNoCan
release window wYesNoCan
restore screen from sYesNoCan
release screen sYesNoCan
release menu mYesNoCan
RETURN upper(substr(prompt(),2,1))
*-- EoF: YesNoCan()
*===============================================================================
*-- In PICKLIST.PRG
*===============================================================================
PROCEDURE Diacrit
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 01/27/1993
*-- Notes.......: Used to insert those letters with diacritical marks into
*-- your input screens. This routine brings up a picklist with
*-- all the standard diacrit characters built into the ASCII
*-- character set.
*-- NOTE: To use this routine properly, two things must be
*-- done first:
*-- PUBLIC n_RowPop, n_ColPop
*-- a Call to LocPop() should be made with a WHEN clause in
*-- the "get". See example below.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 12/28/1992 -- Original
*-- 01/27/1993 -- Modified (KJM) to cope with data entry WINDOWS
*-- which includes restoring the active window when done.
*-- Calls.......: LocPop() Indirectly. FUNCTION in PICKLIST.PRG
*-- Called by...: Any (routine with a GET)
*-- Usage.......: DO Diacrit
*-- Example.....: public n_RowPop, n_ColPop && vital
*-- @5,10 get cVar when LocPop(5,10) && vital
*-- ON KEY LABEL ALT-K DO DIACRIT
*-- read
*-- on key label alt-k && release definition
*-- Returns.....: Keyboards character into current "GET"
*-- Parameters..: None
*-------------------------------------------------------------------------------
private nRow, nCol, nRow2, nCol2, cReturn
on key label alt-k ?? chr(7) && beep if user tries to call again ...
*-- first things first, define where it's to display
cWindow = window() && save current window if there is one
activate screen
nRow = n_RowPop && get values from public memvars
nCol = n_ColPop
*-- bottom right corner of popup ...
nCol2 = nCol + 5
nRow2 = nRow + 10
*-- define the popup
define popup pDiacrit from nRow,nCol to nRow2,nCol2
define bar 1 of pDiacrit prompt " "+chr(142)+" " && Ä
define bar 2 of pDiacrit prompt " "+chr(143)+" " && Å
define bar 3 of pDiacrit prompt " "+chr(146)+" " && Æ
define bar 4 of pDiacrit prompt " "+chr(131)+" " && â
define bar 5 of pDiacrit prompt " "+chr(132)+" " && ä
define bar 6 of pDiacrit prompt " "+chr(133)+" " && à
define bar 7 of pDiacrit prompt " "+chr(134)+" " && å
define bar 8 of pDiacrit prompt " "+chr(160)+" " && á
define bar 9 of pDiacrit prompt " "+chr(145)+" " && æ
define bar 10 of pDiacrit prompt " "+chr(144)+" " && É
define bar 11 of pDiacrit prompt " "+chr(136)+" " && ê
define bar 12 of pDiacrit prompt " "+chr(137)+" " && ë
define bar 13 of pDiacrit prompt " "+chr(138)+" " && è
define bar 14 of pDiacrit prompt " "+chr(130)+" " && é
define bar 15 of pDiacrit prompt " "+chr(139)+" " && ï
define bar 16 of pDiacrit prompt " "+chr(140)+" " && î
define bar 17 of pDiacrit prompt " "+chr(141)+" " && ì
define bar 18 of pDiacrit prompt " "+chr(161)+" " && í
define bar 19 of pDiacrit prompt " "+chr(147)+" " && ô
define bar 20 of pDiacrit prompt " "+chr(148)+" " && ö
define bar 21 of pDiacrit prompt " "+chr(149)+" " && ò
define bar 22 of pDiacrit prompt " "+chr(162)+" " && ó
define bar 23 of pDiacrit prompt " "+chr(153)+" " && Ö
define bar 24 of pDiacrit prompt " "+chr(150)+" " && û
define bar 25 of pDiacrit prompt " "+chr(129)+" " && ü
define bar 26 of pDiacrit prompt " "+chr(151)+" " && ù
define bar 27 of pDiacrit prompt " "+chr(163)+" " && ú
define bar 28 of pDiacrit prompt " "+chr(154)+" " && Ü
define bar 29 of pDiacrit prompt " "+chr(152)+" " && ÿ
define bar 30 of pDiacrit prompt " "+chr(128)+" " && Ç
define bar 31 of pDiacrit prompt " "+chr(165)+" " && Ñ
define bar 32 of pDiacrit prompt " "+chr(164)+" " && ñ
*-- whatta we do with it?
on selection popup pDiacrit deactivate popup
activate popup pDiacrit
cPrompt = prompt()
*-- Esc -> <-
if lastkey() = 27 .or. lastkey() = 4 .or. lastkey() = 19
cReturn = ""
else
cReturn = substr(cPrompt,2,1) && get the actual character ...
endif
*-- remove from memory
release popup pDiacrit
*-- reactivate window if there was one ...
if .not. isblank(cWindow)
activate window &cWindow
endif
*-- put into user's "Get"
keyboard cReturn
*-- reset ON KEY definition
on key label alt-k do diacrit
RETURN
*-- EoP: Diacrit
FUNCTION LocPop
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth Chan (:>Zak<:) (CIS: 71542,2712)
*-- Date........: 01/28/1993
*-- Notes.......: Created for diacritical routine above, to determine position
*-- of current "Get", and then decide whether to place upper
*-- left coordinates (in public memvars: n_RowPop, n_ColPop)
*-- of a popup.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 12/25/1992 -- Original
*-- 12/28/1992 -- Modified to deal with positioning if get is
*-- to far to the right on the screen, and so on (Ken Mayer).
*-- 01/28/1993 -- Modified to handle windows on screen, giving
*-- an absolute address. Requires user to provide coordinates
*-- for upper left corner of window.
*-- Calls.......: VidRow() Function in SCREEN.PRG
*-- VidCol() Function in SCREEN.PRG
*-- Called by...: Diacrit (Indirectly) Procedure in PICKLIST.PRG
*-- Usage.......: LocPop(<nWidth>,<nLength>[,<nWBorder>])
*-- Example.....: @5,10 get cVar when LocPop(5,10)
*-- Returns.....: logical true
*-- Parameters..: nWidth = width of popup
*-- nLength = length of popup (how many bars should display on
*-- screen -- used to determine if displaying above
*-- or below ROW() of GET)
*-- nWBorder = OPTIONAL -- if there is no border we have to back
*-- up one, so put a '0' in here if there is no
*-- border, otherwise, ignore this parameter.
*-------------------------------------------------------------------------------
parameters nWidth,nLength, nWBorder
private cVar, nRow, nCol
*-- get current "GET"
cVar = varread()
*-- put current position into column/row ... since cursor was just placed
*-- into field (assuming called from WHEN clause), we are always on the
*-- first character in the GET ...
nRow = VidRow()
nCol = VidCol()
if type("NWBORDER") # "L" .and. nWBorder = 0
nRow = nRow - 1
nCol = nCol - 1
endif
*-- add it all up, see if popup coordinates are off the screen
*-- if so, we need to display the popup UNDER the GET
if nCol + (len(&cVar)+nWidth+1) > 79
nRow = nRow + 1
nCol = 79 - nWidth && put it right up against edge of screen
else && otherwise, set column position
nCol = nCol + len(&cVar) + 1 && add length of memvar/get
endif
*-- now to see if we're going to go off the bottom of the screen
*-- and deal with _that_ -- displaying popup ABOVE the GET.
nDisp = val(right(set("DISPLAY"),2)) && (EGAxx ...)
if nRow + nLength +2 => nDisp - 1 && check for bottom of screen
nRow = nRow - nLength - 2
endif
if type("N_ROWPOP") = "U" .or. type("N_ROWPOP") = "L"
public n_RowPop,n_ColPop
endif
n_RowPop = nRow && set current position ...
n_ColPop = nCol
RETURN .t.
*-- EoF: LocPop()
FUNCTION Pick4
*-------------------------------------------------------------------------------
*-- Programmer..: Keith G. Chuvala (CIS: 71600,2033)
*-- Date........: 02/16/1993
*-- Notes.......: This is a generic picklist routine.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 10/01/1992 -- Original version
*-- 11/03/1992 -- Modified to dUFLP it (and use RECOLOR to
*-- ensure that colors are returned properly) -- Ken Mayer
*-- 02/16/1993 -- Updated by Keith to deal with small data files.
*-- Calls.......: ReColor PROCEDURE in PROC.PRG
*-- Called by...: Any
*-- Usage.......: Pick4(nRow,nCol,cTitle,cFileSpecs,cListWhat,nRetChar,;
*-- nRetType,cColors
*-- Example.....: ?Pick4(10,10,"Order Stock","Stock,InvNum",;
*-- "left(invno,10)+' '+desc",4,1,"r/w,b/w,w/b")
*-- Returns.....: number of characters from prompt()
*-- Parameters..: nRow = Upper Left Corner Row
*-- nCol = Upper Left Corner Column
*-- cTitle = Title to display at top of list
*-- cFileSpecs = "FILENAME,ORDER,SET_KEY_TO"
*-- cListWhat = What should display as prompt
*-- nRetChar = Number of characters of prompt to return
*-- nReturnType = 0 = KEYB(), 1 = Normal Return
*-- cColors = Background/Unselected Items,;
*-- Selected letters/border, selected bar
*-- example: rg+/gb,w+/b,w+/n
*-- rg+/gb = unselected items (and background)
*-- w+/b = selected letter(s)
*-- w+/n = currently highlighted bar
*-------------------------------------------------------------------------------
para nRow,nCol,cTitle,cFileSpecs,cListWhat,nRetChar,nReturnType,cColors
private nLastBar,cTalk,cStatus,cNColor,cBColor,cHColor,nPick,;
cWindow,cCursor,cAlias,sPick,cAttrib,nLastBar, nDone,;
nX,nP,nO,aBar,lRefresh,nLCol,nRCol,nPKey,cExact, ;
cSeek,nOldRow,nOldWidth,xRetVal,cSetKey
*-- basic environmental stuff
cTalk = set("talk")
set talk off
*-- set default colors
cNColor = "w/n"
cBColor = "w+/n"
cHColor = "n/w"
*-- if user passed this parameter
if len(cColors) > 0
nX = at(",",cColors)
cNColor = left(cColors,nX-1)
cColors = substr(cColors,nX+1)
if len(cColors) > 0
nX = at(",",cColors)
cBColor = iif(nX > 0,left(cColors,nX-1),cColors)
cColors = iif(nX > 0,substr(cColors,nX+1),"")
if len(cColors) > 0
cHColor = cColors
endif
endif
endif
*-- save current screen colors and screen, modify environment some more
cAttrib = set("attr")
set color to &cHColor,&cNColor
save screen to sPick
cStatus = set("status")
set status off
restore screen from sPick
cCursor = set("cursor")
set cursor off
cWindow = window()
activate screen
cExact = set("exact")
cSeek = ""
set exact off
set near off
*-- display
@ 9,32 clear to 9,47
@ 9,32 fill to 11,49 color w/n
@ 8,31 to 10,48 color &cBColor
@ 9,32 say " Please wait... " color &cNColor
*-- create the picklist
declare aBar[10]
cOrder = ""
cSetKey = ""
cFile = cFileSpecs
nX = at(",",cFileSpecs)
if nX > 0
cFile= left(cFileSpecs,nX-1)
cFileSpecs = substr(cFileSpecs,nX+1)
if len(cFileSpecs) > 0
nX = at(",",cFileSpecs)
cOrder = iif(nX>0,left(cFileSpecs,nX-1),cFileSpecs)
cFileSpecs = iif(nX>0,substr(cFileSpecs,nX+1),"")
if len(cFileSpecs) > 0
cSetKey = cFileSpecs
endif
endif
endif
cAlias = alias()
nLastBar = 9
nP = 1
nO = 1
nDone = 0
lRefresh = .t.
lSameFile = (cAlias = upper(cFile))
use &cFile. again in select() alias picker
if len(tag(1)) > 0
set order to tag(1)
endif
set deleted on
if len(trim(cOrder)) > 0
set order to &cOrder
endif
if len(trim(cSetKey)) > 0
if at(",",cSetKey) > 0
cSetKey = "range "+ cSetKey
endif
set nPKey to &cSetKey
endif
go top
nDone = iif(reccount() < 1,2,0)
if nRow > 14
nRow = 14
endif
nOldWidth = -1
nOldRow = -1
nLastBar = 9
do while nDone = 0
if lRefresh .and. .not. eof("picker")
nWidth = 0
nX = 0
do while nX < 8 .and. .not. eof("picker")
nX = nX + 1
aBar[nX] = &cListWhat
if len(aBar[nX]) > nWidth
nWidth = len(aBar[nX])
endif
skip 1
enddo
nLastBar = nX
nLCol = nCol
nRCol = nLCol + nWidth + 4
do while (nRCol > 77) .and. (nLCol > 0)
if nLCol > 1
nRCol = nRCol - 1
nLCol = nLCol - 1
else
nRCol = 77
endif
enddo
if (nWidth <> nOldWidth) .or. (nLastBar <> nOldRow)
restore screen from sPick
@ nRow+1, nLCol+1 fill to ;
nRow+nLastBar+2,nRCol+2 color w/n
@ nRow , nLCol to ;
nRow+nLastBar+1,nRCol color &cBColor
@ nRow , nLCol+1 say '[' color &cBColor
@ nRow , nLCol+2 say cTitle color &cNColor
@ nRow , nLCol+2+len(cTitle) say ']' color &cBColor
endif
@ nRow+1, nLCol+1 clear to ;
nRow+nLastBar ,nRCol-1
@ nRow+1, nLCol+1 fill to ;
nRow+nLastBar ,nRCol-1 color &cBColor
nOldRow = nLastBar
nOldWidth = nWidth
nX = 1
do while nX <= nLastBar
@ nX+nRow,nLCol+2 say " "+aBar[nX] color &cNColor
nX = nX + 1
enddo
endif
if nP > nLastBar
nP = nLastBar
endif
if nO <= nLastBar
@ nRow+nO, nLCol+2 fill to nRow+nO,nRCol-2 color &cNColor
endif
@ nRow+nP, nLCol+2 fill to nRow+nP,nRCol-2 color &cHColor
nX = at(upper(cSeek),upper(aBar[nP]))
if nX > 0
@ nRow+nP,nLCol+2+nX fill to nRow+nP,nLCol+1+nX+len(cSeek) ;
color &cBColor
endif
nO = nP
*-- start processing key strokes ...
nPKey = inkey(0)
do case
case nPKey = 5 && up
nP = nP - 1
if nP < 1
nPKey = 18
nP = nLastBar
endif
cSeek = ""
case nPKey = 24 && down
nP = nP + 1
if nP > nLastBar
if .not. eof("picker")
nPKey = 3
nP = 1
else
nPKey = 0
nP = nP - 1
endif
endif
cSeek = ""
endcase
lRefresh = .t.
do case
case nPKey = 18 && pgup, up
skip - 16
if bof()
go top
endif
cSeek = ""
case nPKey = 26 && home
go top
nP = 1
cSeek = ""
case nPKey = 2 && end
go bottom
skip - 7
if bof()
go top
else
nP = nLastBar
endif
cSeek = ""
case nPKey = 27 && esc
nDone = 1
case (nPKey = 13) .or. (nPkey = 23) && c/r
nPick = aBar[nP]
nDone = 1
case ((nPKey >= asc(" ")) .and. (nPKey <= asc("z"))) .or. (nPKey = 127)
if nPKey = 127
cSeek = left(cSeek,len(cSeek)-1)
else
cSeek = cSeek + chr(nPKey)
endif
if len(trim(tag())) > 0
seek(cSeek)
if .not. found()
seek(upper(cSeek))
endif
endif
if .not. found()
cSeek = left(cSeek,len(cSeek)-1)
?? chr(7)
endif
if len(trim(cSeek)) = 0
go top
endif
lRefresh = .t.
nPKey = 3
otherwise
if (nPKey <> 3)
lRefresh = .f.
endif
endcase
enddo
*-- return something, unless <Esc> was pressed
if nPKey <> 27
if nReturnType = 0
keyboard chr(26)+chr(25)+left(nPick,nRetChar)+chr(13)
endif
xRetVal = iif(nReturnType=0,.t.,iif(nPKey=27,"",left(nPick,nRetChar)))
else
xRetVal = .f.
endif
*-- cleanup
select picker
use
if len(trim(cAlias)) > 0
select (cAlias)
endif
if len(trim(cWindow)) > 0
activate window &cWindow
endif
do recolor with cAttrib
set status &cStatus
set talk &cTalk
set cursor &cCursor
set exact &cExact
restore screen from sPick
RETURN xRetVal
*-- EoF: Pick4()
*===============================================================================
*-- In FIELDS.PRG
*===============================================================================
FUNCTION FldWidth
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth Chan [HazMatZak] (CIS: 71542,2712)
*-- Date........: 01/28/1993
*-- Notes.......: Returns the width of a field, without having to read the
*-- .DBF structure into a file and use low-level functions ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: FldWidth(<nField>)
*-- Example.....: ?FldWidth(3)
*-- Returns.....: Numeric value
*-- Parameters..: nField = field number in file structure
*-------------------------------------------------------------------------------
parameters nField
private nReturn, cFldType, cFldName
cFldName = field(nField) && get the field name
cFldType = type(cFldName) && get the type ...
do case
case cFldType = "L"
nReturn = 1
case cFldType = "D"
nReturn = 8
case cFldType = "C"
nReturn = len(&cFldName.)
case cFldType $ "NF"
nReturn = len(transform(&cFldName.,"@L"))
otherwise
nReturn = 0
endcase
RETURN nReturn
*-- EoF: FldWidth()
FUNCTION FldDec
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth Chan [HazMatZak] (CIS: 71542,2712)
*-- Date........: 01/28/1993
*-- Notes.......: Returns the number of decimal places of a numeric field.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: FldDec(<nField>)
*-- Example.....: ?FldDec(3)
*-- Returns.....: Numeric value, 0 if non-numeric field type
*-- Parameters..: nField = field number in file structure
*-------------------------------------------------------------------------------
parameters nField
private nReturn, cTemplate, cFldName
cFldName = field(nField)
if type(cFldName) $ "NF" && if it's numeric/float type
cTemplate = transform(&cFldName.,"@L")
nReturn = at(".",cTemplate)
if nReturn > 0
nReturn = len(cTemplate) - nReturn
endif
else
nReturn = 0
endif
RETURN nReturn
*-- EoF: FldDec()
*===============================================================================
*-- In FINANCE.PRG
*===============================================================================
FUNCTION Irr2 && {version 1.01}
*-------------------------------------------------------------------------------
*-- Programmer...: Ron Allen (CIS: 71201,2502)
*-- Date.........: 01/25/1993
*-- Notes........: Returns internal rate of return on an investment from
*-- evenly-spaced periodic cashflows. The UDF simultaneously
*-- accumulates the periodic Net Present Values of the
*-- individual cashflows along with the first derivative of
*-- the function. After the summation is completed for each
*-- guess, the guess is adjusted by subtracting the ratio
*-- of the function to its derivative.
*-- Written for..: dBASEIV, version 1.5, tested on build xx71
*-- Rev. History.: 1.01 01/28/93 - to add missing private variables. To
*-- count iterations without sign change in PV. Move
*-- division by nRatio outside inner loop.
*-- Calls........: None
*-- Called by....: Any
*-- Usage........: Irr2(<nN>, <cFlow>, <lSw>, <nGuess>)
*-- Example......: Rate = Irr2(6, "Cash", Switch, .01)
*-- Returns......: Internal Rate of Return.
*-- Parameters...: nN = number of cashflows in model
*-- cFlow = name of the array holding the cashflows
*-- lSw = name of a logical variable to be switched to
*-- indicate valid IRR returned (.t.).
*-- nGuess = optional guess for initialing search.
*-------------------------------------------------------------------------------
parameters nN, cFlow, lSw, nGuess
private nI, nPosVal, nNegVal, nCurVal, nIRR, nNuDelta, nOlDelta, nBigchange
private nSignChng, nDiscount, nRatio, nSumPV, nCurrPV, nSumDeriv, nOldPV
private nIters, lSw1
store 0 to nI, nPosVal, nNegVal, nIters
store .t. to lSw
store .f. to lSw1
declare nCashFlow[nN]
*-- Transfer cashflows to a private array and separate negatives from
*-- positives
do while nI < nN
nI = nI+1
store &cFlow[nI] to nCashFlow[nI], nCurVal
if nCurVal < 0
nNegVal = nNegVal + nCurVal
else
nPosVal = nPosVal + nCurVal
endif
enddo
if nNegVal = 0 .or. nPosVal = 0
wait "Must have at least one positive and one negative value"
endif
*-- Use initializing guess if provided, otherwise calculate from
*-- weighted average returns.
if pcount() = 4
nIRR = nGuess
else
nIRR = ((-nPosVal/nNegVal)-1)/nN
endif
*-- Housekeeping summary accumulators, etc., before entering loop
store 1 to nNuDelta, nOlDelta
store 0 to nSignChng, nBigChange
*-- Loop until estimated rate indicated accuracy
do while abs(nNuDelta) > .000001
store 0 to nI, nSumPV, nSumDeriv
*-- Set up cumulative denominator to calculate incremental NPV
nDiscount = 1
nRatio = 1 + nIRR
do while nI < nN
nI = nI+1
nDiscount = nDiscount/nRatio
*-- Calculate incremental PV and add to sum
nCurrPV = nDiscount * nCashFlow[nI]
nSumPV = nSumPV + nCurrPV
*-- Add incremental first derivative to derivative sum
nSumDeriv = nSumDeriv - nI * nCurrPV
enddo
*-- count iterations and test for sign change of future value
if .not. lSw1 .and. nIters > 0
lSw1 = iif(sign(nOldPV) = sign(nSumPV),.f.,.t.)
endif
nIters = nIters + 1
nOldPV = nSumPV
*-- Calculate indicated change in IRR
nNuDelta = nRatio * nSumPV/nSumDeriv
*-- Test for big changes in adjusted IRR, limit to 10 times
*-- current guess for IRR and count big changes.
if abs(nNuDelta/nIRR) > 10
nNuDelta = sign(nNuDelta) * 10 * nIRR
nBigChange = nBigChange + 1
endif
nIRR = nIRR - nNuDelta && Make adjustment to guess for IRR
*-- Count reversals in adjustments to limit hunting
nSignChng = nSignChng + iif(sign(nNuDelta) + sign(nOlDelta) = 0,1,0)
nOlDelta = nNuDelta
*-- Test for hunting, too many bigchanges or too large a solution
*-- and set external switch if abnormal exit is used.
if nSignChng + nBigChange > 10 .or. abs(nIRR) > 100 .or. ;
(nIters > 9 .and. .not. lSw1)
store .f. to lSw
exit
endif
enddo
RETURN nIRR
*-- EoF: Irr2()
FUNCTION Mirr && {version 1.0}
*-------------------------------------------------------------------------------
*-- Programmer...: Ron Allen (CIS: 71201,2502)
*-- Date.........: 01/27/1993
*-- Notes........: Used to calculate the Modified Internal Rate of Return
*-- for evenly-spaced periodic cashflows. The modifications
*-- assume that more realistic investment models should
*-- account for the cost of borrowing or the lower 'safe'
*-- rate for keeping reserve funds to cover outlays and the
*-- fact that reinvestments will be made at some other rate
*-- than the IRR itself. This model calculates the answer
*-- directly, therefore more rapidly than the iterative
*-- approach used by IRR.
*-- Written for..: dBASEIV, version 1.5, tested on build xx71
*-- Rev. History.: None
*-- Calls........: None
*-- Called by....: Any
*-- Usage........: Mirr(<nN>, <cFlow>, <nRrate>, <nFrate>)
*-- Example......: Rate = Mirr(6, "Cash", .1, .14)
*-- Returns......: Modified Internal Rate of Return per period.
*-- Parameters...: nN = number of cashflows in model
*-- cFlow = name of the array holding the cashflows
*-- nRrate = Reinvestment rate for positive cashflows.
*-- nFrate = 'Safe' rate expected on reserve funds to
*-- cover disbursements.
*-------------------------------------------------------------------------------
parameters nN, cFlow, nRrate, nFrate
private nI, nNegVal, nPosVal, nCurVal
store 0 to nI, nNegVal, nPosVal
*-- Pass through array once computing present value of negative
*-- cashflows at 'safe' rate and present value of positive values
*-- at the reinvestment rate.
do while nI < nN
nI = nI+1
nCurVal = &cFlow[nI]
nCurVal = nCurVal*(1+iif(nCurVal<0,nFrate,nRrate))^-(nI-1)
if nCurVal < 0
nNegVal = nNegVal + nCurVal
else
nPosVal = nPosVal + nCurVal
endif
enddo
if abs(nNegVal) = 0 .or. nPosVal = 0
wait " There must be at least one negative and one positive value! "
return 0
endif
*-- Calculate the rate of return required to yield a future value
*-- of the positive values reinvested at nRrate from the present
*-- value of the negative values invested at the 'safe' rate.
RETURN ((-nPosVal * (1+nRrate)^(nN-1))/nNegVal)^(1/(nN-1))-1
*-- EoF: Mirr()
FUNCTION Xmirr && {version 1.01}
*-------------------------------------------------------------------------------
*-- Programmer...: Ron Allen (CIS: 71201,2502)
*-- Date.........: 01/27/1993
*-- Notes........: Used to calculate the Modified Internal Rate of Return
*-- from cashflows on random dates. Except for the need to
*-- supply both the dates of transactions and the cashflows
*-- in an 'nN' by 2 array, the other inputs are the same as
*-- in Mirr(). Dates may be in random order except for the
*-- first date. The first date in the array establishes
*-- the date to which present value applies. Enter 'Safe'
*-- rate for reserves and 'Reinvestment' rate for positive
*-- cashflows as annual rates, e.g., .075 for 7.5%.
*-- Written for..: dBASEIV, version 1.5, tested on build xx71
*-- Rev. History.: 1.01 01/27/93 - to allow entry of 'Safe' reserve rate
*-- and 'Reinvestment' rate as annual rates rather than
*-- rates. Also, to return the 'effective' rate of interest
*-- when compounded daily, rather than the 'nominal' rate.
*-- Calls........: None
*-- Called by....: Any
*-- Usage........: Xmirr(<nN>, <cFlow>, <nRrate>, <nFrate>)
*-- Example......: Rate = Xmirr(5, "Cash", .14, .1)
*-- Returns......: Annualized Effective Modified Internal Rate of Return
*-- based on daily compounded interest.
*-- Parameters...: nN = number of cashflows in model
*-- cFlow = name of 'nN' by 2 array holding the dates (col 1)
*-- and cashflow amounts (col 2).
*-- nRrate = Reinvestment rate for positive cashflows.
*-- nFrate = 'Safe' rate expected on reserve funds to
*-- cover disbursements.
*-------------------------------------------------------------------------------
parameters nN, cFlow, nRrate, nFrate
private nI, nCurVal, nNegVal, nPosVal, dPDate
private dMaxDate, dCurDate, nCurN, nMirr
store 0 to nI, nNegVal, nPosVal
store (1+nRrate)^(1/365)-1 to nRrate
store (1+nFrate)^(1/365)-1 to nFrate
store &cFlow[1,1] to dPDate
dMaxDate = dPDate
do while nI < nN
nI = nI+1
nCurVal = &cFlow[nI,2]
dCurDate = &cFlow[nI,1]
dMaxDate = max(dCurDate,dMaxDate)
nCurN = dCurDate-dPDate
nCurVal = nCurVal/(1+iif(nCurVal<0,nFrate,nRrate))^nCurN
if nCurVal < 0
nNegVal = nNegVal + nCurVal
else
nPosVal = nPosVal + nCurVal
endif
enddo
if nNegVal = 0 .or. nPosVal = 0
wait " There must be at least one negative and one positive value! "
return 0
endif
nN = dMaxDate - dPDate
nMirr = ((-nPosVal * (1+nRrate)^(nN-1))/nNegVal)^(1/(nN-1))-1
RETURN (1+nMirr)^365-1
*-- EoF: Xmirr()
FUNCTION Xirr && {version 1.01}
*-------------------------------------------------------------------------------
*-- Programmer...: Ron Allen (CIS: 71201,2502)
*-- Date.........: 01/25/1993
*-- Notes........: Used to calculate the Internal Rate of Return from
*-- cashflows on random dates. Except for the need to
*-- supply both the dates of transactions and the cashflows
*-- in an 'nN' by 2 array, the other inputs are the same as
*-- in Irr(). Dates may be in random order except for the
*-- first date. The first date in the array establishes
*-- the date to which present value applies.
*-- Written for..: dBASEIV, version 1.5, tested on build xx71
*-- Rev. History.: 1.01 - 01/28/93 - to return 'effective' rate of interest
*-- when compounded daily rather than the 'nominal' rate.
*-- Also to count iterations without a sign change in PV.
*-- Move division by nRatio outside inner loop.
*-- Calls........: None
*-- Called by....: Any
*-- Usage........: Irr(<nN>, <cFlow>, <lSw>, <nGuess>)
*-- Example......: Rate = Irr(5, "Cash", "Switch", .01)
*-- Returns......: Effective Internal Rate of Return.
*-- Parameters...: nN = number of cashflows in model
*-- cFlow = name of the 'nN' by 2 array holding the
*-- dates (col 1) and cashflows (col 2). Dates
*-- may be entered in any order except for the
*-- date, which is the date to which present
*-- value applies.
*-- lSw = name of a logical variable to be switched to
*-- indicate valid IRR returned (.t.).
*-- nGuess = optional guess for initializing search.
*-------------------------------------------------------------------------------
parameters nN, cFlow, lSw, nGuess
private nI, nPosVal, nNegVal, nCurVal, nIRR, nNuDelta, nOlDelta, nBigchange
private nSignChng, nRatio, dPDate, dMaxDate, nCurrPV, nSumDeriv
private nSumPV, dCurDate, nIters, lSw1
store 0 to nI, nPosVal, nNegVal, nIters
Store .t. to lSw
declare nCashFlow[nN,2]
store &cFlow[1,1] to dMaxDate, dPDate
store .f. to lSw1
*-- Transfer cashflows to a private array and separate negatives from
*-- positives. Find last date.
do while nI < nN
nI = nI+1
store &cFlow[nI,1] to nCashFlow[nI,1], dCurDate
store &cFlow[nI,2] to nCashFlow[nI,2], nCurVal
store max(dCurDate,dMaxDate) to dMaxDate
if nCurVal < 0
nNegVal = nNegVal + nCurVal
else
nPosVal = nPosVal + nCurVal
endif
enddo
if nNegVal = 0 .or. nPosVal = 0
wait "Must have at least one positive and one negative value"
endif
*-- Use initializing guess if provided, otherwise calculate from
*-- weighted average returns.
if pcount() = 4
nIRR = nGuess
else
nIRR = (((nPosVal+nNegVal-ncashflow[1,2])/-nCashFlow[1,2])-1)/;
(dMaxDate-dPDate)
endif
*-- Housekeeping summary accumulators, etc., before entering loop
store 1 to nNuDelta, nOlDelta
store 0 to nSignChng, nBigChange
*-- Loop until estimated rate indicated accuracy
do while abs(nNuDelta) > .000001
store 0 to nI, nSumPV, nSumDeriv
store 1 + nIrr to nRatio
do while nI < nN
nI = nI+1
*-- Calculate incremental PV and add to sum
nCurrPV = nCashFlow[nI,2] / nRatio^(nCashFlow[nI,1] - dPDate)
nSumPV = nSumPV + nCurrPV
*-- Add incremental first derivative to derivative sum
nSumDeriv = nSumDeriv - (nCashFlow[nI,1] - dPDate) * nCurrPV
enddo
*-- count iterations and test for sign change of future value
if .not. lSw1 .and. nIters > 0
lSw1 = iif(sign(nOldPV) = sign(nSumPV),.f.,.t.)
endif
nIters = nIters + 1
nOldPV = nSumPV
*-- Calculate indicated change in IRR
nNuDelta = nRatio * nSumPV/nSumDeriv
*-- Test for big changes in adjusted IRR, limit to 10 times
*-- current guess for IRR and count big changes.
if abs(nNuDelta/nIRR) > 10
nNuDelta = sign(nNuDelta) * 10 * nIRR
nBigChange = nBigChange + 1
endif
nIRR = nIRR - nNuDelta && Make adjustment to guess for IRR
*-- Count reversals in adjustments to limit hunting
nSignChng = nSignChng + iif(sign(nNuDelta) + sign(nOlDelta) = 0,1,0)
nOlDelta = nNuDelta
*-- Test for hunting, too many bigchanges or too large a solution
*-- and set external switch if abnormal exit is used.
if nSignChng + nBigChange > 10 .or. abs(nIRR) > 100 .or. ;
(nIters > 9 .and. .not. lSw1)
store .f. to lSw
exit
endif
enddo
RETURN (1+nIrr)^365 -1
*-- EoF: Xirr()
FUNCTION FVirr && {version 1.01}
*-------------------------------------------------------------------------------
*-- Programmer...: Ron Allen (CIS: 71201,2502)
*-- Date.........: 01/28/1993
*-- Notes........: Returns same roots as Irr(), but averages 20% faster.
*-- Irr() searches for the roots of NPV (Net Present Value),
*-- while FVirr() searches for the same roots of NFV (Net
*-- Future Value), both with respect to the rate of return.
*-- The user may wish to use this UDF in place of Irr() and
*-- use Irr() as an alternate to help locate more multiple
*-- solutions. The reason this UDF is 'usually' faster is due
*-- to the fact that the NFV curve is 'usually' steeper as
*-- it crosses the zero axis.
*-- Written for..: dBASEIV, version 1.5, tested on build xx71
*-- Rev. History.: 1.01 01/28/93 - Modified Irr() to use Net Future Value
*-- curve instead of Net Present Value curve.
*-- Calls........: None
*-- Called by....: Any
*-- Usage........: Irr(<nN>, <cFlow>, <lSw>, <nGuess>)
*-- Example......: Rate = Irr(6, "Cash", Switch, .01)
*-- Returns......: Internal Rate of Return.
*-- Parameters...: nN = number of cashflows in model
*-- cFlow = name of the array holding the cashflows
*-- lSw = name of a logical variable to be switched to
*-- indicate valid IRR returned (.t.).
*-- nGuess = optional guess for initialing search.
*-------------------------------------------------------------------------------
parameters nN, cFlow, lSw, nGuess
private nI, nPosVal, nNegVal, nCurVal, nIRR, nNuDelta, nOlDelta, nBigchange
private nSignChng, nDiscount, nRatio, nSumFV, nCurrFV, nSumDeriv, nOldFV
private nIters, lSw1
store 0 to nI, nPosVal, nNegVal, nIters
store .t. to lSw
store .f. to lSw1
declare nCashFlow[nN]
*-- Transfer cashflows to a private array and separate negatives from
*-- positives
do while nI < nN
nI = nI+1
store &cFlow[nI] to nCashFlow[nI], nCurVal
if nCurVal < 0
nNegVal = nNegVal + nCurVal
else
nPosVal = nPosVal + nCurVal
endif
enddo
if nNegVal = 0 .or. nPosVal = 0
wait "Must have at least one positive and one negative value"
endif
*-- Use initializing guess if provided, otherwise calculate from
*-- weighted average returns.
if pcount() = 4
nIRR = nGuess
else
nIRR = ((-nPosVal/nNegVal)-1)/nN
endif
*-- Housekeeping summary accumulators, etc., before entering loop
store 1 to nNuDelta, nOlDelta
store 0 to nSignChng, nBigChange
*-- Loop until estimated rate indicated accuracy
do while abs(nNuDelta) > .000001
store 0 to nI, nSumFV, nSumDeriv
*-- Set up cumulative denominator to calculate incremental NFV
nRatio = 1 + nIRR
nDiscount = nRatio^nN
do while nI < nN
nI = nI+1
nDiscount = nDiscount/nRatio
*-- Calculate incremental FV and add to sum
nCurrFV = nDiscount * nCashFlow[nI]
nSumFV = nSumFV + nCurrFV
*-- Add incremental first derivative to derivative sum
nSumDeriv = nSumDeriv - nI * nCurrFV
enddo
*-- count iterations and test for sign change of future value
if .not. lSw1 .and. nIters > 0
lSw1 = iif(sign(nOldFV) = sign(nSumFV),.f.,.t.)
endif
nIters = nIters + 1
nOldFV = nSumFV
*-- Calculate indicated change in IRR
nNuDelta = nRatio * nSumFV/nSumDeriv
*-- Test for big changes in adjusted IRR, limit to 10 times
*-- current guess for IRR and count big changes.
if abs(nNuDelta/nIRR) > 10
nNuDelta = sign(nNuDelta) * 10 * nIRR
nBigChange = nBigChange + 1
endif
nIRR = nIRR - nNuDelta && Make adjustment to guess for IRR
*-- Count reversals in adjustments to limit hunting
nSignChng = nSignChng + iif(sign(nNuDelta) + sign(nOlDelta) = 0,1,0)
nOlDelta = nNuDelta
*-- Test for hunting, too many bigchanges or too large a solution
*-- and set external switch if abnormal exit is used.
if nSignChng + nBigChange > 10 .or. abs(nIRR) > 100 .or. ;
(nIters > 9 .and. .not. lSw1)
store .f. to lSw
exit
endif
enddo
RETURN nIRR
*-- EoF: FVirr()
FUNCTION FVxirr && {version 1.01}
*-------------------------------------------------------------------------------
*-- Programmer...: Ron Allen (CIS: 71201,2502)
*-- Date.........: 01/28/1993
*-- Notes........: Same as Xirr() except that the Net Future Value (NFV)
*-- function is used instead of the Net Present Value (NPV)
*-- function. The roots are the same, but this function is
*-- usually faster for the same reasons that FVirr() is
*-- faster than Irr(). As in Xirr(), all dates except the
*-- first date in the array may be in random order. The first
*-- date in the nN by 2 array along with the maximum date
*-- establishes the range of the investment analysis.
*-- Written for..: dBASEIV, version 1.5, tested on build xx71
*-- Rev. History.: 1.01 - 01/28/93 - Modified Xirr() to find roots of the
*-- Net Future Value curve.
*-- Calls........: None
*-- Called by....: Any
*-- Usage........: Irr(<nN>, <cFlow>, <lSw>, <nGuess>)
*-- Example......: Rate = Irr(5, "Cash", Switch, .01)
*-- Returns......: Effective Internal Rate of Return.
*-- Parameters...: nN = number of cashflows in model
*-- cFlow = name of the 'nN' by 2 array holding the
*-- dates (col 1) and cashflows (col 2). Dates
*-- may be entered in any order except for the
*-- date, which is the date to which present
*-- value applies.
*-- lSw = name of a logical variable to be switched to
*-- indicate valid IRR returned (.t.).
*-- nGuess = optional guess for initializing search.
*-------------------------------------------------------------------------------
parameters nN, cFlow, lSw, nGuess
private nI, nPosVal, nNegVal, nCurVal, nIRR, nNuDelta, nOlDelta, nBigchange
private nSignChng, nRatio, dPDate, dMaxDate, nCurrFV, nSumDeriv
private nSumFV, dCurDate, lSw1, nIters
store 0 to nI, nPosVal, nNegVal, nIters
Store .t. to lSw
declare nCashFlow[nN,2]
store &cFlow[1,1] to dMaxDate, dPDate
*-- Transfer cashflows to a private array and separate negatives from
*-- positives. Find last date.
do while nI < nN
nI = nI+1
store &cFlow[nI,1] to nCashFlow[nI,1], dCurDate
store &cFlow[nI,2] to nCashFlow[nI,2], nCurVal
store max(dCurDate,dMaxDate) to dMaxDate
if nCurVal < 0
nNegVal = nNegVal + nCurVal
else
nPosVal = nPosVal + nCurVal
endif
enddo
if nNegVal = 0 .or. nPosVal = 0
wait "Must have at least one positive and one negative value"
endif
*-- Use initializing guess if provided, otherwise calculate from
*-- weighted average returns.
if pcount() = 4
nIRR = nGuess
else
nIRR = (((nPosVal+nNegVal-ncashflow[1,2])/-nCashFlow[1,2])-1)/;
(dMaxDate-dPDate)
endif
*-- Housekeeping summary accumulators, etc., before entering loop
store 1 to nNuDelta, nOlDelta
store 0 to nSignChng, nBigChange
store .f. to lSw1
*-- Loop until estimated rate indicated accuracy
do while abs(nNuDelta) > .000001
store 0 to nI, nSumFV, nSumDeriv
store 1 + nIrr to nRatio
do while nI < nN
nI = nI+1
*-- Calculate incremental FV and add to sum
nCurrFV = nCashFlow[nI,2] * nRatio^(dMaxDate - nCashFlow[nI,1])
nSumFV = nSumFV + nCurrFV
*-- Add incremental first derivative to derivative sum
nSumDeriv = nSumDeriv + (dMaxDate - nCashFlow[nI,1]) * nCurrFV
enddo
*-- count iterations and test for sign change of future value
if .not. lSw1 .and. nIters > 0
lSw1 = iif(sign(nOldFV) = sign(nSumFV),.f.,.t.)
endif
nIters = nIters + 1
nOldFV = nSumFV
*-- Calculate indicated change in IRR
nNuDelta = nRatio * nSumFV/nSumDeriv
*-- Test for big changes in adjusted IRR, limit to 10 times
*-- current guess for IRR and count big changes.
if abs(nNuDelta/nIRR) > 10
nNuDelta = sign(nNuDelta) * 10 * nIRR
nBigChange = nBigChange + 1
endif
nIRR = nIRR - nNuDelta && Make adjustment to guess for IRR
*-- Count reversals in adjustments to limit hunting
nSignChng = nSignChng + iif(sign(nNuDelta) + sign(nOlDelta) = 0,1,0)
nOlDelta = nNuDelta
*-- Test for hunting, too many bigchanges or too large a solution
*-- and set external switch if abnormal exit is used.
if nSignChng + nBigChange > 10 .or. abs(nIRR) > 100 .or. ;
(nIters > 9 .and. .not. lSw1)
store .f. to lSw
exit
endif
enddo
RETURN (1+nIrr)^365 -1
*-- EoF: FVxirr()
*===============================================================================
*-- In FILES.PRG
*===============================================================================
FUNCTION Used
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 02/28/1992
*-- Notes.......: Created because the picklist routine by Malcolm Rubel
*-- from DBA Magazine (11/91) calls a function that checks
*-- to see if a DBF file is open ...
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 05/15/1992 -- Original
*-- 02/08/1993 -- Discovered (thanks to Jay, and then Malcolm)
*-- a much simpler way to do this ...
*-- Called by...: Any
*-- Calls.......: None
*-- Usage.......: Used("<cFile>")
*-- Example.....: if used("Library")
*-- select library
*-- else
*-- select select()
*-- use library
*-- endif
*-- Returns.....: Logical (.t. if file is in use, .f. if not)
*-- Parameters..: cFile = file to check for
*-------------------------------------------------------------------------------
parameters cFile
RETURN (select(cFile) # 0)
*-- EoF: Used()
*-------------------------------------------------------------------------------
*-- End of Program: NEW194.PRG
*-------------------------------------------------------------------------------