* * Procedure _TextMerge * * Purpose Evaluate the expressions in a text string * * * Param's * 1 - The text to be evaluated * 2&3 - the left & right delimeter for an expression in a text * The default is "<<" and ">>" respectively * 3 - Display Errors if .T. * * Return * * Note * * Modified * * * PARAMETERS tcTemplate, tcLeftDelim, tcRightDelim, tlDispError PRIVATE pcEvalStr, pcCrLf LOCAL lcMergText, lnPosLeftDlm, lnPosRightDlm, lnPosNow, lnAtPos4, lcVarType LOCAL lnMergTextLen, lnCounter, lcSaveOnError, lcOldStr, lcNewStr LOCAL lcExpDlmLeft, lcExpDlmRight, lItsCurrency, lcTemplate, lnOldMemow, lnCounter IF PARAM() < 2 OR TYPE("tcLeftDelim") <> "C" OR LEN(m.tcLeftDelim) <> 2 lcExpDlmLeft = "<<" ELSE lcExpDlmLeft = m.tcLeftDelim ENDIF IF PARAM() < 3 OR TYPE("tcRightDelim") <> "C" OR LEN(m.tcRightDelim) <> 2 lcExpDlmRight = ">>" ELSE lcExpDlmRight = m.tcRightDelim ENDIF lnOldMemow = SET("MEMOW") SET MEMOW TO 8192 pcCrLf = CHR(13) + CHR(10) lcSaveOnError = ON('ERROR') lcTemplate = tcTemplate lcMergText = tcTemplate lnPosNow = 1 DO WHILE .T. * Find position of the first left delimiter from the left lnPosLeftDlm = AT(lcExpDlmLeft, SUBSTR(lcTemplate, lnPosNow)) IF lnPosLeftDlm = 0 * No more expression EXIT ENDIF * Find position of the first right delimiter from the left lnPosRightDlm = AT(lcExpDlmRight, ; SUBSTR(lcTemplate, lnPosLeftDlm + lnPosNow - 1)) IF lnPosRightDlm = 0 * No right expression delimiter. Maybe dispalay warnning? EXIT ENDIF * Find position of the next left delimiter lnAtPos4 = AT(lcExpDlmLeft, ; SUBSTR(lcTemplate, lnPosLeftDlm + lnPosNow + 1)) IF lnAtPos4 > 0 AND lnAtPos4 < lnPosRightDlm * Process expression inside expression lnAtPos4 = OCCURS(lcExpDlmLeft, ; SUBSTR(lcTemplate, lnPosLeftDlm + lnPosNow - 1, ; lnPosRightDlm - lnAtPos4)) lnAtPos4 = AT(lcExpDlmLeft, ; SUBSTR(lcTemplate, lnPosLeftDlm + lnPosNow - 1), lnAtPos4) lcOldStr = SUBSTR(lcTemplate, ; lnPosLeftDlm + lnPosNow - 1, lnPosRightDlm + 1) pcEvalStr = SUBSTR(lcOldStr, 3, LEN(lcOldStr) - 4) lcOldStr = _textmerge(pcEvalStr) lcTemplate = STRTRAN(lcTemplate, pcEvalStr, lcOldStr) lcMergText = STRTRAN(lcMergText, pcEvalStr, lcOldStr) LOOP ENDIF lcOldStr = SUBSTR(lcTemplate, lnPosLeftDlm + lnPosNow - 1, ; lnPosRightDlm + 1) pcEvalStr = ALLTRIM(SUBSTR(lcOldStr, 3, LEN(lcOldStr) - 4)) ON ERROR DO ShowError With tlDispError lItsCurrency = .F. DO CASE CASE EMPTY(pcEvalStr) pcEvalStr = '' CASE LEFT(pcEvalStr,1) = "$" lItsCurrency = .T. pcEvalStr = EVALUATE(SUBSTR(pcEvalStr,2)) OTHERWISE pcEvalStr = EVALUATE(pcEvalStr) ENDCASE ON ERROR &lcSaveOnError lcVarType = TYPE('pcEvalStr') DO CASE CASE lcVarType=='C' lcNewStr = pcEvalStr * -sb- 04/04/2000 CASE lcVarType = "Y" Or (lcVarType=='N' AND lItsCurrency) lcNewStr = "$" + ALLTRIM(STR(pcEvalStr, 24, 2)) CASE lcVarType=='N' lcNewStr = ALLTRIM(STR(pcEvalStr, 24, 12)) DO WHILE RIGHT(lcNewStr, 1)=='0' lcNewStr = LEFT(lcNewStr, LEN(lcNewStr) - 1) IF RIGHT(lcNewStr, 1)=='.' lcNewStr = LEFT(lcNewStr, LEN(lcNewStr) - 1) EXIT ENDIF ENDDO * -sb- 04/04/2000 CASE lcVarType=='T' lcNewStr = TTOC(pcEvalStr) CASE lcVarType=='D' lcNewStr = DTOC(pcEvalStr) CASE lcVarType=='L' lcNewStr = IIF(pcEvalStr, '.T.', '.F.') OTHERWISE lcNewStr = lcOldStr ENDCASE lcMergText = STRTRAN(lcMergText, lcOldStr, lcNewStr) lnPosRightDlm = lnPosLeftDlm + LEN(lcNewStr) IF lnPosRightDlm<=0 EXIT ENDIF lnPosNow = lnPosNow + lnPosRightDlm ENDDO lnCounter = 0 DO WHILE lcExpDlmLeft $ lcMergText AND lcExpDlmRight $ lcMergText *lnMergTextLen = LEN(lcMergText) lcSaveMergText = lcMergText lcMergText = _textmerge(lcMergText) * If after 2 attempts nothing was substituted - get out *IF lnMergTextLen = LEN(lcMergText) IF lcSaveMergText == lcMergText IF lnCounter>=2 EXIT ENDIF lnCounter = lnCounter + 1 ENDIF ENDDO SET MEMOW TO (lnOldMemow) RETURN lcMergText ************************************************************ PROCEDURE ShowError LPARAMETERS tlDispError IF tlDispError WAIT CLEAR WAIT WIND "Error occured during evaluating expression:" + ; pcCrLf + pcEvalStr ENDIF pcEvalStr = "?" + pcEvalStr + "?" RETURN ENDPROC