Level Extreme platform
Subscription
Corporate profile
Products & Services
Support
Legal
Français
Problem with merge two RTF
Message
From
11/06/2008 00:49:44
Reza Meamar
Homa Programming Group
Shiraz, Iran
 
General information
Forum:
Visual FoxPro
Category:
ActiveX controls in VFP
Environment versions
Visual FoxPro:
VFP 7 SP1
OS:
Windows XP SP2
Miscellaneous
Thread ID:
01322805
Message ID:
01323009
Views:
22
Thank you dear sergey,
When i test this useful function, i get an error, but if i ignor it, the result is correct!
Can you see this please?
unfortunatly his website address is rong.
cText1 = "{\rtf1\fbidis\ansi\ansicpg1256\deff0\deflang1025{\fonttbl{\f0\fnil\fcharset0 Arial;}}\viewkind4\uc1\pard\ltrpar\qc\fs32 First Line\par }"
cText2 = "{\rtf1\fbidis\ansi\ansicpg1256\deff0\deflang1025{\fonttbl{\f0\fnil\fcharset0 Arial;}}\viewkind4\uc1\pard\ltrpar\fs18 Second Line\par }"
Landscape = .F.
nPage = 0

= STRTOFILE(JoinRTF(cText1,cText2,Landscape,nPage),"C:\new.rtf")

RETURN




************** Some usefull RTF functions ************
*** (c) 1999, Dmitry Bayanov

*** RtfPSize() - To get RTF-string with pointed Page Size Settings
*** JoinRTF() - Join two RTF-documents into one (UnionRTF function is used)
*** UnionRTF() - RTF-documents union function - create common header and joined text body
*** RTFCreTab() - Creates RTF-table skeleton code
*** RtfTab() - Creates RTF-code for MS Word Table Line (to be adde to table skeleton code)
*** RtfFilRow() - Adding new line to RTF-table and filling it with values
*** TChar_Wide - To convert Wide in CHARS to wide in PITS (1cm = 567 pit)
*** TWide_Char - To convert Wide in PITS to wide in CHARS

*** ArrLen - To get Array Length (0 - if not artray)
*** ArrDel - To delete an element from LOCAL array
*** aADD - To Add an element to the end of array



***********************************************************************
* To get string with Page Size Settings ->  RTF-code for MS Word
* cCode: "L","P", nPage=0(A4), 1(A3), nmT,nmB,nmL,nmR - ïîëÿ â ñì
* in DoAnyRap & Make_Rap :
* nPage=0(A4) npWide=14855,9638 (paperh-margl-margr)16840,1418
* nPage=1(A3) npWide=21829,14571(paperh-margl-margr)23814,16840
FUNCTION RtfPsize(cOrient,nPage,nmT,nmB,nmL,nmR)
LOCAL cBuf
cBuf=""
IF EMPTY(cOrient)
	cOrient="P"
ENDIF
IF EMPTY(nPage)
	nPage=0 && A4
ENDIF
IF !TYPE("nmT")=="N"
	nmT=1.5
ENDIF
IF !TYPE("nmB")=="N"
	nmB=1.7
ENDIF
IF !TYPE("nmL")=="N"
	nmL=2.5
ENDIF
IF !TYPE("nmR")=="N"
	nmR=1.5
ENDIF
DO CASE
	CASE cOrient=="L" .AND. EMPTY(nPage)
		cBuf="\paperw16840\paperh11907\margl"+ALLTRIM(STR(nmL*567))+;
			"\margr"+ALLTRIM(STR(nmR*567))+"\margt"+ALLTRIM(STR(nmT*567))+;
			"\margb"+ALLTRIM(STR(nmB*567))+"\lndscpsxn "
	CASE cOrient=="P" .AND. EMPTY(nPage)
		cBuf="\paperw11907\paperh16840\margl"+ALLTRIM(STR(nmL*567))+;
			"\margr"+ALLTRIM(STR(nmR*567))+"\margt"+ALLTRIM(STR(nmT*567))+;
			"\margb"+ALLTRIM(STR(nmB*567))+" "
	CASE cOrient=="L" .AND. nPage==1
		cBuf="\paperw23814\paperh16840\margl"+ALLTRIM(STR(nmL*567))+"\margr"+;
			ALLTRIM(STR(nmR*567))+"\margt"+ALLTRIM(STR(nmT*567))+"\margb"+;
			ALLTRIM(STR(nmB*567))+"\lndscpsxn "
	CASE cOrient=="P" .AND. nPage==1
		cBuf="\paperw16840\paperh23814\margl"+ALLTRIM(STR(nmL*567))+"\margr"+;
			ALLTRIM(STR(nmR*567))+"\margt"+ALLTRIM(STR(nmT*567))+"\margb"+;
			ALLTRIM(STR(nmB*567))+" "
ENDCASE
RETURN cBuf


