home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / dblib201.zip / STRINGS.PRG < prev    next >
Text File  |  1993-04-02  |  65KB  |  1,728 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: STRINGS.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 03/11/1993
  5. *-- Notes.....: String manipulation routines -- These routines are all designed
  6. *--             to handle the processing of "Strings" (Character Strings).
  7. *--             They range from simple checking of the location of a string 
  8. *--             inside another, to reversing the contents of a string ... 
  9. *--             and lots more. See the file: README.TXT for details on use
  10. *--             of this (and the other) library file(s).
  11. *-------------------------------------------------------------------------------
  12.  
  13. FUNCTION Proper
  14. *-------------------------------------------------------------------------------
  15. *-- Programmer..: Clinton L. Warren (VBCES)
  16. *-- Date........: 07/10/1991
  17. *-- Notes.......: Returns cBaseStr converted to proper case.  Converts
  18. *--               "Mc", "Mac", and "'s" as special cases.  Inspired by
  19. *--               A-T's CCB Proper function.  cBaseStr isn't modified.
  20. *-- Written for.: dBASE IV, 1.1
  21. *-- Rev. History: 07/10/1991 1.0 - Original version (VBCES/CLW)
  22. *-- Calls.......: None
  23. *-- Called by...: Any
  24. *-- Usage.......: Proper(<cBaseStr>)
  25. *-- Example.....: Proper("mcdonald's") returns "McDonald's"
  26. *-- Returns.....: Propertized string (e.g. "Test String")
  27. *-- Parameters..: cBaseStr = String to be propertized
  28. *-------------------------------------------------------------------------------
  29.  
  30.     PARAMETERS cBaseStr
  31.     private nPos, cDeli, cWrkStr
  32.  
  33.     cWrkStr = lower(cBaseStr) + ' '             && space necessary for 's process
  34.  
  35.     nPos = at('mc', cWrkStr)                    && "Mc" handling
  36.     do while nPos # 0
  37.        cWrkStr = stuff(cWrkStr, nPos, 3, upper(substr(cWrkStr, nPos, 1)) ;
  38.                 + lower(substr(cWrkStr, nPos + 1, 1)) ;
  39.                 + upper(substr(cWrkStr, nPos + 2, 1)))
  40.         nPos = at('mc', cWrkStr)
  41.       enddo
  42.  
  43.     nPos = at('mac', cWrkStr)                    && "Mac" handling
  44.     do while nPos # 0
  45.        cWrkStr = stuff(cWrkStr, nPos, 4, upper(substr(cWrkStr, nPos, 1)) ;
  46.                                 + lower(substr(cWrkStr, nPos + 1, 2)) ;
  47.                                 + upper(substr(cWrkStr, nPos + 3, 1)))
  48.         nPos = at('mac', cWrkStr)
  49.     enddo
  50.  
  51.     cWrkStr = stuff(cWrkStr, 1, 1, upper(substr(cWrkStr, 1, 1)))
  52.     nPos = 2
  53.     cDeli = [ -.'"\/`]                           && standard delimiters
  54.  
  55.     do while nPos <= len(cWrkStr)                && 'routine' processing
  56.         if substr(cWrkStr,nPos-1,1) $ cDeli
  57.           cWrkStr = stuff(cWrkStr, nPos, 1, upper(substr(cWrkStr,nPos,1)))
  58.         endif
  59.         nPos = nPos + 1
  60.     enddo
  61.  
  62.     nPos = at("'S ", cWrkStr)                    && 's processing
  63.     do while nPos # 0
  64.         cWrkStr = stuff(cWrkStr, nPos, 2, lower(substr(cWrkStr, nPos, 2)))
  65.         nPos = at('mac', cWrkStr)
  66.     enddo
  67.  
  68. RETURN (cWrkStr)
  69. *-- EoF: Proper()
  70.  
  71. FUNCTION Dots
  72. *-------------------------------------------------------------------------------
  73. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  74. *-- Date........: 12/17/1991
  75. *-- Notes.......: Based on ideas from Technotes, June, 1990 (see JUSTIFY() ),
  76. *--               this function should pad a field or memvar with dots to the
  77. *--               left, right or both sides. Note that if the field is too
  78. *--               large for the length passed (nLength) it will be truncated.
  79. *-- Written for.: dBASE IV, 1.1
  80. *-- Rev. History: 12/17/1991 -- Original
  81. *-- Calls.......: ALLTRIM()            Function in PROC.PRG
  82. *-- Called by...: Any
  83. *-- Usage.......: Dots(<cFld>,<nLength>,"<cType>")
  84. *-- Example.....: ?? Dots(Address,25,"R")
  85. *-- Returns.....: Field/memvar with dot leader/trailer ...
  86. *-- Parameters..: cFld    =  Field/Memvar/Character String to justify
  87. *--               nLength =  Width to justify within
  88. *--               cType   =  Type of justification: L=Left, C=Center,R=Right
  89. *-------------------------------------------------------------------------------
  90.     
  91.     parameters cFld,nLength,cType
  92.     private cReturn, nVal, nMore
  93.     
  94.     if type("cFld")+type("nLength")+type("cType") $ "CNC,CFC"
  95.     
  96.         cType   = upper(cType)      && just to make sure ...
  97.         cReturn = AllTrim(cFld)     && trim this puppy on all sides
  98.         if len(cReturn) => nLength  && check length against parameter
  99.                                     && truncate if necessary
  100.             cReturn = substr(cReturn,1,nLength)
  101.         endif
  102.         
  103.         do case
  104.             case cType = "L"  && Left -- add trailing dots to field
  105.                 cReturn = cReturn + replicate(".",nLength-len(cReturn))
  106.             case cType = "R"  && Right -- add leading dots to field
  107.                 cReturn = replicate(".",nLength-len(cReturn))+cReturn
  108.             case cType = "C"  && Center -- add 'em to both sides ...
  109.                 nVal = int( (nLength - len(cReturn)) / 2)
  110.                 *-- here, we have to deal with fractions ...
  111.                 nMore = mod(nlength - len(cReturn), 2)
  112.                 *-- add dots on left, field, dots on right (add one if a fraction)
  113.                 cReturn = replicate(".",nVal)+cReturn+;
  114.                           replicate(".",nVal+iif(nMore>0,1,0))
  115.             otherwise         && invalid parameter ... return nothing
  116.                 cReturn = ""
  117.         endcase
  118.     else
  119.         cReturn = ""
  120.     endif
  121.  
  122. RETURN cReturn
  123. *-- EoF: Dots()
  124.  
  125. FUNCTION CutPaste
  126. *-------------------------------------------------------------------------------
  127. *-- Programmer..: Martin Leon (HMAN)
  128. *-- Date........: 03/05/1992
  129. *-- Notes.......: Used to do a cut and paste within a field/character string.
  130. *--               (Taken from an issue of Technotes, can't remember which)
  131. *--               This function will not allow you to overflow the field/char
  132. *--               string -- i.e., if the Paste part of the function would cause
  133. *--               the returned field to be longer than it started out, it will
  134. *--               not perform the cut/paste (STUFF()). For example, if your 
  135. *--               field were 15 characters, and you wanted to replace 5 of them
  136. *--               with a 10 character string:
  137. *--                      (CutPaste(field,"12345","1234567890"))
  138. *--               If this would cause the field returned to be longer than 15,
  139. *--               the function will return the original field.
  140. *-- Written for.: dBASE IV, 1.1
  141. *-- Rev. History: Original function 12/17/1991
  142. *--               03/05/1992 -- minor change to TRIM(cFLD) in the early
  143. *--               bits, solving a minor problem with phone numbers that
  144. *--               Dave Creek (DCREEK) discovered.
  145. *-- Calls.......: None
  146. *-- Called by...: Any
  147. *-- Usage.......: CutPaste(<cFld>,"<cLookFor>","<cRepWith>")
  148. *-- Example.....: Replace all city with CutPaste(City,"L.A.","Los Angeles")
  149. *-- Returns.....: The field with text replaced (or not, if no match is found)
  150. *-- Parameters..: cFld     = Field/Memvar/Expression to replace in 
  151. *--               cLookFor = Item to look for (Cut)
  152. *--               cRepWith = What to replace it with (Paste)
  153. *-------------------------------------------------------------------------------
  154.  
  155.     parameters cFld,cLookFor,cRepWith
  156.     private lMatched,nLookLen,nLen,nRepLen,cRetFld,nTrimLen,nCutAt
  157.     
  158.     *-- Make sure they're all character fields/strings
  159.     if type("cFld")+type("cLookFor")+type("cRepWith") # "CCC"
  160.         RETURN cFld
  161.     endif
  162.     
  163.     lMatched = .f.
  164.     nLookLen = len(cLookFor)  && length of field to look for
  165.     nLen     = len(cFld)      && length of original field
  166.     nRepLen  = len(cRepWith)  && length of field to replace with
  167.     cRetFld  = trim(cFld)     && trim it ... (DCREEK's suggestion)
  168.     
  169.     *-- the loop will allow a cut/paste to occur more than once in the field
  170.     do while at(cLookFor,cRetFld) > 0
  171.         lMatched = .t.
  172.         cRetFld  = trim(cRetFld)
  173.         nTrimLen = len(cRetFld)
  174.         
  175.         *-- the following IF statement prevents the replacement text
  176.         *-- from overflowing the length of the original string ...
  177.         if(nTrimLen - nLookLen) + nRepLen > nLen
  178.             RETURN cRetFld
  179.         endif
  180.         
  181.         *-- here we figure where to "cut" at
  182.         nCutAt = at(cLookFor,cRetFld)
  183.         *-- let's do the paste ... (using dBASE STUFF() function)
  184.         cRetFld = stuff(cRetFld,nCutAt,nLookLen,cRepWith)
  185.     enddo
  186.     
  187.     if .not. lMatched  && no match with cLookFor, return original field
  188.         RETURN cFld
  189.     endif
  190.     
  191. RETURN cRetFld
  192. *-- EoF: CutPaste
  193.  
  194. FUNCTION LastWord
  195. *-------------------------------------------------------------------------------
  196. *-- Programmer..: Martin Leon (HMAN)
  197. *-- Date........: 12/19/1991
  198. *-- Notes.......: Returns the last word in a character string.
  199. *-- Written for.: dBASE IV, 1.1
  200. *-- Rev. History: 12/19/1991 -- Original
  201. *-- Calls.......: None
  202. *-- Called by...: Any
  203. *-- Usage.......: LastWord("<cString>")
  204. *-- Example.....: ? LastWord("This is a test string") 
  205. *-- Returns.....: The Last word (bracketed with spaces), i.e.:"string"
  206. *-- Parameters..: cString = string to be searched 
  207. *-------------------------------------------------------------------------------
  208.     
  209.     parameters cString
  210.     private cReturn
  211.     
  212.     cReturn = trim(cString)
  213.     do while at(" ",cReturn) # 0
  214.         cReturn = substr(cReturn,at(" ",cReturn)+1)
  215.     enddo
  216.     
  217. RETURN cReturn
  218. *-- EoF: LastWord()
  219.  
  220. FUNCTION VStretch
  221. *-------------------------------------------------------------------------------
  222. *-- Programmer..: Martin Leon (HMAN -- Ashton Tate/Borland BBS)
  223. *-- Date........: 10/30/91
  224. *-- Notes.......: Used to display a long character field, with proper word wrap
  225. *-- Written for.: dBASE IV, 1.1
  226. *-- Rev. History: Once upon a time, Martin helped me write a more complicated
  227. *--               routine for use in a browse table. He came up with this
  228. *--               much less complex version recently and sent to me via EMail.
  229. *--               (10/30/1991 -- Original release for the library)
  230. *-- Calls.......: None
  231. *-- Called by...: Any
  232. *-- Usage.......: ?VStretch(<cLFld>,<nULRow>,<nULCol>,<nBRRow>,<nBRCol>)
  233. *-- Example.....: ?VStretch(Notes,20,10,24,60,"rg+/gb")
  234. *-- Returns.....: ""  (Nul)
  235. *-- Parameters..: cLFld  = Long Field to be wrapped on screen
  236. *--               nULRow = Upper Left Row of window
  237. *--               nULCol = Upper Left Column
  238. *--               nBRRow = Bottom Right Row of window
  239. *--               nBRCol = Bottom Right Column
  240. *-------------------------------------------------------------------------------
  241.  
  242.     parameter cLFld,nULRow,nULCol,nBRRow,nBRCol
  243.     private nWinWidth
  244.     
  245.     nWinWidth = ltrim(str((nBRCol - nULCol)-1,2))
  246.     *-- define window without any border ...
  247.     define window wStretch from nULRow,nULCol to nBRRow,nBRCol none
  248.     activate window wStretch
  249.     *-- make sure window is empty ...
  250.     clear
  251.     *-- display field
  252.     ?? cLFld picture "@V"+nWinWidth at 0  && the @V function causes word wrap
  253.     save screen to sTemp
  254.     activate screen
  255.     release window wStretch
  256.     restore screen from sTemp
  257.     release screen sTemp
  258.  
  259. RETURN ""
  260. *-- EoF: VStretch()
  261.  
  262. FUNCTION AtCount
  263. *-------------------------------------------------------------------------------
  264. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  265. *-- Date........: 03/01/1992
  266. *-- Notes.......: returns the number of times FindString is found in Bigstring
  267. *-- Written for.: dBASE IV
  268. *-- Rev. History: 03/01/1992 -- Original Release
  269. *-- Calls.......: None
  270. *-- Called by...: Any
  271. *-- Usage.......: AtCount("<cFindStr>","<cBigStr>")
  272. *-- Example.....: ? AtCount("Test","This is a Test string, with Test data")
  273. *-- Returns.....: Numeric value
  274. *-- Parameters..: cFindStr = string to find in cBigStr
  275. *--               cBigStr  = string to look in
  276. *-------------------------------------------------------------------------------
  277.  
  278.     parameters cFindstr, cBigstr
  279.     private cTarget, nCount
  280.     
  281.     cTarget = cBigstr
  282.     nCount = 0
  283.     
  284.     do while .t.
  285.         if at( cFindStr,cTarget ) > 0
  286.             nCount = nCount + 1
  287.             cTarget = substr( cTarget, at( cFindstr, cTarget ) + 1 )
  288.         else
  289.          exit
  290.         endif
  291.     enddo
  292.     
  293. RETURN nCount
  294. *-- EoF: AtCount()
  295.         
  296. FUNCTION IsAlNum
  297. *-------------------------------------------------------------------------------
  298. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  299. *-- Date........: 03/01/1992
  300. *-- Notes.......: Returns .T. if the first character of cChar is alphanumeric,
  301. *--               otherwise it is false.
  302. *-- Written for.: dBASE IV
  303. *-- Rev. History: 03/01/1992 -- Original Release
  304. *-- Calls.......: None
  305. *-- Called by...: Any
  306. *-- Usage.......: IsAlNum("<cChar>")
  307. *-- Example.....: ? IsAlNum("Test")
  308. *-- Returns.....: Logical
  309. *-- Parameters..: cChar = character string to check for Alphanumeric ...
  310. *-------------------------------------------------------------------------------
  311.  
  312.     parameters cChar
  313.     
  314. RETURN isalpha( cChar ) .or. left( cChar, 1 ) $ "0123456789"
  315. *-- EoF: IsAlNum()
  316.  
  317. FUNCTION IsAscii
  318. *-------------------------------------------------------------------------------
  319. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  320. *-- Date........: 03/01/1992
  321. *-- Notes.......: Returns .t. if the first character of cChar is in the lower
  322. *--               half of the ASCII set ( value < 128 )
  323. *-- Written for.: dBASE IV
  324. *-- Rev. History: 03/01/1992 -- Original Release
  325. *-- Calls.......: None
  326. *-- Called by...: Any
  327. *-- Usage.......: IsAscii("<cChar>")
  328. *-- Example.....: ? IsAscii("Teststring")
  329. *-- Returns.....: Logical
  330. *-- Parameters..: cChar = string to test
  331. *-------------------------------------------------------------------------------
  332.  
  333.     parameters cChar
  334.     
  335. RETURN asc( cChar ) < 128
  336. *-- EoF: IsAscii()
  337.  
  338. FUNCTION IsCntrl
  339. *-------------------------------------------------------------------------------
  340. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  341. *-- Date........: 03/01/1992
  342. *-- Notes.......: Returns .t. if the first character of cChar is a delete,
  343. *--               or a control character.
  344. *-- Written for.: dBASE IV
  345. *-- Rev. History: 03/01/1992 -- Original Release
  346. *-- Calls.......: None
  347. *-- Called by...: Any
  348. *-- Usage.......: IsCntrl("<cChar>")
  349. *-- Example.....: ? IsCntrl("Test")
  350. *-- Returns.....: Logical
  351. *-- Parameters..: cChar = string to test
  352. *-------------------------------------------------------------------------------
  353.  
  354.     parameters cChar
  355.     private nCharval
  356.     nCharval = asc(cChar)
  357.     
  358. RETURN nCharval = 127 .or. nCharval < 32
  359. *-- EoF: IsCntrl()
  360.  
  361. FUNCTION IsDigit
  362. *-------------------------------------------------------------------------------
  363. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  364. *-- Date........: 03/01/1992
  365. *-- Notes.......: If the first character of cChar is a digit, returns .T.
  366. *-- Written for.: dBASE IV
  367. *-- Rev. History: 03/01/1992 -- Original Release
  368. *-- Calls.......: None
  369. *-- Called by...: Any
  370. *-- Usage.......: IsDigit("<cChar>")
  371. *-- Example.....: ? IsDigit("123Test")
  372. *-- Returns.....: Logical
  373. *-- Parameters..: cChar = string to test
  374. *-------------------------------------------------------------------------------
  375.  
  376.     parameters cChar
  377.  
  378. RETURN left( cChar, 1 ) $ "0123456789"
  379. *-- EoF: IsDigit()
  380.  
  381. FUNCTION IsPrint
  382. *-------------------------------------------------------------------------------
  383. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  384. *-- Date........: 03/01/1992
  385. *-- Notes.......: Returns .t. if first character of cChar is a printing 
  386. *--               character (space through chr(126) ).
  387. *-- Written for.: dBASE IV
  388. *-- Rev. History: Original Release
  389. *-- Calls.......: None
  390. *-- Called by...: Any
  391. *-- Usage.......: IsPrint("<cChar>")
  392. *-- Example.....: ? IsPrint("Test")
  393. *-- Returns.....: Logical
  394. *-- Parameters..: cChar = string to test
  395. *-------------------------------------------------------------------------------
  396.  
  397.     parameters cChar
  398.     private nCharval
  399.     nCharval = asc(cChar)
  400.     
  401. RETURN nCharval > 31 .and. nCharval < 127
  402. *-- EoF: IsPrint()
  403.  
  404. FUNCTION IsXDigit
  405. *-------------------------------------------------------------------------------
  406. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  407. *-- Date........: 03/01/1992
  408. *-- Notes.......: Returns .t. if first character of cChar is a possible
  409. *--               hexidecimal digit.
  410. *-- Written for.: dBASE IV
  411. *-- Rev. History: 03/01/1992 -- Original Release
  412. *-- Calls.......: None
  413. *-- Called by...: Any
  414. *-- Usage.......: IsXDigit("<cChar>")
  415. *-- Example.....: ? IsXDigit("F000")
  416. *-- Returns.....: Logical
  417. *-- Parameters..: cChar = string to test
  418. *-------------------------------------------------------------------------------
  419.  
  420.     parameters cChar
  421.     
  422. RETURN left( cChar, 1 ) $ "0123456789ABCDEFabcdef"
  423. *-- EoF: IsXDigit()
  424.  
  425. FUNCTION IsSpace
  426. *-------------------------------------------------------------------------------
  427. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  428. *-- Date........: 03/01/1992
  429. *-- Notes.......: Returns .T. if first character of cChar is in set of space,
  430. *--               tab, carriage return, line feed, vertical tab or formfeed,
  431. *--               otherwise .F.  Differs from C function of the same
  432. *--               name in treating chr(141), used as carriage return
  433. *--               in dBASE memo fields, as a space.
  434. *-- Written for.: dBASE IV
  435. *-- Rev. History: Original Release
  436. *-- Calls.......: None
  437. *-- Called by...: Any
  438. *-- Usage.......: IsSpace("<cChar>")
  439. *-- Example.....: ? IsSpace(" Test")
  440. *-- Returns.....: Logical
  441. *-- Parameters..: cChar = string to test
  442. *-------------------------------------------------------------------------------
  443.  
  444.     parameters cChar
  445.     private cSpacestr
  446.     cSpacestr = " "+chr(9)+chr(10)+chr(11)+chr(12)+chr(13)+chr(141)
  447.  
  448. RETURN left( cChar, 1 ) $ cSpacestr
  449. *-- EoF: IsSpace()
  450.  
  451. FUNCTION Name2Label
  452. *-------------------------------------------------------------------------------
  453. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  454. *-- Date........: 03/01/1992
  455. *-- Notes.......: Returns a name held in five separate fields or memvars as it
  456. *--               should appear on a label of a given length in characters.
  457. *--               The order of abbreviating is somewhat arbitrary--you may
  458. *--               prefer to remove the suffix before the prefix, or to remove 
  459. *--               both before abbreviating the first name.  This can be 
  460. *--               accomplished by rearranging the CASE statements, which operate 
  461. *--               in the order of their appearance.
  462. *-- Written for.: dBASE IV
  463. *-- Rev. History: 03/01/1992 -- Original Release
  464. *-- Calls.......: None
  465. *-- Called by...: Any
  466. *-- Usage.......: Name2Label(<nLength>,"<cPrefix>","<cFirstName>",;
  467. *--                          "<cMidName>","<cLastName>","<cSuffix>")
  468. *-- Example.....: ? Name2Label(20,"The Rev.","Elmore","Norbert","Smedley","III")
  469. *-- Returns.....: Character String, in this case "E. N. Smedley, III"
  470. *-- Parameters..: nLength     = length of label
  471. *--               cPrefix     = Prefix to name, such as Mr., Ms., Dr...
  472. *--               cFirstName  = self explanatory
  473. *--               cMiddleName = self explanatory
  474. *--               cLastName   = self explanatory
  475. *--               cSuffix     = "Jr.", "M.D.", "PhD", etc.
  476. *-------------------------------------------------------------------------------
  477.  
  478.     parameters nLength, cPrefix, cFirstname, cMidname, cLastname, cSuffix
  479.     private cTrypref, cTryfirst, cTrymid, cTrylast, cTrysuff, cTryname
  480.     cTrypref  = ltrim( trim( cPrefix ) )
  481.     cTryfirst = ltrim( trim( cFirstname ) )
  482.     cTrymid   = ltrim( trim( cMidname ) )
  483.     cTrylast  = ltrim( trim( cLastname ) )
  484.     cTrysuff  = ltrim( trim( cSuffix ) )
  485.     do while .t.
  486.       cTryname = cTrylast
  487.       if "" # cTrymid
  488.         cTryname = cTrymid + " " + cTryname
  489.       endif
  490.       if "" # cTryfirst
  491.         cTryname = cTryfirst + " " + cTryname
  492.       endif
  493.       if "" # cTrypref
  494.         cTryname = cTrypref + " " + cTryname
  495.       endif
  496.       if "" # cTrysuff
  497.         cTryname = cTryname + ", " + cTrysuff
  498.       endif
  499.       if len(cTryname) <= nLength
  500.          exit
  501.       endif
  502.       do case
  503.         case "" # cTrymid .AND. right( cTrymid, 1 ) # "."
  504.           cTrymid = left( cTrymid, 1 ) + "."    && convert middle name to initial
  505.         case "" # cTryfirst .AND. right( cTryfirst, 1 ) # "."
  506.           cTryfirst = left( cTryfirst, 1 ) + "." && convert first name to initial
  507.         case "" # cTrypref
  508.           cTrypref = ""                          && drop prefix
  509.         case "" # cTrysuff
  510.           cTrysuff = ""                          && drop suffix
  511.         case "" # cTrymid
  512.           cTrymid = ""                           && drop middle initial
  513.         case "" # cTryfirst
  514.           cTryfirst = ""                         && drop first initial
  515.         otherwise
  516.           cTrylast = left( cTrylast, nLength )   && truncate last name
  517.       endcase
  518.     enddo
  519.     
  520. RETURN cTryName
  521. *-- EoF: Name2Label()
  522.  
  523. FUNCTION StrPBrk
  524. *-------------------------------------------------------------------------------
  525. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  526. *-- Date........: 03/01/1992
  527. *-- Notes.......: Search string for first occurrence of any of the
  528. *--               characters in charset.  Returns its position as
  529. *--               with at().  Contrary to ANSI.C definition, returns
  530. *--               0 if none of characters is found.
  531. *-- Written for.: dBASE IV
  532. *-- Rev. History: 03/01/1992
  533. *-- Calls.......: None
  534. *-- Called by...: Any
  535. *-- Usage.......: StrPBrk("<cCharSet>","<cBigStr>")
  536. *-- Example.....: ? StrPBrk("Tt","This is a Test string, with Test data")
  537. *-- Returns.....: Numeric value
  538. *-- Parameters..: cCharSet = characters to look for in cBigStr
  539. *--               cBigStr  = string to look in
  540. *-------------------------------------------------------------------------------
  541.  
  542.     parameters cCharset, cBigstring
  543.     private nPos, nLooklen
  544.     nPos = 0
  545.     nLooklen = len( cBigstring )
  546.     do while nPos < nLooklen
  547.       nPos = nPos + 1
  548.         if at( substr( cBigstring, nPos, 1 ), cCharset ) > 0
  549.          exit
  550.        endif
  551.     enddo
  552.     
  553. RETURN iif(nPos=nLookLen,0,nPos)
  554. *-- EoF: StrPBrk()
  555.  
  556. FUNCTION StrRev
  557. *-------------------------------------------------------------------------------
  558. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  559. *-- Date........: 03/01/1992
  560. *-- Notes.......: Reverses a string of characters, returns that reversed string.
  561. *-- Written for.: dBASE IV
  562. *-- Rev. History: 03/01/1992 -- Original Release
  563. *-- Calls.......: None
  564. *-- Called by...: Any
  565. *-- Usage.......: StrRev("<cAnyStr>")
  566. *-- Example.....: ? StrRev("This is a Test")
  567. *-- Returns.....: Character string
  568. *-- Parameters..: cAnyStr = String of characters to reverse ...
  569. *-------------------------------------------------------------------------------
  570.  
  571.     parameters cAnystr
  572.     private cRevstring, nX,nY
  573.     nX = len( cAnystr )
  574.     nY = 1
  575.     cRevstring = space( nX )
  576.     do while nX > 0
  577.           cRevstring = stuff(cRevstring,nY,1,substr(cAnyStr,nX,1))
  578.       nY = nY + 1
  579.       nX = nX - 1
  580.     enddo
  581.     
  582. RETURN cRevstring
  583. *-- EoF: StrRev()
  584.  
  585. FUNCTION Strip2Val
  586. *-------------------------------------------------------------------------------
  587. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  588. *-- Date........: 03/01/1992
  589. *-- Notes.......: Strip characters from the left of a string until reaching
  590. *--               one that might start a number.
  591. *-- Written for.: dBASE IV
  592. *-- Rev. History: 03/01/1992 -- Original Release
  593. *-- Calls.......: None
  594. *-- Called by...: Any
  595. *-- Usage.......: Strip2Val("<cStr>")
  596. *-- Example.....: ? Strip2Val("Test345")
  597. *-- Returns.....: character string
  598. *-- Parameters..: cStr = string to search
  599. *-------------------------------------------------------------------------------
  600.  
  601.     parameters cStr
  602.    private cNew
  603.    cNew = cStr
  604.    do while "" # cNew
  605.       if left( cNew, 1 ) $ "-.0123456789"
  606.          exit
  607.        endif
  608.       cNew = substr( cNew, 2 )
  609.     enddo
  610.     
  611. RETURN cNew
  612. *-- EoF: Strip2Val()
  613.  
  614. FUNCTION StripVal
  615. *-------------------------------------------------------------------------------
  616. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  617. *-- Date........: 03/01/1992
  618. *-- Notes.......: Strip characters from the left of the string until
  619. *--               reaching one that is not part of a number.  A hyphen
  620. *--               following numerics, or a second period,
  621. *--               is treated as not part of a number.
  622. *-- Written for.: dBASE IV
  623. *-- Rev. History: 03/01/1992 -- Original Release
  624. *-- Calls.......: None
  625. *-- Called by...: Any
  626. *-- Usage.......: StripVal("<cStr>")
  627. *-- Example.....: ? StripVal("123.2Test")
  628. *-- Returns.....: Character
  629. *-- Parameters..: cStr = string to test
  630. *-------------------------------------------------------------------------------
  631.  
  632.     parameters cStr
  633.    private cNew, cChar, lGotminus, lGotdot
  634.    cNew = cStr
  635.    store .f. to lGotminus, lGotdot
  636.    do while "" # cNew
  637.       cChar = left( cNew, 1 )
  638.        do case
  639.           case .not. cChar $ "-.0123456789"
  640.             exit
  641.          case cChar = "-"
  642.              if lGotminus
  643.                exit
  644.             endif
  645.            case cChar = "."
  646.              if lGotdot
  647.                exit
  648.              else
  649.                 lGotdot = .T.
  650.              endif
  651.        endcase
  652.       cNew = substr( cNew, 2 )
  653.        lGotminus = .T.
  654.     enddo
  655.     
  656. RETURN cNew
  657. *-- EoF: StripVal()
  658.  
  659. FUNCTION ParseWord
  660. *-------------------------------------------------------------------------------
  661. *-- Programmer..: Jay Parsons (CIS: 70160,340).
  662. *-- Date........: 04/26/1992
  663. *-- Notes.......: returns the first word of a string
  664. *-- Written for.: dBASE IV, 1.1, 1.5
  665. *-- Rev. History: 04/26/1992 -- Original Release
  666. *-- Calls       : None
  667. *-- Called by...: Any
  668. *-- Usage.......: ? ParseWord(<cString>)
  669. *-- Example.....: Command = ParseWord( cProgramline )
  670. *-- Parameters..: cString - character string to be stripped.
  671. *-- Returns     : that portion, trimmed on both ends, of the passed string
  672. *--               that includes the characters up to the first interior space.
  673. *-------------------------------------------------------------------------------
  674.    parameters string
  675.    private cW
  676.    cW = trim( ltrim( string ) )
  677.  
  678. RETURN iif( " " $ cW, rtrim( left( cW, at( " ", cW ) - 1 ) ), cW )
  679. *-- EoF: ParseWord()
  680.  
  681. FUNCTION StripWord
  682. *-------------------------------------------------------------------------------
  683. *-- Programmer..: Jay Parsons (CIS: 70160,340).
  684. *-- Date........: 04/26/1992
  685. *-- Notes.......: discards first word of a string
  686. *-- Written for.: dBASE IV, 1.1, 1.5
  687. *-- Rev. History: 04/26/1992 -- Original Release
  688. *-- Calls       : None
  689. *-- Called by...: Any
  690. *-- Usage.......: ? StripWord(<cString>)
  691. *-- Example.....: Lastname = StripWord( "Carrie Nation" )
  692. *-- Parameters..: cString - character string to be stripped.
  693. *-- Returns     : string trimmed of trailing spaces, and trimmed on the
  694. *--               left to remove leading spaces and, if the passed string
  695. *--               contained interior spaces, also to remove everything before
  696. *--               the first nonspace character after the first interior space.
  697. *-------------------------------------------------------------------------------
  698.    parameters string
  699.    private cW
  700.    cW = trim( ltrim( string ) )
  701.  
  702. RETURN iif( " " $ cW, ltrim( substr( cW, at( " ", cW ) + 1 ) ), cW )
  703. *-- EoF: StripWord()
  704.  
  705. FUNCTION Plural
  706. *-------------------------------------------------------------------------------
  707. *-- Programmer..: Kelvin Smith (KELVIN)
  708. *-- Date........: 08/27/1992
  709. *-- Notes.......: Returns number in string form, and pluralized form of
  710. *--               noun, including converting "y" to "ies", unless the "y"
  711. *--               is preceded by a vowel.  Works with either upper or lower
  712. *--               case nouns (based on last character).
  713. *--                  As no doubt all are aware, English includes many
  714. *--               irregular plural forms; to trap for all is not worthwhile
  715. *--               (how often do you really need to print out die/dice?).
  716. *--               This should handle the vast majority of needs.
  717. *-- Written for.: dBASE IV, 1.5
  718. *-- Rev. History: 08/27/1992 1.0 - Original version
  719. *-- Calls.......: None
  720. *-- Called by...: Any
  721. *-- Usage.......: Plural(<nCnt>, <cNoun>)
  722. *-- Examples....: Plural(1, "flag")    returns "1 flag"
  723. *--               Plural(0, "store")   returns "0 stores"
  724. *--               Plural(5, "COMPANY") returns "5 COMPANIES"
  725. *-- Returns.....: String with number and noun, no trailing spaces
  726. *-- Parameters..: nCnt  = Count value for noun (how many of cNoun?)
  727. *--               cNoun = Noun to pluralize
  728. *-------------------------------------------------------------------------------
  729.  
  730.    parameters nCnt, cNoun
  731.    private cNounOut, cLast, c2Last, cLast2, lUpper
  732.  
  733.    if nCnt = 1
  734.       cNounOut = trim(cNoun)
  735.    else
  736.       cNounOut = trim(cNoun)          && No trailing spaces
  737.       cLast = right(cNounOut, 1)
  738.       lUpper = isupper(cLast)         && Upper case?
  739.       cLast = upper(cLast)
  740.       c2Last = upper(substr(cNounOut, len(cNounOut) - 1, 1))
  741.       cLast2 = c2Last + cLast
  742.  
  743.       * If the noun ends in "Y", normally we change "Y" to "IES".
  744.       * However, if the "Y" is preceded by a vowel, just add "S".
  745.       if cLast = "Y" .and. at(c2Last, "AEIOU") = 0
  746.          cNounOut = left(cNounOut, len(cNounOut) - 1) +;
  747.                     iif(lUpper, "IES", "ies")
  748.       else
  749.          if cLast = "S" .or. cLast = "X" ;
  750.                         .or. cLast2 = "CH" .or. cLast2 = "SH"
  751.             cNounOut = cNounOut + iif(lUpper, "ES", "es")
  752.          else
  753.             cNounOut = cNounOut + iif(lUpper, "S", "s")
  754.          endif
  755.       endif
  756.    endif
  757.  
  758. RETURN ltrim(str(nCnt)) + " " + cNounOut
  759. *-- EoF: Plural()
  760.  
  761. FUNCTION StrComp
  762. *-------------------------------------------------------------------------------
  763. *-- Programmer..: Sri Raju (Borland Technical Support)
  764. *-- Date........: 08/01/1992
  765. *-- Notes.......: From Technotes, August, 1992, "Strings and Things"
  766. *--               This function compares the contents of two strings.
  767. *--               If cStr1 is less than cStr2, return -1
  768. *--               If cStr1 is equal to  cStr2, return 0
  769. *--               If cStr1 is greaterh than cStr2, return 1
  770. *-- Written for.: dBASE IV, 1.5
  771. *-- Rev. History: 08/01/1992 -- Original Release
  772. *-- Calls.......: None
  773. *-- Called by...: Any
  774. *-- Usage.......: StrComp(<cStr1>,<cStr2>)
  775. *-- Example.....: ? StrComp("TEST","TEXT")
  776. *-- Returns.....: Numeric (see notes)
  777. *-- Parameters..: cStr1 = First string
  778. *--               cStr2 = Second string
  779. *-------------------------------------------------------------------------------
  780.     
  781.     parameters cStr1,cStr2
  782.     
  783.     cExact = set("EXACT")
  784.     set exact on
  785.     
  786.     do case
  787.         case cStr1 = cStr2
  788.             nReturn = 0
  789.         case cStr1 > cStr2
  790.             nReturn = 1
  791.         case cStr1 < cStr2
  792.             nReturn = -1
  793.     endcase
  794.     
  795.     set exact &cExact
  796.  
  797. RETURN nReturn
  798. *-- EoF: StrComp()
  799.  
  800. FUNCTION StrOccur
  801. *-------------------------------------------------------------------------------
  802. *-- Programmer..: Sri Raju (Borland Technical Support)
  803. *-- Date........: 08/01/1992
  804. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  805. *--               Calculates the number of occurences of a string in another
  806. *--               given character or memo field.
  807. *-- Written for.: dBASE IV, 1.5
  808. *-- Rev. History: 08/01/1992 -- Original Release
  809. *-- Calls.......: NumOccur()           Function in STRINGS.PRG
  810. *-- Called by...: Any
  811. *-- Usage.......: StrOccur(<cInString>,<cFindString>)
  812. *-- Example.....: ? StrOccur("NOTES","every")  && find all occurences of "every"
  813. *--                                            && in Memo: NOTES.
  814. *-- Returns.....: Numeric
  815. *-- Parameters..: cInString   = "Large" string -- to be looked "in". If a Memo,
  816. *--                             name of memo field must be in quotes or passed
  817. *--                             as a memvar, and record pointer must be on
  818. *--                             correct record.
  819. *--               cFindString = "Small" string -- to be found in larger string.
  820. *-------------------------------------------------------------------------------
  821.  
  822.     parameters cInString, cFindString
  823.     
  824.     nBytes = 0
  825.     lMemo = .f.
  826.     nReturn = 0
  827.     
  828.     if pCount() # 2   && not enough parameters or too many parameters passed ...
  829.         ?"ERROR. Usage: StrOccur(<string>|<memo fld name>,<string>)"
  830.         RETURN (0)
  831.     endif
  832.     if type("CINSTRING") = "M"
  833.         lMemo = .t.
  834.     else
  835.         RETURN (NumOccur(cInstring,cFindString))
  836.     endif
  837.     
  838.     *-- process a memo ...
  839.     if lMemo
  840.         nTotLen = len(&cInString)
  841.         n = 1
  842.         nOffSet = 0
  843.         cTempStr = " "
  844.         do while nOffSet <= nTotLen
  845.             cTempStr = "arr"+ltrim(str(n))  && ?
  846.             if (nOffSet + 254) > nTotLen
  847.                 cTempStr = substr(&cInString,nOffSet+1,nOffSet+254)
  848.             else
  849.                 cTempStr = substr(&cInString,nOffSet+1,nTotLen)
  850.             endif
  851.             nReturn = nReturn + NumOccur(cTempStr,cFindStr)
  852.             n = n + 1
  853.             nOffSet = nOffSet + 254
  854.         enddo
  855.     endif
  856.  
  857. RETURN (nReturn)
  858. *-- EoF: StrOccur()
  859.  
  860. FUNCTION NumOccur
  861. *-------------------------------------------------------------------------------
  862. *-- Programmer..: Sri Raju (Borland Technical Support)
  863. *-- Date........: 08/01/1992
  864. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  865. *--               Calculates the number of occurences of a string in another
  866. *--               string.
  867. *-- Written for.: dBASE IV, 1.5
  868. *-- Rev. History: 08/01/1992 -- Original Release
  869. *-- Calls.......: None
  870. *-- Called by...: StrOccur()           Function in STRINGS.PRG
  871. *-- Usage.......: NumOccur(<cInString>,<cFindString>)
  872. *-- Example.....: ? NumOccur("This is a string","is")
  873. *-- Returns.....: Numeric (integer -- # of times string occurs)
  874. *-- Parameters..: cInString   = "Large" string -- to be looked 'in'
  875. *--               cFindString = "Small" string -- to be looked for
  876. *-------------------------------------------------------------------------------
  877.  
  878.     parameters cInString, cFindString
  879.     
  880.     cHoldStr = " "
  881.     nReturn = 0
  882.     cInit = cInString
  883.     
  884.     do while len(cInit) => 1
  885.         cHoldStr = cInit
  886.         if at(cFindString,cHoldStr) > 0
  887.             nReturn = nReturn + 1
  888.             cInit = substr(cHoldStr,at(cFindString,cHoldStr)+len(cFindString))
  889.         else
  890.             cInit = ""
  891.         endif
  892.     enddo
  893.  
  894. RETURN (nReturn)
  895. *-- EoF: NumOccur()
  896.  
  897. FUNCTION ReplMemo
  898. *-------------------------------------------------------------------------------
  899. *-- Programmer..: Sri Raju (Borland Technical Support)
  900. *-- Date........: 08/01/1992
  901. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  902. *--               Globally searches and replaces a string with another string
  903. *--               in a character field/memvar or memo field.
  904. *-- Written for.: dBASE IV, 1.5
  905. *-- Rev. History: 08/01/1992 -- Original Release
  906. *-- Calls.......: MemStuff()           Function in STRINGS.PRG
  907. *-- Called by...: Any
  908. *-- Usage.......: ReplMemo("cSource",<cCurrStr>,<cNewStr>)
  909. *-- Example.....: ?ReplMemo("NOTES","Test","testing")
  910. *-- Returns.....: .T. if a memo field, or character string with changes
  911. *-- Parameters..: cSource  = Source to make changes IN
  912. *--               cCurrStr = Current string (item(s)) to be changed
  913. *--               cNewStr  = Change 'Current' to this ....
  914. *-------------------------------------------------------------------------------
  915.  
  916.     parameters cSource, cCurrStr, cNewStr
  917.     cConsole = set("CONSOLE")
  918.     
  919.     nBytes = 0
  920.     nPointer = 0
  921.     nMaster = 0
  922.     
  923.     *-- error
  924.     if pcount() # 3   && valid number of parms
  925.         ?"Error."
  926.         ?"Usage: ReplMemo(<Memo/string>,<Current String>,<New String>)"
  927.         RETURN .f.
  928.     endif
  929.     
  930.     *-- start
  931.     if type(cSource) = "M"                         && if a memo ...
  932.         if len(&cSource) > 254                      && if > 254 char
  933.             cNewFile = (cSource)+".TXT"              && create a temp file
  934.             erase cNewFile
  935.             nPointer = fcreate(cNewFile,"A")
  936.         endif
  937.     else
  938.         *-- if not a memo, just perform the replace ...
  939.         RETURN (MemStuff(cSource,cCurrStr,cNewStr))
  940.     endif
  941.     
  942.     *-- memo handling ...
  943.     nTotLen = len(&cSource)
  944.     nCounter = 1
  945.     nOffSet = 0
  946.     do while nOffSet <= nTotLen
  947.         cTempStr = "arr"+ltrim(str(nCounter))
  948.         if (nOffSet+200) < nTotLen
  949.             cTempStr = substr(&cSource,nOffSet+1,200)
  950.         else
  951.             cTempStr = substr(&cSource,nOffSet+1,nTotLen)
  952.         endif
  953.         cTemp2 = space(200)
  954.         cTemp2 = MemStuff(cTempStr, cCurrStr, cNewStr)
  955.         nBytes = fwrite(nPointer,cTemp2)
  956.         
  957.         nCounter = nCounter + 1
  958.         nOffSet = nOffSet + 200
  959.     enddo
  960.     
  961.     nNull = fclose(nPointer)
  962.     append memo &cSource) from (newfile) overwrite
  963.  
  964. RETURN .T.
  965. *-- EoF: ReplMemo()
  966.  
  967. FUNCTION MemStuff
  968. *-------------------------------------------------------------------------------
  969. *-- Programmer..: Sri Raju (Borland Technical Support)
  970. *-- Date........: 08/01/1992
  971. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  972. *--               Replaces a specific string in a character string, by another,
  973. *--               and returns the resultant string.
  974. *-- Written for.: dBASE IV, 1.5
  975. *-- Rev. History: 08/01/1992 -- Original Release
  976. *-- Calls.......: Stub()               Function in STRINGS.PRG
  977. *-- Called by...: ReplMemo()           Funciton in STRINGS.PRG
  978. *-- Usage.......: MemStuff(<cSource>,<cCurrStr>,<cNewStr>)
  979. *-- Example.....: ? MemStuff(cTestStr,"Test","Testing")
  980. *-- Returns.....: Character
  981. *-- Parameters..: cSource  = Source to make changes IN
  982. *--               cCurrStr = Current string (item(s)) to be changed
  983. *--               cNewStr  = Change 'Current' to this ....
  984. *-------------------------------------------------------------------------------
  985.  
  986.     parameters cSource, cCurrStr, cNewStr
  987.     private cSource, cCurrStr, cNewStr
  988.     cRetStr  = ""
  989.     cHoldStr = ""
  990.     cInitStr = cSource
  991.     
  992.     do while len(cInitStr) => 1
  993.         cHoldStr = cInitStr
  994.         if at(cCurrStr,cNewStr) > 0
  995.             cTemp = substr(cInitStr,1,at(cCurrStr,cHoldStr))
  996.             nPos  = at(cCurrStr,cHoldStr)
  997.             cReturn = cReturn+Stub(cTemp,nPos,cNewStr)
  998.             cInitStr = substr(cHoldStr,at(cReplace,cHoldStr)+len(cNewStr))
  999.         else
  1000.             cReturn = trim(cInitStr)+trim(cHoldStr)
  1001.             cInitStr = ""
  1002.         endif
  1003.     enddo
  1004.  
  1005. RETURN (cReturn)
  1006. *-- EoF: MemStuff()
  1007.  
  1008. FUNCTION Stub
  1009. *-------------------------------------------------------------------------------
  1010. *-- Programmer..: Sri Raju (Borland Technical Support)
  1011. *-- Date........: 08/01/1992
  1012. *-- Notes.......: This returns a specific number of characters from the given
  1013. *--               string specified by the parameter innum, added to the
  1014. *--               third parameter.
  1015. *-- Written for.: dBASE IV, 1.5
  1016. *-- Rev. History: 08/01/1992 -- Original Release
  1017. *-- Calls.......: None
  1018. *-- Called by...: MemStuff()           Function in STRINGS.PRG
  1019. *-- Usage.......: Stub(<cString>,nIn,<cIn>)
  1020. *-- Example.....: ? Stub(cTest,5,"Test")
  1021. *-- Returns.....: Character
  1022. *-- Parameters..: cString = Character string to look in
  1023. *--               nIn     = # of characters to return
  1024. *--               cIn     = characters to add to the end of ...
  1025. *-------------------------------------------------------------------------------
  1026.  
  1027.     parameters cString, nIn, cIn
  1028.  
  1029. RETURN trim(substr(cString,1,nIn-1)+cIn)
  1030. *-- EoF: Stub()
  1031.  
  1032. FUNCTION FirstMem
  1033. *-------------------------------------------------------------------------------
  1034. *-- Programmer..: Sri Raju (Borland Technical Support)
  1035. *-- Date........: 08/01/1992
  1036. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  1037. *--               Capitalizes the first character of all the words in the string
  1038. *--               that is passed as a parameter, and returns the resultant
  1039. *--               string. If a name of a memo field is pass as the parameter,
  1040. *--               it re-writes the memo field, and returns a .T.
  1041. *-- Written for.: dBASE IV, 1.5
  1042. *-- Rev. History: 08/01/1992 -- Original Release
  1043. *-- Calls.......: FirstCap()           Function in STRINGS.PRG
  1044. *-- Called by...: None
  1045. *-- Usage.......: FirstMem(cInStr)
  1046. *-- Example.....: ? FirstMem("this is a string")
  1047. *-- Returns.....: Either character string with first letter of each word
  1048. *--               capitalized, or .T. (if a Memo).
  1049. *-- Parameters..: cInStr = character string or Memo Field name
  1050. *-------------------------------------------------------------------------------
  1051.     
  1052.     parameters cInStr
  1053.  
  1054.     nBytes = 0
  1055.     lMemo = .F.
  1056.     lReturn = .T.
  1057.     nFPtr = 0
  1058.     nMasterCnt = 0
  1059.  
  1060.     if pcount() # 1
  1061.         ? "Error."
  1062.         ? "Usage:- FIRSTMEM (<string>) "
  1063.         lMemo = .F.
  1064.     else
  1065.         if type(instr) = "M"
  1066.             lMemo = .T.
  1067.             cNewFile = (cInStr) + ".txt"
  1068.             erase (cnewfile)
  1069.             nFPtr = fcreate(cNewFile, "A")
  1070.         else
  1071.             lReturn = .F.
  1072.         endif
  1073.     endif
  1074.         
  1075.     if lMemo 
  1076.         nTotLen = len(&CInStr)
  1077.         nCntr = 1
  1078.         nOffSet = 0
  1079.             do while nOffSet <= nTotLen
  1080.                 if (nOffSet + 250) < nTotLen
  1081.                     cTemp = substr(&cInStr, nOffSet + 1, 250)
  1082.                 else
  1083.                     cTemp = substr(&CInStr, nOffSet + 1, nTotLen)
  1084.                 endif
  1085.                 cTempStr = space(250)
  1086.                 cTempStr = FirstCap(cTemp)
  1087.                 nBytes = fwrite(nFPtr, cTempStr)
  1088.                 
  1089.                 nCntr = nCntr + 1
  1090.                 nOffSet = nOffSet + 250
  1091.             enddo
  1092.             x = fclose(nFPtr)
  1093.             append memo &cInStr from (CNewFile) overwrite
  1094.     endif
  1095.  
  1096.     if lMemo .or. lReturn
  1097.         RETURN (.F.)
  1098.     else
  1099.         RETURN (FirstCap(cInStr))
  1100.     endif
  1101. *-- EoF: FirstMem()
  1102.  
  1103. FUNCTION FirstCap
  1104. *-------------------------------------------------------------------------------
  1105. *-- Programmer..: Sri Raju (Borland Technical Support)
  1106. *-- Date........: 08/01/1992
  1107. *-- Notes.......: TechNotes, August, 1992, "Strings and Things"
  1108. *--               Capitalizes the first character of a string.
  1109. *-- Written for.: dBASE IV, 1.5
  1110. *-- Rev. History: 08/01/1992 -- Original Release
  1111. *-- Calls.......: None
  1112. *-- Called by...: FirstMem()           Function in STRINGS.PRG
  1113. *-- Usage.......: FirstCap(<cInString>) 
  1114. *-- Example.....: ?FirstCap("stringofcharacters")
  1115. *-- Returns.....: String with first character captilized.
  1116. *-- Parameters..: cInString = String to cap the first letter of
  1117. *-------------------------------------------------------------------------------
  1118.  
  1119.     parameters cInString
  1120.     cRetString = ""
  1121.     cIStr = cInString
  1122.  
  1123.     do while len(cIStr) > 1
  1124.         nPos = at(" ", cIStr) 
  1125.         if nPos <> 0
  1126.             cRetString = cRetString + upper(left(cIStr, 1)) + ;
  1127.                 substr(cIStr, 2, nPos-1)
  1128.         else
  1129.             cRetString = cRetString + upper(left(cIStr, 1)) + substr(cIStr, 2)
  1130.             exit
  1131.         endif
  1132.         do while substr(cIStr, nPos, 1) = " "
  1133.             nPos = nPos + 1
  1134.         enddo
  1135.         cIStr = substr(cIStr, nPos)
  1136.     enddo
  1137.  
  1138. RETURN (cRetString)
  1139. *-- EoF: FirstCap()
  1140.  
  1141. FUNCTION StripND
  1142. *-------------------------------------------------------------------------------
  1143. *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
  1144. *-- Date........: 01/04/1993
  1145. *-- Notes.......: Strips characters out of a numeric character string (like
  1146. *--               perhaps, a date ... 01/04/93 would become 010493)
  1147. *-- Written for.: dBASE IV, 1.5
  1148. *-- Rev. History: 01/04/1993 -- Original Release
  1149. *-- Calls.......: IsDigit()            Function in STRINGS.PRG
  1150. *-- Called by...: Any
  1151. *-- Usage.......: StripND(<cNumArg>)
  1152. *-- Example.....: keyboard stripnd(dtoc(date()))
  1153. *-- Returns.....: character string
  1154. *-- Parameters..: cNumArg = Character memvar containing a "numeric" string
  1155. *-------------------------------------------------------------------------------
  1156.  
  1157.     parameters cNumArg
  1158.     private cNumStr, nLen, cRetVal, nCount, cChar
  1159.     cNumStr = cNumArg
  1160.     nLen = len(cNumStr)
  1161.     cRetVal = ""
  1162.     nCount = 0
  1163.     do while nCount <= nLen
  1164.         nCount = nCount + 1
  1165.         cChar = substr(cNumStr,nCount,1)
  1166.         if isdigit(cChar)
  1167.             cRetVal = cRetVal+cChar
  1168.         endif
  1169.     enddo
  1170.  
  1171. RETURN cRetVal
  1172. *-- EoF: StripND()
  1173.  
  1174. FUNCTION Strip
  1175. *-------------------------------------------------------------------------------
  1176. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 71542,2712)
  1177. *-- Date........: 01/05/1993
  1178. *-- Notes.......: Strips out specified character(s) from a string
  1179. *-- Written for.: dBASE IV, 1.5
  1180. *-- Rev. History: 01/05/1993 -- Original Release
  1181. *-- Calls.......: None
  1182. *-- Called by...: Any
  1183. *-- Usage.......: Strip(<cVar>,<cArg>)
  1184. *-- Example.....: ?strip(dtoc(date(),"/")
  1185. *-- Returns.....: Character
  1186. *-- Parameters..: cVar = variable/field to remove character(s) from
  1187. *--               cArg = item to remove from cVar
  1188. *-------------------------------------------------------------------------------
  1189.  
  1190.   parameter cVar, cArg
  1191.   do while cArg $ cVar
  1192.     cVar = stuff( cVar, at( cArg, cVar ), 1, "" )
  1193.   enddo
  1194.  
  1195. RETURN cVar
  1196. *-- EoF: Strip()
  1197.  
  1198. PROCEDURE WordWrap
  1199. *-------------------------------------------------------------------------------
  1200. *-- Programmer..: David Frankenbach (CIS: 72147,2635)
  1201. *-- Date........: 01/14/1993 (Version 1.1)
  1202. *-- Notes.......: Wraps a long string, breaking it into strings that have
  1203. *--               a maximum length of nWidth. The first output is displayed
  1204. *--               @nRow, nCol. Words are not split ...
  1205. *-- Written for.: dBASE IV, 1.5
  1206. *-- Rev. History: 01/06/1993 -- Original Release (Version 1.0)
  1207. *--               01/14/1993 -- Version 1.1 -- Corrected side-effect of 
  1208. *--                       destroying string arg, added test for 
  1209. *--                       string[nWidth+1] = " "
  1210. *-- Calls.......: None
  1211. *-- Called by...: Any
  1212. *-- Usage.......: do WordWrap with <nRow>, <nCol>, <cString>, <nWidth>
  1213. *-- Example.....: do WordWrap with 2,2,cText,38
  1214. *-- Returns.....: None
  1215. *-- Parameters..: nRow     = Row to display first line at
  1216. *--               nCol     = Left side of area to display text at
  1217. *--               cString  = text to wrap
  1218. *--               nWidth   = Width of area to wrap text in
  1219. *-------------------------------------------------------------------------------
  1220.  
  1221.     parameters nRow, nCol, cString, nWidth
  1222.     private cTemp, nI, cStr
  1223.     
  1224.     cStr = cString                  && work with a COPY of input, to avoid
  1225.                                     && destroying original
  1226.     
  1227.     do while len(cStr) > 0          && while there's something to work on
  1228.         if (nWidth < len(cStr))
  1229.             nI = nWidth               && look for last " " in first nWidth
  1230.             
  1231.             if substr(cStr,nI+1,1) # " "
  1232.                 do while ( (nI > 0) .and. (substr(cStr,nI,1) # " ") )
  1233.                     nI = nI - 1
  1234.                 enddo
  1235.             endif
  1236.             
  1237.             if nI = 0                 && no spaces
  1238.                 nI = nWidth            && get first nWidth characters
  1239.             endif
  1240.         else
  1241.             nI = len(cStr)         && use the rest of the string
  1242.         endif
  1243.         
  1244.         cTemp = left(cStr,nI)     && get the part we're going to display
  1245.         
  1246.         if nI < len(cStr)         && remove that part
  1247.            cStr = ltrim(substr(cStr,nI + 1))
  1248.         else
  1249.             cStr = ""
  1250.         endif
  1251.         
  1252.         *-- display it
  1253.         @nRow,nCol say cTemp
  1254.         *-- move to next row
  1255.         nRow = nRow + 1
  1256.         
  1257.     enddo
  1258.     
  1259. RETURN
  1260. *-- EoP: WordWrap
  1261.  
  1262. FUNCTION BreakName
  1263. *-------------------------------------------------------------------------------
  1264. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  1265. *-- Date........: 03/21/1993
  1266. *-- Notes.......: Returns part of a name based on user positioning of cursor.
  1267. *--               This function requires the programmer to set up any window
  1268. *--               desired; the writing surface must have a minimum width of
  1269. *--               45 characters or the length of the name plus 2, whichever
  1270. *--               is greater, and must be at least 4 rows high.
  1271. *-- Written for.: dBASE IV 1.5 ( earlier versions will require changing
  1272. *--               the optional parameter to a required one )
  1273. *-- Rev. History: 03/21/1993 -- Original
  1274. *-- Calls.......: NamePart()                    function in STRINGS.PRG
  1275. *--               MarkLine()                    function in STRINGS.PRG
  1276. *-- Called by...: Any
  1277. *-- Usage.......: Breakname("<cName>" [,"<cPart>"] )
  1278. *-- Example.....: LastName = BreakName( "Dr. E. N. Smedley III, "L" )
  1279. *-- Returns.....: character     = substring containing part of the name
  1280. *-- Parameters..: cName         = Name to parse
  1281. *--               cPart         = optional, a character from the set below:
  1282. *--                                 P -- prefix( es )
  1283. *--                                 F -- first name
  1284. *--                                 M -- middle name or initial
  1285. *--                                 L -- last name
  1286. *--                                 S -- suffix( es )
  1287. *-------------------------------------------------------------------------------
  1288.         parameters cName, cPart
  1289.         private nPos, cP, cParts, nPart, cPrompts, nFirst, nLast, cRet
  1290.         private nRow, nCol, nOff
  1291.         cRet = ""
  1292.         store 0 to nPos, nParts, nPart
  1293.         cParts = "PFMLS"
  1294.         *                    1         2         3         4
  1295.         * Ruler-->  123456789012345678901234567890123456789012
  1296.         cPrompts = "desired part  prefix(es)    first name    " ;
  1297.                  + "middle name(s)last name     suffix(es)"
  1298.         if type( "cPart" ) # "C" .or. "" = cPart
  1299.           nPos = 1
  1300.           cP = "?"
  1301.         endif
  1302.         if nPos = 0
  1303.           cP = upper( left( ltrim( cPart ), 1 ) )
  1304.           nPart = at( cP, cParts )
  1305.         endif
  1306.         if nPart = 0
  1307.           nPos = 1
  1308.         else
  1309.           nPos = NameMark( cName, cP, "B" )
  1310.           nPos = iif( nPos = 0, len( cName ) + 1, nPos )
  1311.         endif
  1312.         nRow = row()
  1313.         nCol = col()
  1314.         nOff = int( ( 43 - len( cName ) ) / 2 )
  1315.         @ nRow, nCol + nOff clear to nRow + 4, nCol + max( 45, 45 - nOff )
  1316.         @ nRow, nCol say "Please use the arrow keys to place the cursor"
  1317.         @ nRow + 1, nCol say "on the FIRST character of the "
  1318.         @ nRow + 1, col() say trim( substr( cPrompts, nPart * 14 + 1, 14 ) ) ;
  1319.                 + ":"
  1320.         @ nRow + 4, nCol + nOff say ""
  1321.         nFirst = MarkLine( cName, nPos )
  1322.         if nFirst = 0 .or. nFirst > len( cName )
  1323.           RETURN cRet
  1324.         endif
  1325.         if cP = "S"
  1326.           nLast = len( trim( cName ) )
  1327.         else
  1328.           @ nRow, nCol + nOff clear to nRow + 4, nCol + max( 43, 43 - nOff )
  1329.           @ nRow, nCol say "Please use the arrow keys to place the cursor"
  1330.           @ nRow + 1, nCol say " on the LAST character of the "
  1331.           @ nRow + 1, col() say trim( substr( cPrompts, nPart * 14 + 1, 14 ) ) ;
  1332.                + ":"
  1333.           nPos = NameMark( cName, cP, "E" )
  1334.           @ nRow + 4, nCol + nOff say ""
  1335.           nLast = MarkLine( cName, nPos )
  1336.         endif
  1337.         if nLast > nFirst
  1338.           cRet = substr( cName, nFirst, nLast - nFirst + 1 )
  1339.         endif
  1340. RETURN cRet
  1341. *-- EoF: BreakName()
  1342.  
  1343. FUNCTION NamePart
  1344. *-------------------------------------------------------------------------------
  1345. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  1346. *-- Date........: 03/21/1993
  1347. *-- Notes.......: Guesses which portion of a name held in a single variable
  1348. *--               in the usual printing order corresponds to the letter code
  1349. *--               given for prefix, first name, middle names, last name or
  1350. *--               suffixes and returns that portion.  This does not work
  1351. *--               correctly for all names and is recommended to be used
  1352. *--               only with some human interpretation of the results.
  1353. *-- Written for.: dBASE IV 1.5
  1354. *-- Rev. History: 03/21/1993 -- Original
  1355. *-- Calls.......: NameMark()                       function in STRINGS.PRG
  1356. *-- Called by...: Any
  1357. *-- Usage.......: NamePart( <cName> ,<cPart> )
  1358. *-- Example.....: Suffix = NamePart( "John Doe Jr. Ph. D.", "S" )
  1359. *-- Returns.....: character     = substring, part of the name, or null string
  1360. *-- Parameters..: cName         = Name to parse
  1361. *--               cPart         = a character from the set below:
  1362. *--                                 P -- prefix
  1363. *--                                 F -- first name
  1364. *--                                 M -- middle name(s) or initial(s) or both
  1365. *--                                 L -- last name
  1366. *--                                 S -- suffix(es)
  1367. *-------------------------------------------------------------------------------
  1368.         parameters cName, cPart
  1369.         private nStart, nStop, cP, nTrimmed, nMark, cN1, cN2
  1370.         store 0 to nStart, nStop
  1371.         cRet = ""
  1372.         if type( "cPart" ) # "C" .or. "" = cPart .or. "" = cName
  1373.           RETURN cRet
  1374.         endif
  1375.         cP = upper( left( cPart, 1 ) )
  1376.         if .not. cP $ "PFMLS"
  1377.           RETURN cRet
  1378.         endif
  1379.         nStart = NameMark( cName, cP, "B" )
  1380.         nStop  = NameMark( cName, cP, "E" )
  1381.         if nStop > nStart .and. nStart > 0
  1382.           cRet = substr( cName, nStart, nStop - nStart + 1 )
  1383.         endif
  1384. RETURN cRet
  1385. *-- EoF: NamePart()
  1386.  
  1387. FUNCTION NameMark
  1388. *-------------------------------------------------------------------------------
  1389. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  1390. *-- Date........: 03/21/1993
  1391. *-- Notes.......: Guesses which portion of a name held in a single variable
  1392. *--               in the usual printing order corresponds to the letter code
  1393. *--               given for prefix, first name, middle names, last name or
  1394. *--               suffixes and returns the position of the character that
  1395. *--               begins or ends that portion.  This does not work properly
  1396. *--               for all names and is recommended to be used with MarkLine(),
  1397. *--               as in BreakName().
  1398. *-- Written for.: dBASE IV 1.5
  1399. *-- Rev. History: 03/21/1993 -- Original
  1400. *-- Calls.......: Rat()                         function in STRINGS.PRG 
  1401. *-- Called by...: Any
  1402. *-- Usage.......: NameMark( <cName> ,<cPart>, <cEnd> )
  1403. *-- Example.....: Suffix = NamePart( "John Doe Jr. Ph. D.", "S", "B" )
  1404. *-- Returns.....: numeric       = position in cName of requested character, or 0 the name, or null string
  1405. *-- Parameters..: cName         = Name to parse
  1406. *--               cPart         = a character from the set below:
  1407. *--                                 P -- prefix
  1408. *--                                 F -- first name
  1409. *--                                 M -- middle name(s) or initial(s) or both
  1410. *--                                 L -- last name
  1411. *--                                 S -- suffix(es)
  1412. *--               cEnd          = a character from the set below:
  1413. *--                                 B or F -- first char of the part
  1414. *--                                 E or L -- last char of the part
  1415. *-------------------------------------------------------------------------------
  1416.         parameters cName, cPart, cEnd
  1417.         private nStart, nStop, nRet, cP, cE, nTrimmed, nM1, nM2, cN1, cN2, lC
  1418.  
  1419.         * intialize and check for proper parameters
  1420.         store 0 to nStart, nStop, nRet
  1421.         if type( "cPart" ) # "C" .or. type( "cName" ) # "C" .or. ;
  1422.           type( "cEnd" ) # "C" .or. "" = cName .or. "" = cPart .or. "" = cEnd
  1423.           RETURN nRet
  1424.         endif
  1425.         cP = upper( left( cPart, 1 ) )
  1426.         if .not. cP $ "PFMLS"
  1427.           RETURN nRet
  1428.         endif
  1429.         cE = upper( left( cEnd, 1 ) )
  1430.         do case
  1431.           case cE $ "BF"
  1432.             cE = "B"
  1433.           case cE $ "EL"
  1434.             cE = "E"
  1435.           otherwise
  1436.             RETURN nRet
  1437.         endcase
  1438.         * remove end spaces but count leading ones
  1439.         cN1 = ltrim( cName )
  1440.         nTrimmed = len( cName ) - len( cN1 )
  1441.         cN1 = trim( cN1 )
  1442.         * find interior space; if none we're done
  1443.         nM1 = at( " ", cN1 )
  1444.         if nM1 = 0
  1445.           cRet = iif( cP = "L", cN1, "" )
  1446.           RETURN cRet
  1447.         endif
  1448.         * anything ending in a period but one initial is treated as a prefix
  1449.         if nM1 > 3 .and. substr( cN1, nM1 - 1, 1 ) = "."
  1450.           if cP = "P"
  1451.             nStart = 1
  1452.             nStop = nM1 - 1
  1453.           else
  1454.             cN2 = ltrim( substr( cN1, nM1 + 1 ) )
  1455.             nTrimmed = nTrimmed + len( cN1 ) - len( cN2 )
  1456.             cN1 = cN2
  1457.             nM1 = at( " ", cN1 )
  1458.           endif
  1459.         else
  1460.           if cP = "P"
  1461.             nStart = 1
  1462.           endif
  1463.         endif
  1464.         * if we're not looking for prefix, first word is first name
  1465.         * if not looking for it either, trim it off and adjust space count
  1466.         if nStart = 0
  1467.           if cP = "F"
  1468.             nStart = 1
  1469.             nStop = nM1 - 1
  1470.           else
  1471.             cN2 = ltrim( substr( cN1, nM1 + 1 ) )
  1472.             nTrimmed = nTrimmed + len( cN1 ) - len( cN2 )
  1473.             cN1 = cN2
  1474.           endif
  1475.         endif
  1476.         * if not done yet, look for suffix.  Anything after a comma plus
  1477.         * anything ending with period and certain common differentiators
  1478.         if nStart = 0
  1479.           nM1 = at( ",", cN1 )
  1480.           if nM1 > 0
  1481.             cN1 = left( cN1, nM1 - 1 )
  1482.             nM2 = nM1
  1483.           else
  1484.             nM2 = len( cN1 ) + 1
  1485.           endif
  1486.           nM1 = rat( " ", cN1 )
  1487.           lC = .T.
  1488.           do while lC
  1489.             lC = .F.
  1490.             if upper( right( cN1, 3 ) ) $ "III 2D 2ND 3D 3RD"
  1491.               nM1 = len( cN1 ) - iif( left( right( cN1, 3 ), 1 ) = " ", ;
  1492.                 3, 4 )
  1493.               cN1 = left( cN1, nM1 )
  1494.               lC = .T.
  1495.               nM2 = nM1 + 2
  1496.               nM1 = rat( " ", cN1 )
  1497.             endif
  1498.             if nM1 > 0 .and. "." $ substr( cN1, nM1 )
  1499.               cN1 = left( cN1, nM1 - 1 )
  1500.               cL = .T.
  1501.               nM2 = nM1 + 1
  1502.               nM1 = rat( " ", cN1 )
  1503.             endif
  1504.           enddo
  1505.           * the two marks delineate the starts of the last name and suffix
  1506.           do case
  1507.             case cP = "S"
  1508.               nStart = nM2
  1509.               nStop = len( cName )
  1510.             case cP = "L"
  1511.               nStart = nM1 + 1
  1512.               nStop = nM2 - 1
  1513.             otherwise
  1514.               nStart = 1
  1515.               nStop = nM1 - 1
  1516.           endcase
  1517.         endif
  1518.         if nStart < nStop
  1519.           nStop = min( nStop, Nstart + len( trim( substr( cN1, Nstart, ;
  1520.              Nstop - Nstart + 1 ) ) ) - 1 )
  1521.           nRet = iif( cE = "B", nStart, nStop ) + nTrimmed
  1522.         endif
  1523. RETURN nRet
  1524. *-- EoF: NameMark()
  1525.  
  1526. FUNCTION MarkLine
  1527. *-------------------------------------------------------------------------------
  1528. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  1529. *-- Date........: 03/21/1993
  1530. *-- Notes.......: Presents a string with cursor at character given by
  1531. *--               numeric offset, allows user to move the cursor within
  1532. *--               the string using arrow keys and returns position
  1533. *--               within the string at which cursor is located when edit
  1534. *--               is ended, or 0 if edit is ended by pressing {Esc}.
  1535. *--               The programmer must deal with opening windows,
  1536. *--               positioning the edit, etc. before calling the function.
  1537. *--               Mouse support not supplied for this version.
  1538. *-- Written for.: dBASE IV 1.5
  1539. *-- Rev. History: 03/21/1993 -- Original
  1540. *-- Calls.......: None
  1541. *-- Called by...: Any
  1542. *-- Usage.......: MarkLine( <cLine> [, <nPos> ] )
  1543. *-- Example.....: ? MarkLine( "G. C. K. Chesterton", 10 )
  1544. *-- Returns.....: numeric, character position of the cursor, or 0 if {Esc}
  1545. *-- Parameters..: cLine         = Line to parse
  1546. *--               nPos          = optional, default position of cursor
  1547. *--                               if omitted, cursor is at first character
  1548. *-------------------------------------------------------------------------------
  1549.         parameters cLine, nPos
  1550.         private nP, nRet, nCol, cCurs
  1551.         cCurs = set( "CURSOR" )
  1552.         set cursor on
  1553.         nP = iif( type( "nPos" ) = "L", 1, nPos )
  1554.         nRet = nP
  1555.         nCol = col()
  1556.         @ row(), nCol say cLine
  1557.         nKey = 0
  1558.         do while nKey # 27 .and. nKey # 13 .and. nKey # 23
  1559.           @ row(), nCol + nRet - 1 say ""
  1560.           nKey = inkey( 0 )
  1561.           do case
  1562.             case nKey = 27
  1563.               nRet = 0
  1564.             case nKey = 4 .and. nRet < len( cLine )
  1565.               nRet = nRet + 1
  1566.             case nKey = 19 .and. nRet > 1
  1567.               nRet = nRet - 1
  1568.           endcase
  1569.         enddo
  1570.         if cCurs = "OFF"
  1571.           set cursor off
  1572.         endif
  1573. RETURN nRet
  1574. *-- EoF: MarkLine() 
  1575.  
  1576. FUNCTION Decode
  1577. *-------------------------------------------------------------------------------
  1578. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1579. *-- Date........: 11/25/1992 (unknown.  Stolen from somewhere....)
  1580. *-- Note........: simple decoding for primitive password protection
  1581. *-- Written for.: dBASE IV 1.1+                                                  
  1582. *-- Rev. History: 11/25/1992 -- Original
  1583. *-- Calls.......: None
  1584. *-- Called by...: Any
  1585. *-- Usage.......: Decode(<cInput>)
  1586. *-- Example.....: Password = Decode(cPassWd)
  1587. *-- Returns.....: decoded string
  1588. *-- Parameters..: <cInput> = encoded string
  1589. *-------------------------------------------------------------------------------
  1590.  
  1591.     parameters cInput
  1592.     private cString
  1593.  
  1594.     cString = cInpit
  1595.   if isblank(m->cString)
  1596.     return cString
  1597.   else
  1598.     cpw = m->cString
  1599.     x = 1
  1600.     do while x <= len(trim(m->cString))
  1601.       cString = stuff(m->cInput,x,1,chr(asc(substr(m->cpw,x,1))-x))
  1602.       x = x + 1
  1603.     enddo
  1604.     endif
  1605.  
  1606. RETURN cString
  1607. *-- EoF: Decode()
  1608.  
  1609. FUNCTION Encode
  1610. *-------------------------------------------------------------------------------
  1611. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1612. *-- Date........: 11/25/1992 (unknown.  Stolen from somewhere....)
  1613. *-- Note........: simple encoding for primitive password protection
  1614. *-- Written for.: dBASE IV 1.1+
  1615. *-- Rev. History: 11/25/1992 -- Original
  1616. *-- Calls.......: None
  1617. *-- Called by...: Any
  1618. *-- Usage.......: Encode(<cInput>)
  1619. *-- Example.....: store encode(cPassWd) to PassWord
  1620. *-- Returns.....: encoded string
  1621. *-- Parameters..: cInput = unencoded string
  1622. *-------------------------------------------------------------------------------
  1623.     parameters cInput
  1624.     private cString
  1625.     cString = cInput
  1626.  
  1627.   * encode the password
  1628.   cpw = m->cString
  1629.   x = 1
  1630.   do while x <= len(trim(m->cString))
  1631.     cString = stuff(m->cString,x,1,chr(asc(substr(m->cpw,x,1))+x))
  1632.     x = x + 1
  1633.   enddo
  1634.  
  1635. RETURN cString
  1636. *-- EoF: Encode()
  1637.  
  1638. FUNCTION ExEqual
  1639. *-------------------------------------------------------------------------------
  1640. *-- Programmer..: Angus Scott-Fleming
  1641. *-- Date........: 11/26/1992  (Improvement on Genifer function)
  1642. *-- Note........: Test for two variables for exact match
  1643. *-- Written for.: dBASE IV 1.1+
  1644. *-- Rev. History: 11/26/1992 - test for TYPE MATCH as well!
  1645. *-- Calls.......: None
  1646. *-- Called by...: Any
  1647. *-- Usage.......: ExEqual(<cInput1>,<cInput2>)
  1648. *-- Example.....: if ExEqual(alias(),"XYZ")
  1649. *-- Returns.....: .T. (exact match) or .F. (different types or no match)
  1650. *-- Parameters..: cInput1 = \
  1651. *--               cInput2 =  - two memvars to be compared
  1652. *-------------------------------------------------------------------------------
  1653.  
  1654.   parameters cInput1, cInput2
  1655.  
  1656. RETURN (type("cInput1") = type("cInput2")) .and. ;
  1657.   (cInput1 = cInput2) .and. (cInput2 = cInput1)
  1658. *-- EoF: ExEqual()
  1659.  
  1660. FUNCTION Str_Edit
  1661. *-------------------------------------------------------------------------------
  1662. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3232)
  1663. *-- Date........: 05/26/1992
  1664. *-- Notes.......: strips unwanted characters from a string
  1665. *--               (e.g. to normalize international phone numbers
  1666. *--               to nothing but numerals and "-")
  1667. *-- Written for.: dBASE IV 1.1+
  1668. *-- Rev. History: 01/01/1991 -- Original (Pete Carr)
  1669. *--               05/26/1992 -- Current
  1670. *-- Calls.......: None
  1671. *-- Called by...: Any
  1672. *-- Usage.......: valid required Str_Edit(<cInput>,<cBadChars>)
  1673. *-- Example.....: iphone = space(20)
  1674. *--               @ 6,12  say "Enter Phone# : " get iphone;
  1675. *--                       picture replicate("#",len(iphone));
  1676. *--                       valid required Str_Edit(iphone, " .+")
  1677. *--               input "011-(49)-345+6789-6790" 
  1678. *--               becomes "011-49-3456789-6790"
  1679. *-- Returns.....: .f., then .t.
  1680. *-- Parameters..: cInput    = input string
  1681. *--               cBadChars = excluded characters
  1682. *-------------------------------------------------------------------------------
  1683.  
  1684.   parameters cInput,cBadChars
  1685.   private lrv,nel,nsl,csc,nca,cInput,cBadChars
  1686.  
  1687.   lRV  = .t.              && init return value to true
  1688.   nEL  = len(cBadChars)   && len of edit characters
  1689.   nSL  = len(cInput)      && len of string to edit
  1690.  
  1691.   cInput = trim(cInput)        && first, trim string to edit
  1692.  
  1693.   do while nEL > 0        && search string for cBadChars[el]
  1694.      cSC = substr(cBadChars,nEL,1)
  1695.      do while .t.        && delete all cBadChars[el] contained in cInput
  1696.         nCA = at(cSC,cInput)
  1697.         if nCA > 0
  1698.            cInput = stuff(cInput,nCA,1,"")
  1699.            lRV = .f.
  1700.            loop
  1701.         endif
  1702.         exit
  1703.      enddo
  1704.      nEL = nEL-1
  1705.   enddo
  1706.  
  1707.   do while .t.           && search for double spaces and delete
  1708.      nCA = at("  ",cInput)
  1709.      if nCA > 0
  1710.         cInput = stuff(cInput,nCA,1,"")
  1711.         lRV = .f.
  1712.      else
  1713.         exit
  1714.      endif
  1715.   enddo
  1716.  
  1717.   cInput = cInput + space(nSL-len(cInput))  && restore string to original len
  1718.   if .not. lRV
  1719.      keyboard chr(32)+chr(13)     && accept and display edited string
  1720.   endif
  1721.  
  1722. RETURN lRV
  1723. *-- EoF: Str_Edit
  1724.  
  1725. *-------------------------------------------------------------------------------
  1726. *-- EoP: STRINGS.PRG
  1727. *-------------------------------------------------------------------------------
  1728.