>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. > >