*************************************************************
* Join two RTF-documents into one
FUNCTION JoinRTF(cText1,cText2,Landscape,nPage,nmT,nmB,nmL,nmR)
LOCAL cOut,cBuf,cHead,crt1,crt2
cHead=""
cBuf=""
crt1=cText1
crt2=cText2
=UnionRTF(@cHead,@crt1,Landscape)
=UnionRTF(@cHead,@crt2,Landscape)
cOut=cHead+RtfPsize(IIF(Landscape,"L","P"),nPage,nmT,nmB,nmL,nmR)+crt1+"\par "+crt2+"}"
RETURN cOut


**********************************************************************************
* RTF-documents union function - create common header and joined text body:
* Fonts and Colors definition in text body.
* Input arguments - Common capacited Header cHead and text Body cRTF
* cRtf - returned by referenca without header, without resulting symbol "}" and
* with corrected numbers Font, ColorTable (fN,cfN,cbN),
* in cRTF code we find \deffN\ and {\fN\, insert in header and after all
* \plain insert \fN in cRTF, if it's not equal Header's Deff
* (c) Dm.Bayanov, 1998
FUNCTION UnionRTF(cHead,cRTF,Landscape,cFontName)
LOCAL aFont2,aColor2,cHead2,cText2,ni,nj,nk,nCount,cim,aFont0,aColor0, cContr,cDeff
LOCAL cHPart1,cHPart2,cBuf,lAdd,cBuf1,cBuf2,nBuf1,nBuf2,nParam,cParam,nNum,nDeffH,nDeffT

IF EMPTY(cFontName)
	cFontName="Arial Cyr"
ENDIF

IF EMPTY(cHead)
	cHead="{\rtf1\ansi\ansicpg1252\deff0\deftab720{\fonttbl{\f0\fswiss "+cFontName+";}}{\colortbl\red0\green0\blue0;}{\info{\author Created by DBRAD32 Report Generator}}"
ENDIF

IF EMPTY(cRTF)
	cRTF="\viewkind1"
	RETURN .F.
ENDIF

IF .F.
	DECLARE aFont0(1),aFont2(1),aColor0(1),aColor2(1)
ENDIF

*** Split Header from text body
ni=RTFHeadCount(cHead)
cHead=SUBSTR(cHead,1,ni)
ni=RTFHeadCount(cRTF)
cHead2=SUBSTR(cRTF,1,ni)
cText2=SUBSTR(cRTF,ni+1,LEN(cRTF)-ni)
cHPart1=""
cHPart2=""

IF EMPTY(cHead2) .OR. EMPTY(cText2)
	cRTF=""
	RETURN .F.
ENDIF

*** Find default fonts
nDeffH=""
nDeffT=""
cDeff=""
ni=AT("\deff",cHead)
IF ni>0
	cBuf=SUBSTR(cHead,ni+5,10)
	ni=AT("\",cBuf)
	nDeffH=SUBSTR(cBuf,1,ni-1)
ENDIF
ni=AT("\deff",cHead2)
IF ni>0
	cBuf=SUBSTR(cHead2,ni+5,10)
	ni=AT("\",cBuf)
	nDeffT=SUBSTR(cBuf,1,ni-1)
ENDIF

*** Getting Header befor and after fonttbl,colortbl
**************** cHead ******************
** Font cHead processing
nj=AT("{\fonttbl",cHead)
IF nj>0
	** first part of header cHead1
	cHPart1=SUBSTR(cHead,1,nj-1)
	nj=nj+9
	nCount=0
	lAdd=.F.
	FOR ni=nj TO LEN(cHead)
		cim=SUBSTR(cHead,ni,1)
		nCount=IIF(cim=="{",nCount+1,IIF(cim=="}",nCount-1,nCount))
		DO CASE
				*** begin of new font
			CASE cim=="{" .AND. nCount==1
				*** begin of new font
				cBuf=""
				lAdd=.T.

				*** End of font
			CASE cim=="}" .AND. nCount==0
				** number cutting
				nj=AT("\",cBuf,2)
				cBuf=SUBSTR(cBuf,nj+1,LEN(cBuf)-nj)+"}"

				*         ***************** font cyrillisation ***********
				*         ** "Cyr" word adding
				*          IF nCodePage==1251 and. RAT(" Cyr;}",cBuf)==0
				*            cBuf=SUBSTR(cBuf,1,LEN(cBuf)-2)+" Cyr;}"
				*          ENDIF

				** adding font in array
				=AADD(@aFont0,cBuf)
				lAdd=.F.

				*** font collection process
			CASE lAdd
				cBuf=cBuf+cim
		ENDCASE

		*** no more fonts
		IF nCount<0
			EXIT
		ENDIF
	NEXT
ENDIF

*** Color cHead processing
nj=AT("{\colortbl",cHead)
IF nj>0
	nj=nj+10
	cBuf=""
	FOR ni=nj TO LEN(cHead)
		cim=SUBSTR(cHead,ni,1)
		cBuf=cBuf+cim
		*** End of color
		IF cim==";"
			=AADD(@aColor0,cBuf)
			cBuf=""
		ENDIF
		*** no more colors
		IF cim=="}"
			EXIT
		ENDIF
	NEXT
	** second part of header cHead
	IF ni<LEN(cHead)
		** no color definition colortbl
		cHPart2=SUBSTR(cHead,ni+1,LEN(cHead)-ni)
	ENDIF
ENDIF

**************** cHead2 ******************
** Font cHead2 processing
nj=AT("{\fonttbl",cHead2)
IF nj>0
	nj=nj+9 && !!!
	nCount=0
	lAdd=.F.
	FOR ni=nj TO LEN(cHead2)
		cim=SUBSTR(cHead2,ni,1)
		nCount=IIF(cim=="{",nCount+1,IIF(cim=="}",nCount-1,nCount))
		DO CASE
				*** Begin of new font
			CASE cim=="{" .AND. nCount==1
				*** Begin of new font
				cBuf=""
				lAdd=.T.

				*** End of font
			CASE cim=="}" .AND. nCount==0

				*      ***************** font cyrillisation ***********
				*      ** "Cyr" word adding
				*      IF nCodePage==1251 and. RAT(" Cyr;",cBuf)==0
				*        cBuf=SUBSTR(cBuf,1,LEN(cBuf)-1)+" Cyr;"
				*      ENDIF

				** adding font in array
				=AADD(@aFont2,"{"+cBuf+"}")
				lAdd=.F.

				*** font linking
			CASE lAdd
				cBuf=cBuf+cim
		ENDCASE
		*** no more fonts
		IF nCount<0
			EXIT
		ENDIF
	NEXT
ENDIF

*** Color cHead2 processing
nj=AT("{\colortbl",cHead2)
IF nj>0
	nj=nj+10
	cBuf=""
	FOR ni=nj TO LEN(cHead2)
		cim=SUBSTR(cHead2,ni,1)
		cBuf=cBuf+cim
		*** end of color
		IF cim==";"
			=AADD(@aColor2,cBuf) && adding color in array
			cBuf=""
		ENDIF
		*** no more colors
		IF cim=="}"
			EXIT
		ENDIF
	NEXT
ENDIF

****************** Passing through RTF-texts and Font & Color parameters union
******************************* RTFtext **************************************
** RTF - fonts searching and correction
nCount=1
DO WHILE .T.
	ni=AT("\f",cText2,nCount)
	IF ni>0 && somethig was found - check in parameter
		nCount=nCount+1
		nBuf1=ni-1 && last char number before Control
		ni=ni+2 && LEN(control+1)
		cim=SUBSTR(cText2,ni,1)
		IF ISDIGIT(cim) && font number digit - font definition was found
			cParam=""
			*** Font number correction in text
			DO WHILE .T.
				cim=SUBSTR(cText2,ni,1)
				ni=ni+1
				IF ISDIGIT(cim)
					cParam=cParam+cim
				ELSE
					EXIT
				ENDIF
			ENDDO
			nBuf2=ni-1
			*** searching font definition "\f"+cParam+"\" in aFont array
			SET EXACT OFF
			nj=ASCAN(aFont2,"{\f"+cParam+"\")
			SET EXACT ON
			IF nj>0
				cBuf=aFont2[nj]
				** number cutting
				nj=AT("\",cBuf,2)
				cBuf=SUBSTR(cBuf,nj+1,LEN(cBuf)-nj)
				*** check in if exist such font in common aFont0 array
				nj=0
				IF ArrLen(@aFont0)>0
					nj=ASCAN(aFont0,cBuf)
				ENDIF
				** ok - this number exists
				IF nj>0
					nNum=nj-1
				ELSE
					=AADD(@aFont0,cBuf)
					nNum=ArrLen(@aFont0)-1
				ENDIF
				** number correction in text
				cText2=SUBSTR(cText2,1,nBuf1)+;
					"\f"+ALLTRIM(STR(nNum))+;
					SUBSTR(cText2,nBuf2,LEN(cText2)-nBuf2+1)
			ENDIF
		ELSE
			LOOP && it's not font
		ENDIF
	ELSE
		EXIT
	ENDIF
ENDDO

** RTF - Font Colors searching and correction
nCount=1
DO WHILE .T.
	ni=AT("\cf",cText2,nCount)
	IF ni>0 && somethig was found - check in parameter
		nCount=nCount+1
		nBuf1=ni-1 && last char number before Control
		ni=ni+3 && LEN(control+1)
		cim=SUBSTR(cText2,ni,1)
		IF ISDIGIT(cim) && color number digit - color definition was found
			cParam=""
			*** Color number correction in text
			DO WHILE .T.
				cim=SUBSTR(cText2,ni,1)
				ni=ni+1
				IF ISDIGIT(cim)
					cParam=cParam+cim
					nParam=VAL(cParam)+1
				ELSE
					EXIT
				ENDIF
			ENDDO
			nBuf2=ni-1
			*** Color definition - in aColor2 array
			IF nParam<=ArrLen(@aColor2)
				cBuf=aColor2[nParam]
				*** check in if exist such Color in common aColor0 array
				nj=0
				IF ArrLen(@aColor0)>0
					nj=ASCAN(aColor0,cBuf)
				ENDIF
				** such color is exist
				IF nj>0
					nNum=nj-1
				ELSE
					=AADD(@aColor0,cBuf)
					nNum=ArrLen(@aColor0)-1
				ENDIF
				cBuf="\cf"+ALLTRIM(STR(nNum))
				*** bad color number
			ELSE
				cBuf=""
			ENDIF
			** number correction in text
			cText2=SUBSTR(cText2,1,nBuf1)+cBuf+SUBSTR(cText2,nBuf2,LEN(cText2)-nBuf2+1)
		ELSE
			LOOP && it is not color
		ENDIF
	ELSE
		EXIT
	ENDIF
ENDDO

** RTF - Colors Back searching and correction
nCount=1
DO WHILE .T.
	ni=AT("\cb",cText2,nCount)
	IF ni>0 && somethig was found - check in parameter
		nCount=nCount+1
		nBuf1=ni-1 && last char number before Control
		ni=ni+3 && LEN(control+1)
		cim=SUBSTR(cText2,ni,1)
		IF ISDIGIT(cim) && color number digit - color definition was found
			cParam=""
			*** Color number correction in text
			DO WHILE .T.
				cim=SUBSTR(cText2,ni,1)
				ni=ni+1
				IF ISDIGIT(cim)
					cParam=cParam+cim
					nParam=VAL(cParam)+1
				ELSE
					EXIT
				ENDIF
			ENDDO
			nBuf2=ni-1
			*** Color definition - in aColor2 array
			IF nParam<=ArrLen(@aColor2)
				cBuf=aColor2[nParam]
				*** check in if exist such Color in common aColor0 array
				nj=0
				IF ArrLen(@aColor0)>0
					nj=ASCAN(aColor0,cBuf)
				ENDIF
				** such color is exist
				IF nj>0
					nNum=nj-1
				ELSE
					=AADD(@aColor0,cBuf)
					nNum=ArrLen(@aColor0)-1
				ENDIF
				cBuf="\cb"+ALLTRIM(STR(nNum))
				*** bad color number
			ELSE
				cBuf=""
			ENDIF
			** number correction in text
			cText2=SUBSTR(cText2,1,nBuf1)+cBuf+SUBSTR(cText2,nBuf2,LEN(cText2)-nBuf2+1)
		ELSE
			LOOP && it is not color
		ENDIF
	ELSE
		EXIT
	ENDIF
ENDDO

** RTF - HightLight Colors searching and correction
nCount=1
DO WHILE .T.
	ni=AT("\highlight",cText2,nCount)
	IF ni>0 && somethig was found - check in parameter
		nCount=nCount+1
		nBuf1=ni-1 && last char number before Control
		ni=ni+10 && LEN(control+1)
		cim=SUBSTR(cText2,ni,1)
		IF ISDIGIT(cim) && color number digit - color definition was found
			cParam=""
			*** Color number correction in text
			DO WHILE .T.
				cim=SUBSTR(cText2,ni,1)
				ni=ni+1
				IF ISDIGIT(cim)
					cParam=cParam+cim
					nParam=VAL(cParam)+1
				ELSE
					EXIT
				ENDIF
			ENDDO
			nBuf2=ni-1
			*** Color definition - in aColor2 array
			IF nParam<=ArrLen(@aColor2)
				cBuf=aColor2[nParam]
				*** check in if exist such Color in common aColor0 array
				nj=0
				IF ArrLen(@aColor0)>0
					nj=ASCAN(aColor0,cBuf)
				ENDIF
				** such color is exist
				IF nj>0
					nNum=nj-1
				ELSE
					=AADD(@aColor0,cBuf)
					nNum=ArrLen(@aColor0)-1
				ENDIF
				cBuf="\highlight"+ALLTRIM(STR(nNum))
				*** bad color number
			ELSE
				cBuf=""
			ENDIF
			** number correction in text
			cText2=SUBSTR(cText2,1,nBuf1)+cBuf+SUBSTR(cText2,nBuf2,LEN(cText2)-nBuf2+1)
		ELSE
			LOOP && it is not color
		ENDIF
	ELSE
		EXIT
	ENDIF
ENDDO

*** deffN - defaul font definition correction in text
IF !EMPTY(nDeffH+nDeffT) .AND. ArrLen(@aFont2)>0
	*** search font definition "\f"+nDEffT+"\" for header
	nDeffH=aFont0[VAL(nDeffH)+1] && ôîíò â çàãîëîâêå
	*** search font definition "\f"+nDEffT+"\" for text
	SET EXACT OFF
	nj=ASCAN(aFont2,"{\f"+nDeffT+"\")
	SET EXACT ON
	IF nj>0
		nDeffT=aFont2[nj] && font in text
	ENDIF
	*** will add this font in header and insert it's number in text
	IF nj>0 .AND. !nDeffT==nDeffH && fonts are different !
		cBuf=nDeffT
		** number cutting
		nj=AT("\",cBuf,2)
		cBuf=SUBSTR(cBuf,nj+1,LEN(cBuf)-nj)
		*** check in if exist such Font in common aFont0 array
		nj=0
		IF ArrLen(@aFont0)>0
			nj=ASCAN(aFont0,cBuf)
		ENDIF
		** Such is exist
		IF nj>0
			nNum=nj-1
		ELSE
			=AADD(@aFont0,cBuf)
			nNum=ArrLen(@aFont0)-1
		ENDIF
		cDeff="\plain\f"+ALLTRIM(STR(nNum)) && +" "
		*** will insert \fN in cText2 after \plain
		cText2=STRTRAN(cText2,"\plain",cDeff)
	ENDIF
ENDIF


************* Common header cHead0 linking ************

*** Fonts definition
cHead=cHPart1+"{\fonttbl"
FOR ni=1 TO ArrLen(@aFont0)
	cBuf=aFont0[ni]
	*  IF nCodePage==1251 && Russian
	*   ***************** Fonts cyrillisation ***********
	*   ** replacement \fcharset shift with russian 204
	*   cBuf=AllStuff(cBuf,"\fcharset","\fcharset204",.t.)
	*   cHead=cHead+"{\f"+ALLTRIM(STR(ni-1))+"\"+cBuf
	*  ENDIF
NEXT
cHead=cHead+"}"

*** Colors definition
cHead=cHead+"{\colortbl"
FOR ni=1 TO ArrLen(@aColor0)
	cHead=cHead+aColor0[ni]
NEXT
cHead=cHead+"}"+cHPart2
cHead=cHead+"{\info{\author Created by DBRAD32 Report Generator}}"

************* Common text cText2 linking ************
** viewkind1 - to enabling vertical text in Word
** viewzk2 - autoscale, otherwise - 100%
* cText2="\viewkind1\viewzk2"+cText2
cText2="\viewkind1"+cText2
** Styles pointers deleting StyleSheet - \sNN
cText2=AllStuff(cText2,"\s","",.T.)
** Set DocumentView mode in 1 (Page Layout View)
cText2=AllStuff(cText2,"\viewkind","\viewkind1",.T.)
** Page settings deleting
cText2=AllStuff(cText2,"\paperw","",.T.)
cText2=AllStuff(cText2,"\paperh","",.T.)
cText2=AllStuff(cText2,"\margl","",.T.)
cText2=AllStuff(cText2,"\margr","",.T.)
cText2=AllStuff(cText2,"\margt","",.T.)
cText2=AllStuff(cText2,"\margb","",.T.)
cText2=AllStuff(cText2,"\lndscpsxn","",.F.)
IF Landscape
	cText2=AllStuff(cText2,"\sectd\","\sectd\lndscpsxn\",.F.)
	cText2=AllStuff(cText2,"\sectd ","\sectd\lndscpsxn ",.F.)
ENDIF
*** Resulting char "}" cutting in RTF text
nj=RAT("}",cText2)
cText2=SUBSTR(cText2,1,nj-1)
cRTF=cText2
RETURN .T.


****************************************************************
** Searching and replacement substring [cContr] in text [cRtfText]
* lDigit==.t. - cContr with digital parameter
FUNCTION AllStuff(cText,cContr,cNew,lDigit)
LOCAL ni,nBuf1,nBuf2,cim,cOut1,nCount,cOut2
cOut1=""
cOut2=cText
IF EMPTY(cNew)
	cNew=""
ENDIF
** search \contr
DO WHILE .T.
	ni=AT(cContr,cOut2,1)
	IF ni>0 && smth was found - check by parameter
		nBuf1=ni-1 && last digit number before Control
		** search with digital parameter
		IF lDigit
			ni=ni+LEN(cContr)
			cim=SUBSTR(cOut2,ni,1)
			nBuf2=ni-1
			IF ISDIGIT(cim) && next char - digit ?
				*** Full number collecting
				DO WHILE ISDIGIT(cim)
					cim=SUBSTR(cOut2,ni,1)
					ni=ni+1
				ENDDO
				nBuf2=ni-1
				** Replace/delete in text
				cOut1=cOut1+SUBSTR(cOut2,1,nBuf1)+cNew
				cOut2=SUBSTR(cOut2,nBuf2)
			ELSE
				** replace in text
				cOut1=cOut1+SUBSTR(cOut2,1,nBuf2)
				cOut2=SUBSTR(cOut2,nBuf2+1)
			ENDIF
			** exuct search
		ELSE && !lDigit
			nBuf2=ni+LEN(cContr)
			** Replace/delete in text
			cOut1=cOut1+SUBSTR(cOut2,1,nBuf1)+cNew
			cOut2=SUBSTR(cOut2,nBuf2)
		ENDIF && lDigit
	ELSE
		EXIT
	ENDIF
ENDDO
RETURN cOut1+cOut2


*******************************************************************
*** Creates RTF-code for MS Word Table Line
** @aRow(7):
** aRow[1] - Cell value (character)
** aRow[2] - Cell Width (ñm)
** aRow[3] - Font Size (def=10)
** aRow[4] - Alignment: Center,Left,Right (def="c")
** aRow[5] - Bold (def=.f.)
** aRow[6] - Italic (def=.f.)
** aRow[7] - Vertical text (def=.f.)
*** [lHeader] - this flag means that Line is a Table Header and will (def=.f.)
*** [nMargin] - Left table margin in cm (def=0)
*** [nMinHeight] - Minimal Height for vertical text case ( aRow[7]==.t. )
*** [lDoubleLine] - Double (vs. single) separate line between header and table body
*** [lcUnVisible] - Hidden lines from mentioned as string "tblrhv" , .t. - âñå
FUNCTION RtfTab(aRow,lHeader,nMargin,nMinHeight,lDoubleLine,lcUnvisible)
LOCAL cOut,ni,nWide,cAlin,cFontSize,cMinh, cDop1,cDop2,nTol
IF .F.
	DECLARE aRow(1,1)
ENDIF
IF !ArrLen(@aRow,.T.) == 7
	RETURN "\par RtfTab()- Wrong cells array length !  \par"
ENDIF
IF TYPE("lcUnVisible")=="C"
	lcUnvisible=LOWER(lcUnvisible)
ELSE
	lcUnvisible=IIF(EMPTY(lcUnvisible),"","tblrhv")
ENDIF
IF TYPE("nMargin")=="N"
	nMargin=nMargin*567
ELSE
	nMargin=0
ENDIF
nWide=0
cMinh=""
IF TYPE("nMinHeight")=="N"
	cMinh="\trrh"+ALLTRIM(STR(nMinHeight*567))
ENDIF
** ôîðìèðîâàíèå ñêåëåòà òàáëèöû
cOut=CRLF+"\plain\lang1049\trowd\trgaph50"+cMinh+"\trleft"+ALLTRIM(STR(nMargin))+IIF(lHeader,"\trhdr","")+"\trkeep\deflang1049"+CRLF+;
	IIF("t"$lcUnvisible,"","\trbrdrt\brdrs\brdrw10")+;
	IIF("l"$lcUnvisible,"","\trbrdrl\brdrs\brdrw10")+;
	IIF("b"$lcUnvisible,"","\trbrdrb\brdrs\brdrw10")+;
	IIF("r"$lcUnvisible,"","\trbrdrr\brdrs\brdrw10")+;
	IIF("h"$lcUnvisible,"","\trbrdrh\brdrs\brdrw10")+;
	IIF("v"$lcUnvisible,"","\trbrdrv\brdrs\brdrw10")+;
	"\clvertalt"+CRLF

FOR ni=1 TO ArrLen(@aRow)
	IF aRow[ni,2]==0 .OR. aRow[ni,2] < 0.0001
		LOOP
	ENDIF
	** Wideth count
	nWide=nWide+aRow[ni,2]*567
	cOut=cOut+;
		IIF("t"$lcUnvisible,"","\clbrdrt\brdrs\brdrw10")+;
		IIF("l"$lcUnvisible,"","\clbrdrl\brdrs\brdrw10")+;
		IIF("b"$lcUnvisible,"","\clbrdrb\brdrs\brdrw10")+;
		IIF("r"$lcUnvisible,"","\clbrdrr\brdrs\brdrw10")+;
		IIF(aRow[ni,7],"\cltxbtlr","\cltxlrtb")+;
		"\cellx"+ALLTRIM(STR(nWide+nMargin))+"\clvertalt"+CRLF
NEXT
cOut=cOut+"\cgrid"
IF lDoubleLine
	cOut=cOut+"\trbrdrh\brdrdb"
ENDIF
cOut=cOut+"\pard\intbl{"
** Cells filling in
FOR ni=1 TO ArrLen(@aRow)
	IF aRow[ni,2]==0 .OR. aRow[ni,2] < 0.0001
		LOOP
	ENDIF
	cDop1=IIF(aRow[ni,7],"{\pard\li50\ri50\intbl","")
	cDop2=IIF(aRow[ni,7],"}","")
	cAlin="\q"+IIF(EMPTY(aRow[ni,4]),"r",LOWER(aRow[ni,4]))
	cFontSize="\fs"+IIF(EMPTY(aRow[ni,3]),"20",ALLTRIM(STR(2*aRow[ni,3],4,0)))
	cOut=cOut+cDop1+"\plain"+cFontSize+cAlin+IIF(!EMPTY(aRow[ni,5]),"\b","")+IIF(!EMPTY(aRow[ni,6]),"\i","")+" "+aRow[ni,1]+"\cell "+cDop2+CRLF
NEXT
cOut=cOut+"}{\row }\pard"
IF lDoubleLine
	cOut=cOut+"\trbrdrh\brdrs "
ENDIF
cOut=cOut+CRLF
RETURN cOut


**************************************************************************
* Creates RTF-table skeleton
* @aWide[nWide] , aWide[1]=Len cm, aWide[2]=lVert
* @noWide - Table Width
* code RTF is returned from this function
*** [cUnVisible] - Hidden lines from mentioned string as - "tblrhv"
FUNCTION RTFCreTab(aWide,nSize,noWide,nMargin,lHead,nMinHeight,cUnvisible)
LOCAL ni,cBuf,nWide,nBuf,nMargin,cMinh
IF .F.
	DECLARE aWide(ArrLen(@aWide))
ENDIF
IF TYPE("cUnVisible")=="C"
	cUnvisible=LOWER(cUnvisible)
ELSE
	cUnvisible=IIF(EMPTY(cUnvisible),"","tblrhv")
ENDIF
IF EMPTY(nSize)
	nSize=12
ENDIF
IF TYPE("nMargin")=="N"
	nMargin=nMargin*567
ELSE
	nMargin=0
ENDIF
cMinh=""
IF TYPE("nMinHeight")=="N"
	cMinh="\trrh"+ALLTRIM(STR(nMinHeight*567))
ENDIF

cBuf="\trowd\trgaph50"+cMinh+"\trleft"+ALLTRIM(STR(nMargin))+IIF(lHead,"\trhdr","")+"\deflang1049"+CRLF+;
	IIF("t"$cUnvisible,"","\trbrdrt\brdrs\brdrw10")+;
	IIF("b"$cUnvisible,"","\trbrdrb\brdrs\brdrw10")+;
	IIF("r"$cUnvisible,"","\trbrdrr\brdrs\brdrw10")+;
	IIF("l"$cUnvisible,"","\trbrdrl\brdrs\brdrw10")+;
	IIF("h"$cUnvisible,"","\trbrdrh\brdrs\brdrw10")+;
	IIF("v"$cUnvisible,"","\trbrdrv\brdrs\brdrw10")+;
	"\clvertalt"+CRLF

nWide=0
noWide=0.0
FOR ni=1 TO ArrLen(@aWide)
	IF aWide[ni,1]==0 .OR. aWide[ni,1] < 0.0001
		LOOP
	ENDIF
	** Wide Count
	noWide=noWide+aWide[ni,1]
	nWide=nWide+aWide[ni,1]*567
	cBuf=cBuf+;
		IIF(!EMPTY(cMinh).AND.aWide[ni,2],"\cltxbtlr","\cltxlrtb")+;
		IIF("t"$cUnvisible,"","\clbrdrt\brdrs\brdrw10")+;
		IIF("b"$cUnvisible,"","\clbrdrb\brdrs\brdrw10")+;
		IIF("l"$cUnvisible,"","\clbrdrl\brdrs\brdrw10")+;
		IIF("r"$cUnvisible,"","\clbrdrr\brdrs\brdrw10")+;
		"\cellx"+ALLTRIM(STR(nWide+nMargin))+"\clvertalt"+CRLF
NEXT
cBuf=cBuf+"\cgrid\plain\lang1049\fs"+ALLTRIM(STR(nSize*2))+" "+CRLF
RETURN cBuf


****************************************************************
** To convert Wide in CHARS to wide in PITS (1cm = 567 pit)
FUNC TChar_Wide(cFont,nFont,nChars)
LOCAL nWide
IF nChars==0
	RETURN 0
ENDIF
** Wide count
nChars=IIF(nChars<1,1,nChars)
nWide=FONTMETRIC(6,cFont,nFont)*nChars*25+100  && [trgaph50+nWide+trgap50]
RETURN nWide

************************************
** To convert Wide in PITS to wide in CHARS
FUNC TWide_Char(cFont,nFont,nWide)
LOCAL nChars
IF nWide==0
	RETURN 0
ENDIF
** Wide count in chars
nChars=(nWide-100)/(FONTMETRIC(6,cFont,nFont)*25)
RETURN nChars


***********************************************************************
* Adding new line to RTF-table and filling it with values - from aRow array
* @aRow[cValue,cAlingmentType(c/l/r),nWide,fsize,bold,italic,vert]
FUNCTION RtfFilRow(aRow,lHeader,lBold,lItalic,nStart,nStop,nSize)
LOCAL ni,cBuf,cAlin,cFont,lSluz,cDop1,cDop2
IF .F.
	DECLARE aRow(1,6)
ENDIF
cBuf=""
cFont=""
IF lHeader
	cBuf=cBuf+"\trbrdrh\brdrdb"
ENDIF
cBuf=cBuf+"\pard\intbl{"
IF !TYPE("nStart")=="N"
	nStart=1
ENDIF
IF !TYPE("nStop")=="N"
	nStop=ArrLen(@aRow)
ENDIF
FOR ni=nStart TO nStop
	** skip zero-width
	IF TYPE("aRow[ni,3]")=="N"
		IF aRow[ni,3]==0
			LOOP
		ENDIF
	ENDIF
	IF !TYPE("aRow[ni,5]")=="L"
		aRow[ni,5]=.F.
	ENDIF
	IF !TYPE("aRow[ni,6]")=="L"
		aRow[ni,6]=.F.
	ENDIF

	IF TYPE("aRow[ni,4]")=="N"
		cFont="\fs"+ALLTRIM(STR(2*aRow[ni,4],2,0))
	ELSE
		IF TYPE("nSize")=="N"
			cFont="\fs"+ALLTRIM(STR(2*nSize,2,0))
			lSluz=.T.
		ELSE
			lSluz=.F.
		ENDIF
	ENDIF

	cDop1=IIF(aRow[ni,7],"{\pard\li50\ri50\intbl","")
	cDop2=IIF(aRow[ni,7],"}","")
	cAlin="\q"+IIF(EMPTY(aRow[ni,2]),"r",LOWER(aRow[ni,2]))
	cBuf=cBuf+cDop1+"\plain"+cFont+cAlin+IIF((lSluz.AND.lBold).OR.aRow[ni,5],"\b","")+IIF(!lSluz.AND.(lItalic.OR.aRow[ni,6]),"\i","")+" "+aRow[ni,1]+"\cell "+cDop2+CRLF

NEXT
cBuf=cBuf+"}{\row }\pard"
IF lHeader
	cBuf=cBuf+"\trbrdrh\brdrs "
ENDIF
cBuf=cBuf+CRLF
RETURN cBuf


*************************************
*** To count number of bytes in RTF-text Header
FUNCTION RTFHeadCount(cRTF)
LOCAL nCount,nj
nj=AT("{\info",cRTF)
IF nj==0
	nj=AT("{\revtbl",cRTF)
ENDIF
IF nj==0
	nj=AT("{\listtables",cRTF)
ENDIF
IF nj==0
	nj=AT("{\stylesheet",cRTF)
ENDIF
IF nj==0
	nj=AT("{\colortbl",cRTF)
ENDIF
IF nj==0
	nj=AT("{\filetbl",cRTF)
ENDIF
IF nj==0
	nj=AT("{\fonttbl",cRTF)
ENDIF
nCount=0
FOR ni=nj TO LEN(cRTF)
	cim=SUBSTR(cRTF,ni,1)
	nCount=IIF(cim=="{",nCount+1,IIF(cim=="}",nCount-1,nCount))
	IF nCount==0
		EXIT
	ENDIF
NEXT
RETURN ni



*********************************************************************************
*** To get Array Length (0 - if not artray)
*** l2 - to get length of second dimension
*** call aName_ as a referenced parameter ! (like ArrLen(@aArray) )
*** (c) Dm.Bayanov , 1998
FUNCTION ArrLen(aName_,l2)
LOCAL nLen
IF .F.
	DECLARE aName_(1)
ENDIF
nLen=0
IF !TYPE("aName_[1]")=="U" && Boo !
	IF l2
		nLen=ALEN(aName_,2)
	ELSE
		nLen=ALEN(aName_,1)
	ENDIF
	nLen=IIF(nLen==1.AND.ISNULL(aName_[1]),0,nLen)
ENDIF
RETURN nLen

***********************************************************************************
** Delete ni element from LOCAL array, n2 - second dimension length (should be pointed)
** @aName !
FUNCTION ArrDel(aName,ni,n2)
IF ArrLen(@aName)==1 .AND. ni==1
	aName[1]=NULL
ELSE
	IF ni<=ArrLen(@aName)
		ADEL(aName,ni)
		IF TYPE("n2")=="N"
			DECLARE aName(ArrLen(@aName)-1,n2)
		ELSE
			DECLARE aName(ArrLen(@aName)-1)
		ENDIF
	ENDIF
ENDIF
RETURN


**********************************************************************************
*** To Add element to the end of array @aNameAr
*** xVal - added value, nLen2 - second dimension length
FUNCTION AADD(aNameAr,xVal,nLen2)
LOCAL nLen,nBuf
nLen=ArrLen(@aNameAr)
nLen2=IIF(EMPTY(nLen2),0,nLen2)
IF nLen==0
	*** 2-nd dimension length
	IF nLen2>0
		DECLARE aNameAr(1,nLen2)
		aNameAr[1,1]=xVal
	ELSE
		DECLARE aNameAr(1)
		aNameAr[1]=xVal
	ENDIF
ELSE
	nBuf=ArrLen(@aNameAr,.T.)
	nLen2=IIF(nBuf>0,nBuf,nLen2)
	*** 2-nd dimension length
	IF nLen2>0
		DECLARE aNameAr(nLen+1,nLen2)
		aNameAr[nLen+1,1]=xVal
	ELSE
		DECLARE aNameAr(nLen+1)
		aNameAr[nLen+1]=xVal
	ENDIF
ENDIF
RETURN .T.
Previous
Next
Reply
Map
View

Click here to load this message in the networking platform