home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Media Share 9
/
MEDIASHARE_09.ISO
/
progmisc
/
dblib201.zip
/
STRINGS.PRG
< prev
next >
Wrap
Text File
|
1993-04-02
|
65KB
|
1,728 lines
*-------------------------------------------------------------------------------
*-- Program...: STRINGS.PRG
*-- Programmer: Ken Mayer (CIS: 71333,1030)
*-- Date......: 03/11/1993
*-- Notes.....: String manipulation routines -- These routines are all designed
*-- to handle the processing of "Strings" (Character Strings).
*-- They range from simple checking of the location of a string
*-- inside another, to reversing the contents of a string ...
*-- and lots more. See the file: README.TXT for details on use
*-- of this (and the other) library file(s).
*-------------------------------------------------------------------------------
FUNCTION Proper
*-------------------------------------------------------------------------------
*-- Programmer..: Clinton L. Warren (VBCES)
*-- 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(<cBaseStr>)
*-- Example.....: Proper("mcdonald's") returns "McDonald's"
*-- Returns.....: Propertized string (e.g. "Test String")
*-- Parameters..: cBaseStr = 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 Dots
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 12/17/1991
*-- Notes.......: Based on ideas from Technotes, June, 1990 (see JUSTIFY() ),
*-- this function should pad a field or memvar with dots to the
*-- left, right or both sides. Note that if the field is too
*-- large for the length passed (nLength) it will be truncated.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 12/17/1991 -- Original
*-- Calls.......: ALLTRIM() Function in PROC.PRG
*-- Called by...: Any
*-- Usage.......: Dots(<cFld>,<nLength>,"<cType>")
*-- Example.....: ?? Dots(Address,25,"R")
*-- Returns.....: Field/memvar with dot leader/trailer ...
*-- Parameters..: cFld = Field/Memvar/Character String to justify
*-- nLength = Width to justify within
*-- cType = Type of justification: L=Left, C=Center,R=Right
*-------------------------------------------------------------------------------
parameters cFld,nLength,cType
private cReturn, nVal, nMore
if type("cFld")+type("nLength")+type("cType") $ "CNC,CFC"
cType = upper(cType) && just to make sure ...
cReturn = AllTrim(cFld) && trim this puppy on all sides
if len(cReturn) => nLength && check length against parameter
&& truncate if necessary
cReturn = substr(cReturn,1,nLength)
endif
do case
case cType = "L" && Left -- add trailing dots to field
cReturn = cReturn + replicate(".",nLength-len(cReturn))
case cType = "R" && Right -- add leading dots to field
cReturn = replicate(".",nLength-len(cReturn))+cReturn
case cType = "C" && Center -- add 'em to both sides ...
nVal = int( (nLength - len(cReturn)) / 2)
*-- here, we have to deal with fractions ...
nMore = mod(nlength - len(cReturn), 2)
*-- add dots on left, field, dots on right (add one if a fraction)
cReturn = replicate(".",nVal)+cReturn+;
replicate(".",nVal+iif(nMore>0,1,0))
otherwise && invalid parameter ... return nothing
cReturn = ""
endcase
else
cReturn = ""
endif
RETURN cReturn
*-- EoF: Dots()
FUNCTION CutPaste
*-------------------------------------------------------------------------------
*-- Programmer..: Martin Leon (HMAN)
*-- Date........: 03/05/1992
*-- Notes.......: Used to do a cut and paste within a field/character string.
*-- (Taken from an issue of Technotes, can't remember which)
*-- This function will not allow you to overflow the field/char
*-- string -- i.e., if the Paste part of the function would cause
*-- the returned field to be longer than it started out, it will
*-- not perform the cut/paste (STUFF()). For example, if your
*-- field were 15 characters, and you wanted to replace 5 of them
*-- with a 10 character string:
*-- (CutPaste(field,"12345","1234567890"))
*-- If this would cause the field returned to be longer than 15,
*-- the function will return the original field.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Original function 12/17/1991
*-- 03/05/1992 -- minor change to TRIM(cFLD) in the early
*-- bits, solving a minor problem with phone numbers that
*-- Dave Creek (DCREEK) discovered.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: CutPaste(<cFld>,"<cLookFor>","<cRepWith>")
*-- Example.....: Replace all city with CutPaste(City,"L.A.","Los Angeles")
*-- Returns.....: The field with text replaced (or not, if no match is found)
*-- Parameters..: cFld = Field/Memvar/Expression to replace in
*-- cLookFor = Item to look for (Cut)
*-- cRepWith = What to replace it with (Paste)
*-------------------------------------------------------------------------------
parameters cFld,cLookFor,cRepWith
private lMatched,nLookLen,nLen,nRepLen,cRetFld,nTrimLen,nCutAt
*-- Make sure they're all character fields/strings
if type("cFld")+type("cLookFor")+type("cRepWith") # "CCC"
RETURN cFld
endif
lMatched = .f.
nLookLen = len(cLookFor) && length of field to look for
nLen = len(cFld) && length of original field
nRepLen = len(cRepWith) && length of field to replace with
cRetFld = trim(cFld) && trim it ... (DCREEK's suggestion)
*-- the loop will allow a cut/paste to occur more than once in the field
do while at(cLookFor,cRetFld) > 0
lMatched = .t.
cRetFld = trim(cRetFld)
nTrimLen = len(cRetFld)
*-- the following IF statement prevents the replacement text
*-- from overflowing the length of the original string ...
if(nTrimLen - nLookLen) + nRepLen > nLen
RETURN cRetFld
endif
*-- here we figure where to "cut" at
nCutAt = at(cLookFor,cRetFld)
*-- let's do the paste ... (using dBASE STUFF() function)
cRetFld = stuff(cRetFld,nCutAt,nLookLen,cRepWith)
enddo
if .not. lMatched && no match with cLookFor, return original field
RETURN cFld
endif
RETURN cRetFld
*-- EoF: CutPaste
FUNCTION LastWord
*-------------------------------------------------------------------------------
*-- Programmer..: Martin Leon (HMAN)
*-- Date........: 12/19/1991
*-- Notes.......: Returns the last word in a character string.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 12/19/1991 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: LastWord("<cString>")
*-- Example.....: ? LastWord("This is a test string")
*-- Returns.....: The Last word (bracketed with spaces), i.e.:"string"
*-- Parameters..: cString = string to be searched
*-------------------------------------------------------------------------------
parameters cString
private cReturn
cReturn = trim(cString)
do while at(" ",cReturn) # 0
cReturn = substr(cReturn,at(" ",cReturn)+1)
enddo
RETURN cReturn
*-- EoF: LastWord()
FUNCTION VStretch
*-------------------------------------------------------------------------------
*-- Programmer..: Martin Leon (HMAN -- Ashton Tate/Borland BBS)
*-- Date........: 10/30/91
*-- Notes.......: Used to display a long character field, with proper word wrap
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Once upon a time, Martin helped me write a more complicated
*-- routine for use in a browse table. He came up with this
*-- much less complex version recently and sent to me via EMail.
*-- (10/30/1991 -- Original release for the library)
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ?VStretch(<cLFld>,<nULRow>,<nULCol>,<nBRRow>,<nBRCol>)
*-- Example.....: ?VStretch(Notes,20,10,24,60,"rg+/gb")
*-- Returns.....: "" (Nul)
*-- Parameters..: cLFld = Long Field to be wrapped on screen
*-- nULRow = Upper Left Row of window
*-- nULCol = Upper Left Column
*-- nBRRow = Bottom Right Row of window
*-- nBRCol = Bottom Right Column
*-------------------------------------------------------------------------------
parameter cLFld,nULRow,nULCol,nBRRow,nBRCol
private nWinWidth
nWinWidth = ltrim(str((nBRCol - nULCol)-1,2))
*-- define window without any border ...
define window wStretch from nULRow,nULCol to nBRRow,nBRCol none
activate window wStretch
*-- make sure window is empty ...
clear
*-- display field
?? cLFld picture "@V"+nWinWidth at 0 && the @V function causes word wrap
save screen to sTemp
activate screen
release window wStretch
restore screen from sTemp
release screen sTemp
RETURN ""
*-- EoF: VStretch()
FUNCTION AtCount
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: returns the number of times FindString is found in Bigstring
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: AtCount("<cFindStr>","<cBigStr>")
*-- Example.....: ? AtCount("Test","This is a Test string, with Test data")
*-- Returns.....: Numeric value
*-- Parameters..: cFindStr = string to find in cBigStr
*-- cBigStr = string to look in
*-------------------------------------------------------------------------------
parameters cFindstr, cBigstr
private cTarget, nCount
cTarget = cBigstr
nCount = 0
do while .t.
if at( cFindStr,cTarget ) > 0
nCount = nCount + 1
cTarget = substr( cTarget, at( cFindstr, cTarget ) + 1 )
else
exit
endif
enddo
RETURN nCount
*-- EoF: AtCount()
FUNCTION IsAlNum
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Returns .T. if the first character of cChar is alphanumeric,
*-- otherwise it is false.
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsAlNum("<cChar>")
*-- Example.....: ? IsAlNum("Test")
*-- Returns.....: Logical
*-- Parameters..: cChar = character string to check for Alphanumeric ...
*-------------------------------------------------------------------------------
parameters cChar
RETURN isalpha( cChar ) .or. left( cChar, 1 ) $ "0123456789"
*-- EoF: IsAlNum()
FUNCTION IsAscii
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Returns .t. if the first character of cChar is in the lower
*-- half of the ASCII set ( value < 128 )
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsAscii("<cChar>")
*-- Example.....: ? IsAscii("Teststring")
*-- Returns.....: Logical
*-- Parameters..: cChar = string to test
*-------------------------------------------------------------------------------
parameters cChar
RETURN asc( cChar ) < 128
*-- EoF: IsAscii()
FUNCTION IsCntrl
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Returns .t. if the first character of cChar is a delete,
*-- or a control character.
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsCntrl("<cChar>")
*-- Example.....: ? IsCntrl("Test")
*-- Returns.....: Logical
*-- Parameters..: cChar = string to test
*-------------------------------------------------------------------------------
parameters cChar
private nCharval
nCharval = asc(cChar)
RETURN nCharval = 127 .or. nCharval < 32
*-- EoF: IsCntrl()
FUNCTION IsDigit
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: If the first character of cChar is a digit, returns .T.
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsDigit("<cChar>")
*-- Example.....: ? IsDigit("123Test")
*-- Returns.....: Logical
*-- Parameters..: cChar = string to test
*-------------------------------------------------------------------------------
parameters cChar
RETURN left( cChar, 1 ) $ "0123456789"
*-- EoF: IsDigit()
FUNCTION IsPrint
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Returns .t. if first character of cChar is a printing
*-- character (space through chr(126) ).
*-- Written for.: dBASE IV
*-- Rev. History: Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsPrint("<cChar>")
*-- Example.....: ? IsPrint("Test")
*-- Returns.....: Logical
*-- Parameters..: cChar = string to test
*-------------------------------------------------------------------------------
parameters cChar
private nCharval
nCharval = asc(cChar)
RETURN nCharval > 31 .and. nCharval < 127
*-- EoF: IsPrint()
FUNCTION IsXDigit
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Returns .t. if first character of cChar is a possible
*-- hexidecimal digit.
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsXDigit("<cChar>")
*-- Example.....: ? IsXDigit("F000")
*-- Returns.....: Logical
*-- Parameters..: cChar = string to test
*-------------------------------------------------------------------------------
parameters cChar
RETURN left( cChar, 1 ) $ "0123456789ABCDEFabcdef"
*-- EoF: IsXDigit()
FUNCTION IsSpace
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Returns .T. if first character of cChar is in set of space,
*-- tab, carriage return, line feed, vertical tab or formfeed,
*-- otherwise .F. Differs from C function of the same
*-- name in treating chr(141), used as carriage return
*-- in dBASE memo fields, as a space.
*-- Written for.: dBASE IV
*-- Rev. History: Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsSpace("<cChar>")
*-- Example.....: ? IsSpace(" Test")
*-- Returns.....: Logical
*-- Parameters..: cChar = string to test
*-------------------------------------------------------------------------------
parameters cChar
private cSpacestr
cSpacestr = " "+chr(9)+chr(10)+chr(11)+chr(12)+chr(13)+chr(141)
RETURN left( cChar, 1 ) $ cSpacestr
*-- EoF: IsSpace()
FUNCTION Name2Label
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Returns a name held in five separate fields or memvars as it
*-- should appear on a label of a given length in characters.
*-- The order of abbreviating is somewhat arbitrary--you may
*-- prefer to remove the suffix before the prefix, or to remove
*-- both before abbreviating the first name. This can be
*-- accomplished by rearranging the CASE statements, which operate
*-- in the order of their appearance.
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Name2Label(<nLength>,"<cPrefix>","<cFirstName>",;
*-- "<cMidName>","<cLastName>","<cSuffix>")
*-- Example.....: ? Name2Label(20,"The Rev.","Elmore","Norbert","Smedley","III")
*-- Returns.....: Character String, in this case "E. N. Smedley, III"
*-- Parameters..: nLength = length of label
*-- cPrefix = Prefix to name, such as Mr., Ms., Dr...
*-- cFirstName = self explanatory
*-- cMiddleName = self explanatory
*-- cLastName = self explanatory
*-- cSuffix = "Jr.", "M.D.", "PhD", etc.
*-------------------------------------------------------------------------------
parameters nLength, cPrefix, cFirstname, cMidname, cLastname, cSuffix
private cTrypref, cTryfirst, cTrymid, cTrylast, cTrysuff, cTryname
cTrypref = ltrim( trim( cPrefix ) )
cTryfirst = ltrim( trim( cFirstname ) )
cTrymid = ltrim( trim( cMidname ) )
cTrylast = ltrim( trim( cLastname ) )
cTrysuff = ltrim( trim( cSuffix ) )
do while .t.
cTryname = cTrylast
if "" # cTrymid
cTryname = cTrymid + " " + cTryname
endif
if "" # cTryfirst
cTryname = cTryfirst + " " + cTryname
endif
if "" # cTrypref
cTryname = cTrypref + " " + cTryname
endif
if "" # cTrysuff
cTryname = cTryname + ", " + cTrysuff
endif
if len(cTryname) <= nLength
exit
endif
do case
case "" # cTrymid .AND. right( cTrymid, 1 ) # "."
cTrymid = left( cTrymid, 1 ) + "." && convert middle name to initial
case "" # cTryfirst .AND. right( cTryfirst, 1 ) # "."
cTryfirst = left( cTryfirst, 1 ) + "." && convert first name to initial
case "" # cTrypref
cTrypref = "" && drop prefix
case "" # cTrysuff
cTrysuff = "" && drop suffix
case "" # cTrymid
cTrymid = "" && drop middle initial
case "" # cTryfirst
cTryfirst = "" && drop first initial
otherwise
cTrylast = left( cTrylast, nLength ) && truncate last name
endcase
enddo
RETURN cTryName
*-- EoF: Name2Label()
FUNCTION StrPBrk
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Search string for first occurrence of any of the
*-- characters in charset. Returns its position as
*-- with at(). Contrary to ANSI.C definition, returns
*-- 0 if none of characters is found.
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: StrPBrk("<cCharSet>","<cBigStr>")
*-- Example.....: ? StrPBrk("Tt","This is a Test string, with Test data")
*-- Returns.....: Numeric value
*-- Parameters..: cCharSet = characters to look for in cBigStr
*-- cBigStr = string to look in
*-------------------------------------------------------------------------------
parameters cCharset, cBigstring
private nPos, nLooklen
nPos = 0
nLooklen = len( cBigstring )
do while nPos < nLooklen
nPos = nPos + 1
if at( substr( cBigstring, nPos, 1 ), cCharset ) > 0
exit
endif
enddo
RETURN iif(nPos=nLookLen,0,nPos)
*-- EoF: StrPBrk()
FUNCTION StrRev
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Reverses a string of characters, returns that reversed string.
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: StrRev("<cAnyStr>")
*-- Example.....: ? StrRev("This is a Test")
*-- Returns.....: Character string
*-- Parameters..: cAnyStr = String of characters to reverse ...
*-------------------------------------------------------------------------------
parameters cAnystr
private cRevstring, nX,nY
nX = len( cAnystr )
nY = 1
cRevstring = space( nX )
do while nX > 0
cRevstring = stuff(cRevstring,nY,1,substr(cAnyStr,nX,1))
nY = nY + 1
nX = nX - 1
enddo
RETURN cRevstring
*-- EoF: StrRev()
FUNCTION Strip2Val
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Strip characters from the left of a string until reaching
*-- one that might start a number.
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Strip2Val("<cStr>")
*-- Example.....: ? Strip2Val("Test345")
*-- Returns.....: character string
*-- Parameters..: cStr = string to search
*-------------------------------------------------------------------------------
parameters cStr
private cNew
cNew = cStr
do while "" # cNew
if left( cNew, 1 ) $ "-.0123456789"
exit
endif
cNew = substr( cNew, 2 )
enddo
RETURN cNew
*-- EoF: Strip2Val()
FUNCTION StripVal
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Strip characters from the left of the string until
*-- reaching one that is not part of a number. A hyphen
*-- following numerics, or a second period,
*-- is treated as not part of a number.
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: StripVal("<cStr>")
*-- Example.....: ? StripVal("123.2Test")
*-- Returns.....: Character
*-- Parameters..: cStr = string to test
*-------------------------------------------------------------------------------
parameters cStr
private cNew, cChar, lGotminus, lGotdot
cNew = cStr
store .f. to lGotminus, lGotdot
do while "" # cNew
cChar = left( cNew, 1 )
do case
case .not. cChar $ "-.0123456789"
exit
case cChar = "-"
if lGotminus
exit
endif
case cChar = "."
if lGotdot
exit
else
lGotdot = .T.
endif
endcase
cNew = substr( cNew, 2 )
lGotminus = .T.
enddo
RETURN cNew
*-- EoF: StripVal()
FUNCTION ParseWord
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340).
*-- Date........: 04/26/1992
*-- Notes.......: returns the first word of a string
*-- Written for.: dBASE IV, 1.1, 1.5
*-- Rev. History: 04/26/1992 -- Original Release
*-- Calls : None
*-- Called by...: Any
*-- Usage.......: ? ParseWord(<cString>)
*-- Example.....: Command = ParseWord( cProgramline )
*-- Parameters..: cString - character string to be stripped.
*-- Returns : that portion, trimmed on both ends, of the passed string
*-- that includes the characters up to the first interior space.
*-------------------------------------------------------------------------------
parameters string
private cW
cW = trim( ltrim( string ) )
RETURN iif( " " $ cW, rtrim( left( cW, at( " ", cW ) - 1 ) ), cW )
*-- EoF: ParseWord()
FUNCTION StripWord
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340).
*-- Date........: 04/26/1992
*-- Notes.......: discards first word of a string
*-- Written for.: dBASE IV, 1.1, 1.5
*-- Rev. History: 04/26/1992 -- Original Release
*-- Calls : None
*-- Called by...: Any
*-- Usage.......: ? StripWord(<cString>)
*-- Example.....: Lastname = StripWord( "Carrie Nation" )
*-- Parameters..: cString - character string to be stripped.
*-- Returns : string trimmed of trailing spaces, and trimmed on the
*-- left to remove leading spaces and, if the passed string
*-- contained interior spaces, also to remove everything before
*-- the first nonspace character after the first interior space.
*-------------------------------------------------------------------------------
parameters string
private cW
cW = trim( ltrim( string ) )
RETURN iif( " " $ cW, ltrim( substr( cW, at( " ", cW ) + 1 ) ), cW )
*-- EoF: StripWord()
FUNCTION Plural
*-------------------------------------------------------------------------------
*-- Programmer..: Kelvin Smith (KELVIN)
*-- Date........: 08/27/1992
*-- Notes.......: Returns number in string form, and pluralized form of
*-- noun, including converting "y" to "ies", unless the "y"
*-- is preceded by a vowel. Works with either upper or lower
*-- case nouns (based on last character).
*-- As no doubt all are aware, English includes many
*-- irregular plural forms; to trap for all is not worthwhile
*-- (how often do you really need to print out die/dice?).
*-- This should handle the vast majority of needs.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 08/27/1992 1.0 - Original version
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Plural(<nCnt>, <cNoun>)
*-- Examples....: Plural(1, "flag") returns "1 flag"
*-- Plural(0, "store") returns "0 stores"
*-- Plural(5, "COMPANY") returns "5 COMPANIES"
*-- Returns.....: String with number and noun, no trailing spaces
*-- Parameters..: nCnt = Count value for noun (how many of cNoun?)
*-- cNoun = Noun to pluralize
*-------------------------------------------------------------------------------
parameters nCnt, cNoun
private cNounOut, cLast, c2Last, cLast2, lUpper
if nCnt = 1
cNounOut = trim(cNoun)
else
cNounOut = trim(cNoun) && No trailing spaces
cLast = right(cNounOut, 1)
lUpper = isupper(cLast) && Upper case?
cLast = upper(cLast)
c2Last = upper(substr(cNounOut, len(cNounOut) - 1, 1))
cLast2 = c2Last + cLast
* If the noun ends in "Y", normally we change "Y" to "IES".
* However, if the "Y" is preceded by a vowel, just add "S".
if cLast = "Y" .and. at(c2Last, "AEIOU") = 0
cNounOut = left(cNounOut, len(cNounOut) - 1) +;
iif(lUpper, "IES", "ies")
else
if cLast = "S" .or. cLast = "X" ;
.or. cLast2 = "CH" .or. cLast2 = "SH"
cNounOut = cNounOut + iif(lUpper, "ES", "es")
else
cNounOut = cNounOut + iif(lUpper, "S", "s")
endif
endif
endif
RETURN ltrim(str(nCnt)) + " " + cNounOut
*-- EoF: Plural()
FUNCTION StrComp
*-------------------------------------------------------------------------------
*-- Programmer..: Sri Raju (Borland Technical Support)
*-- Date........: 08/01/1992
*-- Notes.......: From Technotes, August, 1992, "Strings and Things"
*-- This function compares the contents of two strings.
*-- If cStr1 is less than cStr2, return -1
*-- If cStr1 is equal to cStr2, return 0
*-- If cStr1 is greaterh than cStr2, return 1
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 08/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: StrComp(<cStr1>,<cStr2>)
*-- Example.....: ? StrComp("TEST","TEXT")
*-- Returns.....: Numeric (see notes)
*-- Parameters..: cStr1 = First string
*-- cStr2 = Second string
*-------------------------------------------------------------------------------
parameters cStr1,cStr2
cExact = set("EXACT")
set exact on
do case
case cStr1 = cStr2
nReturn = 0
case cStr1 > cStr2
nReturn = 1
case cStr1 < cStr2
nReturn = -1
endcase
set exact &cExact
RETURN nReturn
*-- EoF: StrComp()
FUNCTION StrOccur
*-------------------------------------------------------------------------------
*-- Programmer..: Sri Raju (Borland Technical Support)
*-- Date........: 08/01/1992
*-- Notes.......: TechNotes, August, 1992, "Strings and Things"
*-- Calculates the number of occurences of a string in another
*-- given character or memo field.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 08/01/1992 -- Original Release
*-- Calls.......: NumOccur() Function in STRINGS.PRG
*-- Called by...: Any
*-- Usage.......: StrOccur(<cInString>,<cFindString>)
*-- Example.....: ? StrOccur("NOTES","every") && find all occurences of "every"
*-- && in Memo: NOTES.
*-- Returns.....: Numeric
*-- Parameters..: cInString = "Large" string -- to be looked "in". If a Memo,
*-- name of memo field must be in quotes or passed
*-- as a memvar, and record pointer must be on
*-- correct record.
*-- cFindString = "Small" string -- to be found in larger string.
*-------------------------------------------------------------------------------
parameters cInString, cFindString
nBytes = 0
lMemo = .f.
nReturn = 0
if pCount() # 2 && not enough parameters or too many parameters passed ...
?"ERROR. Usage: StrOccur(<string>|<memo fld name>,<string>)"
RETURN (0)
endif
if type("CINSTRING") = "M"
lMemo = .t.
else
RETURN (NumOccur(cInstring,cFindString))
endif
*-- process a memo ...
if lMemo
nTotLen = len(&cInString)
n = 1
nOffSet = 0
cTempStr = " "
do while nOffSet <= nTotLen
cTempStr = "arr"+ltrim(str(n)) && ?
if (nOffSet + 254) > nTotLen
cTempStr = substr(&cInString,nOffSet+1,nOffSet+254)
else
cTempStr = substr(&cInString,nOffSet+1,nTotLen)
endif
nReturn = nReturn + NumOccur(cTempStr,cFindStr)
n = n + 1
nOffSet = nOffSet + 254
enddo
endif
RETURN (nReturn)
*-- EoF: StrOccur()
FUNCTION NumOccur
*-------------------------------------------------------------------------------
*-- Programmer..: Sri Raju (Borland Technical Support)
*-- Date........: 08/01/1992
*-- Notes.......: TechNotes, August, 1992, "Strings and Things"
*-- Calculates the number of occurences of a string in another
*-- string.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 08/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: StrOccur() Function in STRINGS.PRG
*-- Usage.......: NumOccur(<cInString>,<cFindString>)
*-- Example.....: ? NumOccur("This is a string","is")
*-- Returns.....: Numeric (integer -- # of times string occurs)
*-- Parameters..: cInString = "Large" string -- to be looked 'in'
*-- cFindString = "Small" string -- to be looked for
*-------------------------------------------------------------------------------
parameters cInString, cFindString
cHoldStr = " "
nReturn = 0
cInit = cInString
do while len(cInit) => 1
cHoldStr = cInit
if at(cFindString,cHoldStr) > 0
nReturn = nReturn + 1
cInit = substr(cHoldStr,at(cFindString,cHoldStr)+len(cFindString))
else
cInit = ""
endif
enddo
RETURN (nReturn)
*-- EoF: NumOccur()
FUNCTION ReplMemo
*-------------------------------------------------------------------------------
*-- Programmer..: Sri Raju (Borland Technical Support)
*-- Date........: 08/01/1992
*-- Notes.......: TechNotes, August, 1992, "Strings and Things"
*-- Globally searches and replaces a string with another string
*-- in a character field/memvar or memo field.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 08/01/1992 -- Original Release
*-- Calls.......: MemStuff() Function in STRINGS.PRG
*-- Called by...: Any
*-- Usage.......: ReplMemo("cSource",<cCurrStr>,<cNewStr>)
*-- Example.....: ?ReplMemo("NOTES","Test","testing")
*-- Returns.....: .T. if a memo field, or character string with changes
*-- Parameters..: cSource = Source to make changes IN
*-- cCurrStr = Current string (item(s)) to be changed
*-- cNewStr = Change 'Current' to this ....
*-------------------------------------------------------------------------------
parameters cSource, cCurrStr, cNewStr
cConsole = set("CONSOLE")
nBytes = 0
nPointer = 0
nMaster = 0
*-- error
if pcount() # 3 && valid number of parms
?"Error."
?"Usage: ReplMemo(<Memo/string>,<Current String>,<New String>)"
RETURN .f.
endif
*-- start
if type(cSource) = "M" && if a memo ...
if len(&cSource) > 254 && if > 254 char
cNewFile = (cSource)+".TXT" && create a temp file
erase cNewFile
nPointer = fcreate(cNewFile,"A")
endif
else
*-- if not a memo, just perform the replace ...
RETURN (MemStuff(cSource,cCurrStr,cNewStr))
endif
*-- memo handling ...
nTotLen = len(&cSource)
nCounter = 1
nOffSet = 0
do while nOffSet <= nTotLen
cTempStr = "arr"+ltrim(str(nCounter))
if (nOffSet+200) < nTotLen
cTempStr = substr(&cSource,nOffSet+1,200)
else
cTempStr = substr(&cSource,nOffSet+1,nTotLen)
endif
cTemp2 = space(200)
cTemp2 = MemStuff(cTempStr, cCurrStr, cNewStr)
nBytes = fwrite(nPointer,cTemp2)
nCounter = nCounter + 1
nOffSet = nOffSet + 200
enddo
nNull = fclose(nPointer)
append memo &cSource) from (newfile) overwrite
RETURN .T.
*-- EoF: ReplMemo()
FUNCTION MemStuff
*-------------------------------------------------------------------------------
*-- Programmer..: Sri Raju (Borland Technical Support)
*-- Date........: 08/01/1992
*-- Notes.......: TechNotes, August, 1992, "Strings and Things"
*-- Replaces a specific string in a character string, by another,
*-- and returns the resultant string.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 08/01/1992 -- Original Release
*-- Calls.......: Stub() Function in STRINGS.PRG
*-- Called by...: ReplMemo() Funciton in STRINGS.PRG
*-- Usage.......: MemStuff(<cSource>,<cCurrStr>,<cNewStr>)
*-- Example.....: ? MemStuff(cTestStr,"Test","Testing")
*-- Returns.....: Character
*-- Parameters..: cSource = Source to make changes IN
*-- cCurrStr = Current string (item(s)) to be changed
*-- cNewStr = Change 'Current' to this ....
*-------------------------------------------------------------------------------
parameters cSource, cCurrStr, cNewStr
private cSource, cCurrStr, cNewStr
cRetStr = ""
cHoldStr = ""
cInitStr = cSource
do while len(cInitStr) => 1
cHoldStr = cInitStr
if at(cCurrStr,cNewStr) > 0
cTemp = substr(cInitStr,1,at(cCurrStr,cHoldStr))
nPos = at(cCurrStr,cHoldStr)
cReturn = cReturn+Stub(cTemp,nPos,cNewStr)
cInitStr = substr(cHoldStr,at(cReplace,cHoldStr)+len(cNewStr))
else
cReturn = trim(cInitStr)+trim(cHoldStr)
cInitStr = ""
endif
enddo
RETURN (cReturn)
*-- EoF: MemStuff()
FUNCTION Stub
*-------------------------------------------------------------------------------
*-- Programmer..: Sri Raju (Borland Technical Support)
*-- Date........: 08/01/1992
*-- Notes.......: This returns a specific number of characters from the given
*-- string specified by the parameter innum, added to the
*-- third parameter.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 08/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: MemStuff() Function in STRINGS.PRG
*-- Usage.......: Stub(<cString>,nIn,<cIn>)
*-- Example.....: ? Stub(cTest,5,"Test")
*-- Returns.....: Character
*-- Parameters..: cString = Character string to look in
*-- nIn = # of characters to return
*-- cIn = characters to add to the end of ...
*-------------------------------------------------------------------------------
parameters cString, nIn, cIn
RETURN trim(substr(cString,1,nIn-1)+cIn)
*-- EoF: Stub()
FUNCTION FirstMem
*-------------------------------------------------------------------------------
*-- Programmer..: Sri Raju (Borland Technical Support)
*-- Date........: 08/01/1992
*-- Notes.......: TechNotes, August, 1992, "Strings and Things"
*-- Capitalizes the first character of all the words in the string
*-- that is passed as a parameter, and returns the resultant
*-- string. If a name of a memo field is pass as the parameter,
*-- it re-writes the memo field, and returns a .T.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 08/01/1992 -- Original Release
*-- Calls.......: FirstCap() Function in STRINGS.PRG
*-- Called by...: None
*-- Usage.......: FirstMem(cInStr)
*-- Example.....: ? FirstMem("this is a string")
*-- Returns.....: Either character string with first letter of each word
*-- capitalized, or .T. (if a Memo).
*-- Parameters..: cInStr = character string or Memo Field name
*-------------------------------------------------------------------------------
parameters cInStr
nBytes = 0
lMemo = .F.
lReturn = .T.
nFPtr = 0
nMasterCnt = 0
if pcount() # 1
? "Error."
? "Usage:- FIRSTMEM (<string>) "
lMemo = .F.
else
if type(instr) = "M"
lMemo = .T.
cNewFile = (cInStr) + ".txt"
erase (cnewfile)
nFPtr = fcreate(cNewFile, "A")
else
lReturn = .F.
endif
endif
if lMemo
nTotLen = len(&CInStr)
nCntr = 1
nOffSet = 0
do while nOffSet <= nTotLen
if (nOffSet + 250) < nTotLen
cTemp = substr(&cInStr, nOffSet + 1, 250)
else
cTemp = substr(&CInStr, nOffSet + 1, nTotLen)
endif
cTempStr = space(250)
cTempStr = FirstCap(cTemp)
nBytes = fwrite(nFPtr, cTempStr)
nCntr = nCntr + 1
nOffSet = nOffSet + 250
enddo
x = fclose(nFPtr)
append memo &cInStr from (CNewFile) overwrite
endif
if lMemo .or. lReturn
RETURN (.F.)
else
RETURN (FirstCap(cInStr))
endif
*-- EoF: FirstMem()
FUNCTION FirstCap
*-------------------------------------------------------------------------------
*-- Programmer..: Sri Raju (Borland Technical Support)
*-- Date........: 08/01/1992
*-- Notes.......: TechNotes, August, 1992, "Strings and Things"
*-- Capitalizes the first character of a string.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 08/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: FirstMem() Function in STRINGS.PRG
*-- Usage.......: FirstCap(<cInString>)
*-- Example.....: ?FirstCap("stringofcharacters")
*-- Returns.....: String with first character captilized.
*-- Parameters..: cInString = String to cap the first letter of
*-------------------------------------------------------------------------------
parameters cInString
cRetString = ""
cIStr = cInString
do while len(cIStr) > 1
nPos = at(" ", cIStr)
if nPos <> 0
cRetString = cRetString + upper(left(cIStr, 1)) + ;
substr(cIStr, 2, nPos-1)
else
cRetString = cRetString + upper(left(cIStr, 1)) + substr(cIStr, 2)
exit
endif
do while substr(cIStr, nPos, 1) = " "
nPos = nPos + 1
enddo
cIStr = substr(cIStr, nPos)
enddo
RETURN (cRetString)
*-- EoF: FirstCap()
FUNCTION StripND
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
*-- Date........: 01/04/1993
*-- Notes.......: Strips characters out of a numeric character string (like
*-- perhaps, a date ... 01/04/93 would become 010493)
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/04/1993 -- Original Release
*-- Calls.......: IsDigit() Function in STRINGS.PRG
*-- Called by...: Any
*-- Usage.......: StripND(<cNumArg>)
*-- Example.....: keyboard stripnd(dtoc(date()))
*-- Returns.....: character string
*-- Parameters..: cNumArg = Character memvar containing a "numeric" string
*-------------------------------------------------------------------------------
parameters cNumArg
private cNumStr, nLen, cRetVal, nCount, cChar
cNumStr = cNumArg
nLen = len(cNumStr)
cRetVal = ""
nCount = 0
do while nCount <= nLen
nCount = nCount + 1
cChar = substr(cNumStr,nCount,1)
if isdigit(cChar)
cRetVal = cRetVal+cChar
endif
enddo
RETURN cRetVal
*-- EoF: StripND()
FUNCTION Strip
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth Chan [ZAK] (CIS: 71542,2712)
*-- Date........: 01/05/1993
*-- Notes.......: Strips out specified character(s) from a string
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/05/1993 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Strip(<cVar>,<cArg>)
*-- Example.....: ?strip(dtoc(date(),"/")
*-- Returns.....: Character
*-- Parameters..: cVar = variable/field to remove character(s) from
*-- cArg = item to remove from cVar
*-------------------------------------------------------------------------------
parameter cVar, cArg
do while cArg $ cVar
cVar = stuff( cVar, at( cArg, cVar ), 1, "" )
enddo
RETURN cVar
*-- EoF: Strip()
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
FUNCTION BreakName
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/21/1993
*-- Notes.......: Returns part of a name based on user positioning of cursor.
*-- This function requires the programmer to set up any window
*-- desired; the writing surface must have a minimum width of
*-- 45 characters or the length of the name plus 2, whichever
*-- is greater, and must be at least 4 rows high.
*-- Written for.: dBASE IV 1.5 ( earlier versions will require changing
*-- the optional parameter to a required one )
*-- Rev. History: 03/21/1993 -- Original
*-- Calls.......: NamePart() function in STRINGS.PRG
*-- MarkLine() function in STRINGS.PRG
*-- Called by...: Any
*-- Usage.......: Breakname("<cName>" [,"<cPart>"] )
*-- Example.....: LastName = BreakName( "Dr. E. N. Smedley III, "L" )
*-- Returns.....: character = substring containing part of the name
*-- Parameters..: cName = Name to parse
*-- cPart = optional, a character from the set below:
*-- P -- prefix( es )
*-- F -- first name
*-- M -- middle name or initial
*-- L -- last name
*-- S -- suffix( es )
*-------------------------------------------------------------------------------
parameters cName, cPart
private nPos, cP, cParts, nPart, cPrompts, nFirst, nLast, cRet
private nRow, nCol, nOff
cRet = ""
store 0 to nPos, nParts, nPart
cParts = "PFMLS"
* 1 2 3 4
* Ruler--> 123456789012345678901234567890123456789012
cPrompts = "desired part prefix(es) first name " ;
+ "middle name(s)last name suffix(es)"
if type( "cPart" ) # "C" .or. "" = cPart
nPos = 1
cP = "?"
endif
if nPos = 0
cP = upper( left( ltrim( cPart ), 1 ) )
nPart = at( cP, cParts )
endif
if nPart = 0
nPos = 1
else
nPos = NameMark( cName, cP, "B" )
nPos = iif( nPos = 0, len( cName ) + 1, nPos )
endif
nRow = row()
nCol = col()
nOff = int( ( 43 - len( cName ) ) / 2 )
@ nRow, nCol + nOff clear to nRow + 4, nCol + max( 45, 45 - nOff )
@ nRow, nCol say "Please use the arrow keys to place the cursor"
@ nRow + 1, nCol say "on the FIRST character of the "
@ nRow + 1, col() say trim( substr( cPrompts, nPart * 14 + 1, 14 ) ) ;
+ ":"
@ nRow + 4, nCol + nOff say ""
nFirst = MarkLine( cName, nPos )
if nFirst = 0 .or. nFirst > len( cName )
RETURN cRet
endif
if cP = "S"
nLast = len( trim( cName ) )
else
@ nRow, nCol + nOff clear to nRow + 4, nCol + max( 43, 43 - nOff )
@ nRow, nCol say "Please use the arrow keys to place the cursor"
@ nRow + 1, nCol say " on the LAST character of the "
@ nRow + 1, col() say trim( substr( cPrompts, nPart * 14 + 1, 14 ) ) ;
+ ":"
nPos = NameMark( cName, cP, "E" )
@ nRow + 4, nCol + nOff say ""
nLast = MarkLine( cName, nPos )
endif
if nLast > nFirst
cRet = substr( cName, nFirst, nLast - nFirst + 1 )
endif
RETURN cRet
*-- EoF: BreakName()
FUNCTION NamePart
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/21/1993
*-- Notes.......: Guesses which portion of a name held in a single variable
*-- in the usual printing order corresponds to the letter code
*-- given for prefix, first name, middle names, last name or
*-- suffixes and returns that portion. This does not work
*-- correctly for all names and is recommended to be used
*-- only with some human interpretation of the results.
*-- Written for.: dBASE IV 1.5
*-- Rev. History: 03/21/1993 -- Original
*-- Calls.......: NameMark() function in STRINGS.PRG
*-- Called by...: Any
*-- Usage.......: NamePart( <cName> ,<cPart> )
*-- Example.....: Suffix = NamePart( "John Doe Jr. Ph. D.", "S" )
*-- Returns.....: character = substring, part of the name, or null string
*-- Parameters..: cName = Name to parse
*-- cPart = a character from the set below:
*-- P -- prefix
*-- F -- first name
*-- M -- middle name(s) or initial(s) or both
*-- L -- last name
*-- S -- suffix(es)
*-------------------------------------------------------------------------------
parameters cName, cPart
private nStart, nStop, cP, nTrimmed, nMark, cN1, cN2
store 0 to nStart, nStop
cRet = ""
if type( "cPart" ) # "C" .or. "" = cPart .or. "" = cName
RETURN cRet
endif
cP = upper( left( cPart, 1 ) )
if .not. cP $ "PFMLS"
RETURN cRet
endif
nStart = NameMark( cName, cP, "B" )
nStop = NameMark( cName, cP, "E" )
if nStop > nStart .and. nStart > 0
cRet = substr( cName, nStart, nStop - nStart + 1 )
endif
RETURN cRet
*-- EoF: NamePart()
FUNCTION NameMark
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/21/1993
*-- Notes.......: Guesses which portion of a name held in a single variable
*-- in the usual printing order corresponds to the letter code
*-- given for prefix, first name, middle names, last name or
*-- suffixes and returns the position of the character that
*-- begins or ends that portion. This does not work properly
*-- for all names and is recommended to be used with MarkLine(),
*-- as in BreakName().
*-- Written for.: dBASE IV 1.5
*-- Rev. History: 03/21/1993 -- Original
*-- Calls.......: Rat() function in STRINGS.PRG
*-- Called by...: Any
*-- Usage.......: NameMark( <cName> ,<cPart>, <cEnd> )
*-- Example.....: Suffix = NamePart( "John Doe Jr. Ph. D.", "S", "B" )
*-- Returns.....: numeric = position in cName of requested character, or 0 the name, or null string
*-- Parameters..: cName = Name to parse
*-- cPart = a character from the set below:
*-- P -- prefix
*-- F -- first name
*-- M -- middle name(s) or initial(s) or both
*-- L -- last name
*-- S -- suffix(es)
*-- cEnd = a character from the set below:
*-- B or F -- first char of the part
*-- E or L -- last char of the part
*-------------------------------------------------------------------------------
parameters cName, cPart, cEnd
private nStart, nStop, nRet, cP, cE, nTrimmed, nM1, nM2, cN1, cN2, lC
* intialize and check for proper parameters
store 0 to nStart, nStop, nRet
if type( "cPart" ) # "C" .or. type( "cName" ) # "C" .or. ;
type( "cEnd" ) # "C" .or. "" = cName .or. "" = cPart .or. "" = cEnd
RETURN nRet
endif
cP = upper( left( cPart, 1 ) )
if .not. cP $ "PFMLS"
RETURN nRet
endif
cE = upper( left( cEnd, 1 ) )
do case
case cE $ "BF"
cE = "B"
case cE $ "EL"
cE = "E"
otherwise
RETURN nRet
endcase
* remove end spaces but count leading ones
cN1 = ltrim( cName )
nTrimmed = len( cName ) - len( cN1 )
cN1 = trim( cN1 )
* find interior space; if none we're done
nM1 = at( " ", cN1 )
if nM1 = 0
cRet = iif( cP = "L", cN1, "" )
RETURN cRet
endif
* anything ending in a period but one initial is treated as a prefix
if nM1 > 3 .and. substr( cN1, nM1 - 1, 1 ) = "."
if cP = "P"
nStart = 1
nStop = nM1 - 1
else
cN2 = ltrim( substr( cN1, nM1 + 1 ) )
nTrimmed = nTrimmed + len( cN1 ) - len( cN2 )
cN1 = cN2
nM1 = at( " ", cN1 )
endif
else
if cP = "P"
nStart = 1
endif
endif
* if we're not looking for prefix, first word is first name
* if not looking for it either, trim it off and adjust space count
if nStart = 0
if cP = "F"
nStart = 1
nStop = nM1 - 1
else
cN2 = ltrim( substr( cN1, nM1 + 1 ) )
nTrimmed = nTrimmed + len( cN1 ) - len( cN2 )
cN1 = cN2
endif
endif
* if not done yet, look for suffix. Anything after a comma plus
* anything ending with period and certain common differentiators
if nStart = 0
nM1 = at( ",", cN1 )
if nM1 > 0
cN1 = left( cN1, nM1 - 1 )
nM2 = nM1
else
nM2 = len( cN1 ) + 1
endif
nM1 = rat( " ", cN1 )
lC = .T.
do while lC
lC = .F.
if upper( right( cN1, 3 ) ) $ "III 2D 2ND 3D 3RD"
nM1 = len( cN1 ) - iif( left( right( cN1, 3 ), 1 ) = " ", ;
3, 4 )
cN1 = left( cN1, nM1 )
lC = .T.
nM2 = nM1 + 2
nM1 = rat( " ", cN1 )
endif
if nM1 > 0 .and. "." $ substr( cN1, nM1 )
cN1 = left( cN1, nM1 - 1 )
cL = .T.
nM2 = nM1 + 1
nM1 = rat( " ", cN1 )
endif
enddo
* the two marks delineate the starts of the last name and suffix
do case
case cP = "S"
nStart = nM2
nStop = len( cName )
case cP = "L"
nStart = nM1 + 1
nStop = nM2 - 1
otherwise
nStart = 1
nStop = nM1 - 1
endcase
endif
if nStart < nStop
nStop = min( nStop, Nstart + len( trim( substr( cN1, Nstart, ;
Nstop - Nstart + 1 ) ) ) - 1 )
nRet = iif( cE = "B", nStart, nStop ) + nTrimmed
endif
RETURN nRet
*-- EoF: NameMark()
FUNCTION MarkLine
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/21/1993
*-- Notes.......: Presents a string with cursor at character given by
*-- numeric offset, allows user to move the cursor within
*-- the string using arrow keys and returns position
*-- within the string at which cursor is located when edit
*-- is ended, or 0 if edit is ended by pressing {Esc}.
*-- The programmer must deal with opening windows,
*-- positioning the edit, etc. before calling the function.
*-- Mouse support not supplied for this version.
*-- Written for.: dBASE IV 1.5
*-- Rev. History: 03/21/1993 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: MarkLine( <cLine> [, <nPos> ] )
*-- Example.....: ? MarkLine( "G. C. K. Chesterton", 10 )
*-- Returns.....: numeric, character position of the cursor, or 0 if {Esc}
*-- Parameters..: cLine = Line to parse
*-- nPos = optional, default position of cursor
*-- if omitted, cursor is at first character
*-------------------------------------------------------------------------------
parameters cLine, nPos
private nP, nRet, nCol, cCurs
cCurs = set( "CURSOR" )
set cursor on
nP = iif( type( "nPos" ) = "L", 1, nPos )
nRet = nP
nCol = col()
@ row(), nCol say cLine
nKey = 0
do while nKey # 27 .and. nKey # 13 .and. nKey # 23
@ row(), nCol + nRet - 1 say ""
nKey = inkey( 0 )
do case
case nKey = 27
nRet = 0
case nKey = 4 .and. nRet < len( cLine )
nRet = nRet + 1
case nKey = 19 .and. nRet > 1
nRet = nRet - 1
endcase
enddo
if cCurs = "OFF"
set cursor off
endif
RETURN nRet
*-- EoF: MarkLine()
FUNCTION Decode
*-------------------------------------------------------------------------------
*-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
*-- Date........: 11/25/1992 (unknown. Stolen from somewhere....)
*-- Note........: simple decoding for primitive password protection
*-- Written for.: dBASE IV 1.1+
*-- Rev. History: 11/25/1992 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Decode(<cInput>)
*-- Example.....: Password = Decode(cPassWd)
*-- Returns.....: decoded string
*-- Parameters..: <cInput> = encoded string
*-------------------------------------------------------------------------------
parameters cInput
private cString
cString = cInpit
if isblank(m->cString)
return cString
else
cpw = m->cString
x = 1
do while x <= len(trim(m->cString))
cString = stuff(m->cInput,x,1,chr(asc(substr(m->cpw,x,1))-x))
x = x + 1
enddo
endif
RETURN cString
*-- EoF: Decode()
FUNCTION Encode
*-------------------------------------------------------------------------------
*-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
*-- Date........: 11/25/1992 (unknown. Stolen from somewhere....)
*-- Note........: simple encoding for primitive password protection
*-- Written for.: dBASE IV 1.1+
*-- Rev. History: 11/25/1992 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Encode(<cInput>)
*-- Example.....: store encode(cPassWd) to PassWord
*-- Returns.....: encoded string
*-- Parameters..: cInput = unencoded string
*-------------------------------------------------------------------------------
parameters cInput
private cString
cString = cInput
* encode the password
cpw = m->cString
x = 1
do while x <= len(trim(m->cString))
cString = stuff(m->cString,x,1,chr(asc(substr(m->cpw,x,1))+x))
x = x + 1
enddo
RETURN cString
*-- EoF: Encode()
FUNCTION ExEqual
*-------------------------------------------------------------------------------
*-- Programmer..: Angus Scott-Fleming
*-- Date........: 11/26/1992 (Improvement on Genifer function)
*-- Note........: Test for two variables for exact match
*-- Written for.: dBASE IV 1.1+
*-- Rev. History: 11/26/1992 - test for TYPE MATCH as well!
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ExEqual(<cInput1>,<cInput2>)
*-- Example.....: if ExEqual(alias(),"XYZ")
*-- Returns.....: .T. (exact match) or .F. (different types or no match)
*-- Parameters..: cInput1 = \
*-- cInput2 = - two memvars to be compared
*-------------------------------------------------------------------------------
parameters cInput1, cInput2
RETURN (type("cInput1") = type("cInput2")) .and. ;
(cInput1 = cInput2) .and. (cInput2 = cInput1)
*-- EoF: ExEqual()
FUNCTION Str_Edit
*-------------------------------------------------------------------------------
*-- Programmer..: Angus Scott-Fleming (CIS: 75500,3232)
*-- Date........: 05/26/1992
*-- Notes.......: strips unwanted characters from a string
*-- (e.g. to normalize international phone numbers
*-- to nothing but numerals and "-")
*-- Written for.: dBASE IV 1.1+
*-- Rev. History: 01/01/1991 -- Original (Pete Carr)
*-- 05/26/1992 -- Current
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: valid required Str_Edit(<cInput>,<cBadChars>)
*-- Example.....: iphone = space(20)
*-- @ 6,12 say "Enter Phone# : " get iphone;
*-- picture replicate("#",len(iphone));
*-- valid required Str_Edit(iphone, " .+")
*-- input "011-(49)-345+6789-6790"
*-- becomes "011-49-3456789-6790"
*-- Returns.....: .f., then .t.
*-- Parameters..: cInput = input string
*-- cBadChars = excluded characters
*-------------------------------------------------------------------------------
parameters cInput,cBadChars
private lrv,nel,nsl,csc,nca,cInput,cBadChars
lRV = .t. && init return value to true
nEL = len(cBadChars) && len of edit characters
nSL = len(cInput) && len of string to edit
cInput = trim(cInput) && first, trim string to edit
do while nEL > 0 && search string for cBadChars[el]
cSC = substr(cBadChars,nEL,1)
do while .t. && delete all cBadChars[el] contained in cInput
nCA = at(cSC,cInput)
if nCA > 0
cInput = stuff(cInput,nCA,1,"")
lRV = .f.
loop
endif
exit
enddo
nEL = nEL-1
enddo
do while .t. && search for double spaces and delete
nCA = at(" ",cInput)
if nCA > 0
cInput = stuff(cInput,nCA,1,"")
lRV = .f.
else
exit
endif
enddo
cInput = cInput + space(nSL-len(cInput)) && restore string to original len
if .not. lRV
keyboard chr(32)+chr(13) && accept and display edited string
endif
RETURN lRV
*-- EoF: Str_Edit
*-------------------------------------------------------------------------------
*-- EoP: STRINGS.PRG
*-------------------------------------------------------------------------------