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.