Plateforme Level Extreme
Abonnement
Profil corporatif
Produits & Services
Support
Légal
English
Textmerge()- vfp7
Message
Information générale
Forum:
Visual FoxPro
Catégorie:
Autre
Divers
Thread ID:
00463864
Message ID:
00463869
Vues:
22
>Has anyone made a function like the textmerge function in VFP 7 that they would like to share?
Hi John,
There is a version of texmerge function I'm using:
*            
* 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	
--sb--
Précédent
Répondre
Fil
Voir

Click here to load this message in the networking platform