>*** 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] && ôîíò â çàãîëîâêå >>
>IF .F. > DECLARE aFont0(1),aFont2(1),aColor0(1),aColor2(1) >ENDIF >>when i change IF .F. to IF .T., another error was occured in below line. error message is Operator/operand type mismatch.
> *** will add this font in header and insert it's number in text > IF nj>0 .AND. !nDeffT==nDeffH && fonts are different ! >>
>>>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. >>> >>>