Componentes.Terceros.FastRe.../official/4.7.71/Source/ExportPack/frxExportRTF.pas
2009-02-27 12:41:18 +00:00

1210 lines
40 KiB
ObjectPascal

{******************************************}
{ }
{ FastReport v4.0 }
{ RTF export filter }
{ }
{ Copyright (c) 1998-2008 }
{ by Alexander Fediachov, }
{ Fast Reports Inc. }
{ }
{******************************************}
unit frxExportRTF;
interface
{$I frx.inc}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, extctrls, ComObj, Printers, frxClass, JPEG, ShellAPI, frxExportMatrix
{$IFDEF Delphi6}, Variants {$ENDIF}, frxProgress, ComCtrls, frxGraphicUtils;
type
TfrxHeaderFooterMode = (hfText, hfPrint, hfNone);
TfrxRTFExportDialog = class(TForm)
OkB: TButton;
CancelB: TButton;
GroupPageRange: TGroupBox;
DescrL: TLabel;
AllRB: TRadioButton;
CurPageRB: TRadioButton;
PageNumbersRB: TRadioButton;
PageNumbersE: TEdit;
GroupQuality: TGroupBox;
WCB: TCheckBox;
PageBreaksCB: TCheckBox;
PicturesCB: TCheckBox;
OpenCB: TCheckBox;
SaveDialog1: TSaveDialog;
ContinuousCB: TCheckBox;
HeadFootL: TLabel;
PColontitulCB: TComboBox;
procedure FormCreate(Sender: TObject);
procedure PageNumbersEChange(Sender: TObject);
procedure PageNumbersEKeyPress(Sender: TObject; var Key: Char);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
end;
TfrxRTFExport = class(TfrxCustomExportFilter)
private
FColorTable: TStringList;
FCurrentPage: Integer;
FDataList: TList;
FExportPageBreaks: Boolean;
FExportPictures: Boolean;
FFirstPage: Boolean;
FFontTable: TStringList;
FCharsetTable: TStringList;
FMatrix: TfrxIEMatrix;
FOpenAfterExport: Boolean;
FProgress: TfrxProgress;
FWysiwyg: Boolean;
FCreator: String;
FHeaderFooterMode: TfrxHeaderFooterMode;
FAutoSize: Boolean;
FExportEMF: Boolean;
function TruncReturns(const Str: WideString): WideString;
function GetRTFBorders(const Style: TfrxIEMStyle): string;
function GetRTFColor(const c: DWORD): string;
function GetRTFFontStyle(const f: TFontStyles): String;
function GetRTFFontColor(const f: String): String;
function GetRTFFontName(const f: String; const charset: Integer): String;
function GetRTFHAlignment(const HAlign: TfrxHAlign) : String;
function GetRTFVAlignment(const VAlign: TfrxVAlign) : String;
function StrToRTFSlash(const Value: WideString): WideString;
function StrToRTFUnicodeEx(const Value: WideString): String;
function StrToRTFUnicode(const Value: WideString): String;
procedure ExportPage(const Stream: TStream);
procedure PrepareExport;
public
constructor Create(AOwner: TComponent); override;
class function GetDescription: String; override;
function ShowModal: TModalResult; override;
function Start: boolean; override;
procedure Finish; override;
procedure FinishPage(Page: TfrxReportPage; Index: Integer); override;
procedure StartPage(Page: TfrxReportPage; Index: Integer); override;
procedure ExportObject(Obj: TfrxComponent); override;
published
property ExportEMF: Boolean read FExportEMF write FExportEMF;
property ExportPageBreaks: Boolean read FExportPageBreaks write FExportPageBreaks default True;
property ExportPictures: Boolean read FExportPictures write FExportPictures default True;
property OpenAfterExport: Boolean read FOpenAfterExport
write FOpenAfterExport default False;
property Wysiwyg: Boolean read FWysiwyg write FWysiwyg;
property Creator: String read FCreator write FCreator;
property SuppressPageHeadersFooters;
property HeaderFooterMode: TfrxHeaderFooterMode read FHeaderFooterMode write FHeaderFooterMode;
property AutoSize: Boolean read FAutoSize write FAutoSize;
property OverwritePrompt;
end;
implementation
uses frxUtils, frxFileUtils, frxRes, frxrcExports;
{$R *.dfm}
const
Xdivider = 15.05;
Ydivider = 15;
Ydivider_last = 14.5;
PageDivider = 15.02;
MargDivider = 56.48;
FONT_DIVIDER = 15;
IMAGE_DIVIDER = 25.3;
{ TfrxRTFExport }
constructor TfrxRTFExport.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ShowDialog := True;
FExportPageBreaks := True;
FExportPictures := True;
FWysiwyg := True;
FHeaderFooterMode := hfText;
FAutoSize := False;
FCreator := 'FastReport';
FilterDesc := frxGet(8504);
DefaultExt := frxGet(8505);
FExportEMF := True;
end;
class function TfrxRTFExport.GetDescription: String;
begin
Result := frxResources.Get('RTFexport');
end;
function TfrxRTFExport.TruncReturns(const Str: WideString): WideString;
var
l: Integer;
begin
l := Length(Str);
if (l > 1) and (Str[l - 1] = #13) and (Str[l] = #10) then
Result := Copy(Str, 1, l - 2)
else
Result := Str;
end;
function TfrxRTFExport.StrToRTFSlash(const Value: WideString): WideString;
var
i: integer;
begin
result := '';
for i := 1 to Length(Value) do
begin
if Value[i] = '\' then
result := result + '\\'
else if Value[i] = '{' then
result := result + '\{'
else if Value[i] = '}' then
result := result + '\}'
else if (Value[i] = #13) and (i < (Length(Value) - 1)) and (Value[i + 1] = #10) then
result := result + '\line'#13
else
result := result + Value[i];
end;
end;
function TfrxRTFExport.StrToRTFUnicodeEx(const Value: WideString): String;
var
s: WideString;
begin
s := StrToRTFSlash(Value);
Result := StrToRTFUnicode(s);
end;
function TfrxRTFExport.StrToRTFUnicode(const Value: WideString): String;
var
i: integer;
pwc: ^Word;
begin
result := '';
for i := 1 to Length(Value) do
begin
pwc := @Value[i];
if pwc^ > 127 then
result := result + '\u' + IntToStr(pwc^) + '\''3f'
else
result := result + Chr(pwc^);
end;
end;
function TfrxRTFExport.GetRTFBorders(const Style: TfrxIEMStyle): string;
var
brdrw: String;
brdrc: String;
brdrs: String;
begin
{$IFNDEF FR_DEBUG}
Result := '';
brdrw := '\brdrs\brdrw' + IntToStr(Round(Style.FrameWidth * 20));
brdrc := '\brdrcf' + GetRTFFontColor(GetRTFColor(Style.FrameColor));
if Style.FrameStyle = fsDouble then
brdrs := '\brdrdb'
else if Style.FrameStyle <> fsSolid then
brdrs := '\brdrdashsm'
else brdrs := '';
if ftTop in Style.FrameTyp then
Result := Result + '\clbrdrt' + brdrw + brdrc + brdrs;
if ftLeft in Style.FrameTyp then
Result := Result + '\clbrdrl' + brdrw + brdrc + brdrs;
if ftBottom in Style.FrameTyp then
Result := Result + '\clbrdrb' + brdrw + brdrc + brdrs;
if ftRight in Style.FrameTyp then
Result := Result + '\clbrdrr' + brdrw + brdrc + brdrs;
{$ELSE}
Result := '';
brdrw := '\brdrs\brdrw' + IntToStr(Round(Style.FrameWidth * 20));
brdrc := '\brdrcf' + GetRTFFontColor(GetRTFColor(Style.FrameColor));
brdrs := '';
Result := Result + '\clbrdrt' + brdrw + brdrc + brdrs;
Result := Result + '\clbrdrl' + brdrw + brdrc + brdrs;
Result := Result + '\clbrdrb' + brdrw + brdrc + brdrs;
Result := Result + '\clbrdrr' + brdrw + brdrc + brdrs;
{$ENDIF}
end;
function TfrxRTFExport.GetRTFColor(const c: DWORD): string;
var
cn: DWORD;
begin
cn := ColorToRGB(c);
Result := '\red' + IntToStr(GetRValue(cn)) +
'\green' + IntToStr(GetGValue(cn)) +
'\blue' + IntToStr(GetBValue(cn)) + ';'
end;
function TfrxRTFExport.GetRTFFontStyle(const f: TFontStyles): String;
begin
Result := '';
if fsItalic in f then Result := '\i';
if fsBold in f then Result := Result + '\b';
if fsUnderline in f then Result := Result + '\ul';
end;
function TfrxRTFExport.GetRTFFontColor(const f: String): String;
var
i: Integer;
begin
i := FColorTable.IndexOf(f);
if i <> -1 then
Result := IntToStr(i + 1)
else
begin
FColorTable.Add(f);
Result := IntToStr(FColorTable.Count);
end;
end;
function TfrxRTFExport.GetRTFFontName(const f: String; const Charset: Integer): String;
var
i: Integer;
begin
i := FFontTable.IndexOf(f);
if i <> -1 then
Result := IntToStr(i)
else
begin
FFontTable.Add(f);
FCharsetTable.Add(IntToStr(charset));
Result := IntToStr(FFontTable.Count - 1);
end;
end;
function TfrxRTFExport.GetRTFHAlignment(const HAlign: TfrxHAlign) : String;
begin
if (HAlign = haLeft) then Result := '\ql'
else if (HAlign = haRight) then Result := '\qr'
else if (HAlign = haCenter) then Result := '\qc'
else if (HAlign = haBlock) then Result := '\qj'
else Result := '\ql';
end;
function TfrxRTFExport.GetRTFVAlignment(const VAlign: TfrxVAlign) : String;
begin
if (VAlign = vaTop) then Result := '\clvertalt'
else if (VAlign = vaCenter) then Result := '\clvertalc'
else if (VAlign = vaBottom) then Result := '\clvertalb'
else Result := '\clvertalt';
end;
procedure TfrxRTFExport.PrepareExport;
var
i, j, x, y, n, n1, fx: Integer;
s, s0, s1, s2: String;
Obj: TfrxIEMObject;
RepPos: TStringList;
function PosEx(const SubStr, S: string; Offset: Cardinal = 1): Integer;
var
I,X: Integer;
Len, LenSubStr: Integer;
begin
if Offset = 1 then
Result := Pos(SubStr, S)
else
begin
I := Offset;
LenSubStr := Length(SubStr);
Len := Length(S) - LenSubStr + 1;
while I <= Len do
begin
if S[I] = SubStr[1] then
begin
X := 1;
while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do
Inc(X);
if (X = LenSubStr) then
begin
Result := I;
exit;
end;
end;
Inc(I);
end;
Result := 0;
end;
end;
function TagClean(const Str: String; const BegCut: String; const EndCut: String): String;
var
i, j, k: Integer;
begin
Result := Str;
i := 1;
k := Length(BegCut);
while i > 0 do
begin
i := Pos(BegCut, Result);
if i > 0 then
begin
j := PosEx(EndCut, Result, i + k);
Delete(Result, i, j - i);
end;
end;
end;
function TagClean2(const Str: String; const BegCut: String; const EndCut1: String; const EndCut2: String): String;
var
i, j1, j2, k: Integer;
begin
Result := Str;
i := 1;
k := Length(BegCut);
while i > 0 do
begin
i := Pos(BegCut, Result);
if i > 0 then
begin
j1 := PosEx(EndCut1, Result, i + k);
j2 := PosEx(EndCut2, Result, i + k);
if ((j1 < j2) or (j2 = 0)) and (j1 <> 0) then
Delete(Result, i, j1 - i)
else
if (j2 <> 0) then
Delete(Result, i, j2 - i)
end;
end;
end;
begin
for y := 0 to FMatrix.Height - 1 do
for x := 0 to FMatrix.Width - 1 do
begin
i := FMatrix.GetCell(x, y);
if (i <> -1) then
begin
Obj := FMatrix.GetObjectById(i);
if Obj.Counter <> -1 then
begin
Obj.Counter := -1;
GetRTFFontColor(GetRTFColor(Obj.Style.Color));
GetRTFFontColor(GetRTFColor(Obj.Style.FrameColor));
//// RICH TEXT PREPARE START
if Obj.IsRichText then
begin
RepPos := TStringList.Create;
try
s := Obj.Memo.Text;
fx := Pos('{\fonttbl', s);
Delete(s, 1, fx + 8);
i := 1;
RepPos.Clear;
while (i < Length(s)) and (s[i] <> '}') do
begin
while (i < Length(s)) and (s[i] <> '{') and (s[i] <> '}') do
Inc(i);
j := i;
while (j < Length(s)) and (s[j] <> '}') do
Inc(j);
Inc(j);
s1 := Copy(s, i , j - i - 2);
i := j;
j := Pos(' ', s1);
s2 := Copy(s1, j + 1, Length(s1) - j + 1);
s0 := '\f' + GetRTFFontName(s2, 1);
j := Pos('\f', s1);
n := j + 1;
while (n < Length(s1)) and (s1[n] <> '\') and (s1[n] <> ' ') do
Inc(n);
s2 := Copy(s1, j, n - j);
j := Pos('}}', s);
s1 := Copy(s, j + 2, Length(s) - j - 1);
j := j + 2;
n := 1;
while n > 0 do
begin
n := Pos(s2, s1);
if n > 0 then
begin
if RepPos.IndexOf(IntToStr(n + j - 1)) = -1 then
begin
RepPos.Add(IntToStr(n + j - 1));
Delete(s, n + j - 1, Length(s2));
Insert(s0, s, n + j - 1);
end;
j := j + n + Length(s2) - 1;
s1 := Copy(s, j, Length(s) - j + 1);
end;
end;
end;
fx := Pos('}}', s);
if fx > 0 then
Delete(s, 1, fx + 1);
fx := Pos('{\colortbl', s);
if fx > 0 then
begin
Delete(s, 1, fx + 11);
i := 1;
n1 := 1;
RepPos.Clear;
while (i < Length(s)) and (s[i] <> '}') do
begin
while (i < Length(s)) and (s[i] <> '\') do
Inc(i);
j := i;
while (j < Length(s)) and (s[j] <> ';') do
Inc(j);
Inc(j);
s1 := Copy(s, i , j - i);
i := j;
s0 := '\cf' + GetRTFFontColor(s1);
s2 := '\cf' + IntToStr(n1);
j := Pos(';}', s);
s1 := Copy(s, j + 2, Length(s) - j - 1);
j := j + 2;
n := 1;
while n > 0 do
begin
n := Pos(s2, s1);
if n > 0 then
begin
if RepPos.IndexOf(IntToStr(n + j - 1)) = -1 then
begin
RepPos.Add(IntToStr(n + j - 1));
Delete(s, n + j - 1, Length(s2));
Insert(s0, s, n + j - 1);
end;
j := j + n + Length(s2) - 1;
s1 := Copy(s, j, Length(s) - j + 1);
end;
end;
Inc(n1);
end;
fx := Pos(';}', s);
if fx > 0 then
Delete(s, 1, fx + 1);
end;
fx := Pos('{\stylesheet', s);
if fx > 0 then
begin
Delete(s, 1, fx + 12);
fx := Pos('}}', s);
if fx > 0 then
Delete(s, 1, fx + 1);
end;
s := StringReplace(s, '\pard', '', [rfReplaceAll]);
Delete(s, Length(s) - 3, 3);
s := TagClean(s, '\lang', '\');
s := TagClean(s, '\sa', '\');
s := TagClean(s, '\sb', '\');
s := TagClean(s, '\sb', '\');
s := TagClean2(s, '\cbpat', '\', '{');
s := TagClean2(s, '\cfpat', '\', '{');
Obj.Memo.Text := '{\par{' + s + '}\pard}';
finally
RepPos.Free;
end;
//// RICH TEXT PREPARE END
end else if Obj.IsText then
begin
GetRTFFontColor(GetRTFColor(Obj.Style.Font.Color));
GetRTFFontName(Obj.Style.Font.Name, Obj.Style.Charset);
end;
end;
end;
end;
end;
procedure TfrxRTFExport.ExportPage(const Stream: TStream);
var
i, j, x, y, fx, fy, dx, dy, n, n1, pbk: Integer;
YDiv: Extended;
dcol, drow, xoffs: Integer;
buff, s, s0, s1, s2: String;
st, st1: WideString;
CellsLine: AnsiString;
Obj: TfrxIEMObject;
Graphic: TGraphic;
Str, CellsStream: TStream;
bArr: array[0..1023] of Byte;
FMode: Integer; // 3 - header, 2 - footer, 1 - body, 0 - stop
FHTMLTags: TfrxHTMLTagsList;
Tag: TfrxHTMLTag;
TagFColor: TColor;
TagFStyleB, TagFStyleU, TagFStyleI: Integer;
procedure WriteExpLn(const str: string);
{$IFDEF Delphi12}
var
TemsStr: AnsiString;
{$ENDIF}
begin
{$IFDEF Delphi12}
TemsStr := AnsiString(str);
if Length(TemsStr) > 0 then
begin
Stream.Write(TemsStr[1], Length(TemsStr));
Stream.Write(AnsiString(#13#10), 2);
end;
{$ELSE}
if Length(str) > 0 then
begin
Stream.Write(str[1], Length(str));
Stream.Write(#13#10, 2);
end;
{$ENDIF}
end;
procedure SetPageProp(Page: Integer);
var
s: String;
begin
s := '\pgwsxn' + IntToStr(Round(FMatrix.GetPageWidth(Page) * PageDivider)) +
'\pghsxn' + IntToStr(Round(FMatrix.GetPageHeight(Page) * PageDivider)) +
'\marglsxn' + IntToStr(Round(FMatrix.GetPageLMargin(Page) * MargDivider)) +
'\margrsxn' + IntToStr(Round(FMatrix.GetPageRMargin(Page) * MargDivider)) +
'\margtsxn' + IntToStr(Round(FMatrix.GetPageTMargin(Page) * MargDivider)) +
'\margbsxn' + IntToStr(Round(FMatrix.GetPageBMargin(Page) * MargDivider));
WriteExpLn(s);
if FMatrix.GetPageOrientation(Page) = poLandscape then
WriteExpLn('\lndscpsxn');
end;
begin
PrepareExport;
WriteExpLn('{\rtf1\ansi');
s := '{\fonttbl';
for i := 0 to FFontTable.Count - 1 do
begin
s1 := '{\f' + IntToStr(i) + '\fcharset' + FCharsetTable[i] + ' ' + FFontTable[i] + '}';
if Length(s + s1) < 255 then
s := s + s1
else
begin
WriteExpLn(s);
s := s1;
end;
end;
s := s + '}';
WriteExpLn(s);
s := '{\colortbl;';
for i := 0 to FColorTable.Count - 1 do
begin
s1 := FColorTable[i];
if Length(s + s1) < 255 then
s := s + s1
else
begin
WriteExpLn(s);
s := s1;
end;
end;
s := s + '}';
WriteExpLn(s);
WriteExpLn('{\info{\title ' + StrToRTFUnicodeEx(Report.ReportOptions.Name) +
'}{\author ' + StrToRTFUnicodeEx(FCreator) +
'}{\creatim\yr' + FormatDateTime('yyyy', Now) +
'\mo' + FormatDateTime('mm', Now) + '\dy' + FormatDateTime('dd', Now) +
'\hr' + FormatDateTime('hh', Now) + '\min' + FormatDateTime('nn', Now) + '}}');
if ShowProgress then
FProgress.Execute(FMatrix.Height - 1, frxResources.Get('ProgressWait'), True, True);
pbk := 0;
SetPageProp(pbk);
if FHeaderFooterMode = hfPrint then
FMode := 3
else
FMode := 1;
///
YDiv := Ydivider;
while FMode > 0 do
begin
if FMode = 3 then
WriteExpLn('{\header ')
else if FMode = 2 then
WriteExpLn('{\footer ');
if FMatrix.PagesCount = 1 then
YDiv := Ydivider_last;
for y := 0 to FMatrix.Height - 2 do
begin
if ShowProgress then
begin
FProgress.Tick;
if FProgress.Terminated then
break;
end;
if FExportPageBreaks and (FMode = 1) then
if pbk < FMatrix.PagesCount then
if FMatrix.GetPageBreak(pbk) <= FMatrix.GetYPosById(y) then
begin
WriteExpLn('\pard\sect');
Inc(pbk);
if pbk < FMatrix.PagesCount then
SetPageProp(pbk);
if pbk = FMatrix.PagesCount - 1 then
YDiv := Ydivider_last;
continue;
end;
drow := Round((FMatrix.GetYPosById(y + 1) - FMatrix.GetYPosById(y)) * YDiv);
if FAutoSize then
buff := '\trrh'
else
buff := '\trrh-';
buff := buff + IntToStr(drow) + '\trgaph15';
CellsStream := TMemoryStream.Create;
try
xoffs := Round(FMatrix.GetXPosById(1));
for x := 1 to FMatrix.Width - 2 do
begin
i := FMatrix.GetCell(x, y);
if (i <> -1) then
begin
Obj := FMatrix.GetObjectById(i);
if (FMode = 3) and (not Obj.Header) then
Continue;
if (FMode = 2) and (not Obj.Footer) then
Continue;
if (FMode = 1) and (Obj.Header or Obj.Footer) and
((FHeaderFooterMode = hfPrint) or
(FHeaderFooterMode = hfNone)) then
Continue;
FMatrix.GetObjectPos(i, fx, fy, dx, dy);
if Obj.Counter = -1 then
begin
if dy > 1 then
buff := buff + '\clvmgf';
if (obj.Style.Color mod 16777216) <> clWhite then
buff := buff + '\clcbpat' + GetRTFFontColor(GetRTFColor(Obj.Style.Color));
buff := buff + GetRTFVAlignment(Obj.Style.VAlign) + GetRTFBorders(Obj.Style) + '\cltxlrtb';
dcol := Round((Obj.Left + Obj.Width - xoffs) * Xdivider);
buff := buff + '\cellx' + IntToStr(dcol);
if Obj.IsText then
begin
s := '\f' + GetRTFFontName(Obj.Style.Font.Name, Obj.Style.Charset);
if Length(Obj.Memo.Text) > 0 then
s := s + '\fs' + IntToStr(Obj.Style.Font.Size * 2)
else
begin
j := drow div FONT_DIVIDER;
if j > 20 then j := 20;
s := s + '\fs' + IntToStr(j);
end;
s := s + GetRTFFontStyle(Obj.Style.Font.Style);
s := s + '\cf' + GetRTFFontColor(GetRTFColor(Obj.Style.Font.Color));
if (Obj.IsRichText) then
s1 := Obj.Memo.Text
else
begin
// export HTML tags
if Obj.HTMLTags then
begin
FHTMLTags := TfrxHTMLTagsList.Create;
try
FHTMLTags.SetDefaults(Obj.Style.Font.Color, Obj.Style.Font.Size, Obj.Style.Font.Style);
FHTMLTags.AllowTags := True;
st := StrToRTFSlash(TruncReturns(Obj.Memo.Text));
st1 := st;
s1 := '';
TagFColor := Obj.Style.Color;
TagFStyleB := 0;
TagFStyleU := 0;
TagFStyleI := 0;
FHTMLTags.ExpandHTMLTags(st);
for i := 0 to FHTMLTags.Count - 1 do
for j := 0 to FHTMLTags[i].Count - 1 do
begin
Tag := FHTMLTags[i].Items[j];
// bold tags
if (fsBold in Tag.Style) and (TagFStyleB = 0) then
begin
Inc(TagFStyleB);
s1 := s1 + '\b ';
end;
if (TagFStyleB > 0) and (not (fsBold in Tag.Style)) then
begin
Dec(TagFStyleB);
s1 := s1 + '\b0 ';
end;
// italic tags
if (fsItalic in Tag.Style) and (TagFStyleI = 0) then
begin
Inc(TagFStyleI);
s1 := s1 + '\i ';
end;
if (TagFStyleI > 0) and (not (fsItalic in Tag.Style)) then
begin
Dec(TagFStyleI);
s1 := s1 + '\i0 ';
end;
// underline tags
if (fsUnderline in Tag.Style) and (TagFStyleU = 0) then
begin
Inc(TagFStyleU);
s1 := s1 + '\ul ';
end;
if (TagFStyleU > 0) and (not (fsUnderline in Tag.Style)) then
begin
Dec(TagFStyleU);
s1 := s1 + '\ul0 ';
end;
// color tags
if (Tag.Color <> Obj.Style.Font.Color) and (Tag.Color <> TagFColor) then
begin
TagFColor := Tag.Color;
s1 := s1 + '\cf' + GetRTFFontColor(GetRTFColor(TagFColor)) + ' ';
end;
if (Tag.Color <> TagFColor) then
begin
TagFColor := Tag.Color;
s1 := s1 + '\cf' + GetRTFFontColor(GetRTFColor(TagFColor)) + ' ';
end;
s1 := s1 + StrToRTFUnicode(st1[Tag.Position]);
end;
s1 := s1 + '\plain';
finally
FHTMLTags.Free;
end;
end
else
s1 := StrToRTFUnicodeEx(TruncReturns(Obj.Memo.Text));
end;
if Trim(s1) <> '' then
begin
j := Round(Obj.Style.CharSpacing * FONT_DIVIDER);
if (Obj.Style.GapY + Obj.Style.LineSpacing - 1) > 0 then
n1 := Round((Obj.Style.GapY + Obj.Style.LineSpacing - 1) * YDiv)
else
n1 := 0;
s2 := '\sb' + IntToStr(n1) +
'\li' + IntToStr(Round((Obj.Style.GapX / 2) * Xdivider)) +
'\fi' + IntToStr(Round((Obj.Style.ParagraphGap) * Xdivider)) +
'\expnd' + IntToStr(j div 5) + '\expndtw' + IntToStr(j) +
'\sl-' + IntToStr(Round((-Obj.Style.Font.Height + Obj.Style.LineSpacing) * YDiv * 0.98)) +
'\slmult0';
if Obj.Style.WordBreak then
s2 := s2 + '\hyphauto1\hyphcaps1';
end else
s2 := '';
CellsLine := AnsiString(GetRTFHAlignment(Obj.Style.HAlign) +
'{' + s + s2 + ' ' + s1 + '\cell}');
s := '\par'#13#10'\cell';
while Pos(AnsiString(s), CellsLine) > 0 do
CellsLine := AnsiString(StringReplace(String(CellsLine), s, '\cell', []));
CellsStream.Write(CellsLine[1], Length(CellsLine));
end
else if FExportPictures then
begin
if ExportEMF then
begin
Str := TMemoryStream.Create;
try
// begin export EMF
Obj.Metafile.SaveToStream(Str);
Str.Position := 0;
dx := Round(Obj.Metafile.Width);
dy := Round(Obj.Metafile.Height);
CellsLine := '{\sb0\li0\sl0\slmult0 {\pict\picw' +
AnsiString(FloatToStr(dx * IMAGE_DIVIDER)) + '\pich' + AnsiString(FloatToStr(dy * IMAGE_DIVIDER)) + '\picscalex98\picscaley98\piccropl0\piccropr0\piccropt0\piccropb0\emfblip'#13#10;
CellsStream.Write(CellsLine[1], Length(CellsLine));
n1 := 0; s := '';
repeat
n := Str.Read(bArr[0], 1024);
for j := 0 to n - 1 do
begin
s := s + IntToHex(bArr[j], 2);
Inc(n1);
if n1 > 63 then
begin
n1 := 0;
CellsLine := AnsiString(s + #13#10);
CellsStream.Write(CellsLine[1], Length(CellsLine));
s := '';
end;
end;
until n < 1024;
if n1 <> 0 then
begin
CellsLine := AnsiString(s + #13#10);
CellsStream.Write(CellsLine[1], Length(CellsLine));
end;
CellsLine := '}\cell}' + #13#10;
CellsStream.Write(CellsLine[1], Length(CellsLine));
// end export EMF
finally
Str.Free;
end;
end
else
begin
// begin export Bitmap
Graphic := Obj.Image;
if not ((Graphic = nil) or Graphic.Empty) then
begin
Str := TMemoryStream.Create;
try
dx := Round(Obj.Width);
dy := Round(Obj.Height);
fx := Graphic.Width;
fy := Graphic.Height;
Graphic.SaveToStream(Str);
Str.Position := 0;
CellsLine := '{\sb0\li0\sl0\slmult0 {\pict\wmetafile8\picw' + AnsiString(FloatToStr(Round(dx * IMAGE_DIVIDER))) +
'\pich' + AnsiString(FloatToStr(Round(dy * IMAGE_DIVIDER))) + '\picbmp\picbpp4' + #13#10;
CellsStream.Write(CellsLine[1], Length(CellsLine));
Str.Read(n, 2);
Str.Read(n, 4);
n := n div 2 + 7;
s0 := IntToHex(n + $24, 8);
s := '010009000003' + Copy(s0, 7, 2) + Copy(s0, 5, 2) +
Copy(s0, 3, 2) + Copy(s0, 1, 2) + '0000';
s0 := IntToHex(n, 8);
s1 := Copy(s0, 7, 2) + Copy(s0, 5, 2) + Copy(s0, 3, 2) + Copy(s0, 1, 2);
s := s + s1 + '0000050000000b0200000000050000000c02';
s0 := IntToHex(fy, 4);
s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
s0 := IntToHex(fx, 4);
s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) +
'05000000090200000000050000000102ffffff000400000007010300' + s1 +
'430f2000cc000000';
s0 := IntToHex(fy, 4);
s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
s0 := IntToHex(fx, 4);
s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) + '00000000';
s0 := IntToHex(fy, 4);
s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2);
s0 := IntToHex(fx, 4);
s := s + Copy(s0, 3, 2) + Copy(s0, 1, 2) + '00000000';
CellsLine := AnsiString(s + #13#10);
CellsStream.Write(CellsLine[1], Length(CellsLine));
Str.Read(bArr[0], 8);
n1 := 0; s := '';
repeat
n := Str.Read(bArr[0], 1024);
for j := 0 to n - 1 do
begin
s := s + IntToHex(bArr[j], 2);
Inc(n1);
if n1 > 63 then
begin
n1 := 0;
CellsLine := AnsiString(s + #13#10);
CellsStream.Write(CellsLine[1], Length(CellsLine));
s := '';
end;
end;
until n < 1024;
finally
Str.Free;
end;
if n1 <> 0 then
begin
CellsLine := AnsiString(s + #13#10);
CellsStream.Write(CellsLine[1], Length(CellsLine));
end;
s := '030000000000}';
CellsLine := AnsiString(s + '\cell}' + #13#10);
CellsStream.Write(CellsLine[1], Length(CellsLine));
end;
// end export Bitmap
end;
end;
Obj.Counter := y + 1;
end
else
begin
if (dy > 1) and (Obj.Counter <> (y + 1)) then
begin
buff := buff + '\clvmrg';
buff := buff + GetRTFBorders(Obj.Style) + '\cltxlrtb';
dcol := Round((Obj.Left + Obj.Width - xoffs) * Xdivider);
buff := buff + '\cellx' + IntToStr(dcol);
j := drow div FONT_DIVIDER;
if j > 20 then
j := 20;
CellsLine := '{\fs' + AnsiString(IntToStr(j)) + '\cell}';
CellsStream.Write(CellsLine[1], Length(CellsLine));
Obj.Counter := y + 1;
end;
end
end
end;
if CellsStream.Size > 0 then
begin
s := '\trowd' + buff + '\pard\intbl';
WriteExpLn(s);
Stream.CopyFrom(CellsStream, 0);
WriteExpLn('\pard\intbl{\trowd' + buff + '\row}');
end;
finally
CellsStream.Free;
end;
end;
if FMode in [2, 3] then
WriteExpLn('}');
Dec(FMode);
end;
WriteExpLn('}');
end;
function TfrxRTFExport.ShowModal: TModalResult;
begin
if not Assigned(Stream) then
begin
with TfrxRTFExportDialog.Create(nil) do
begin
SendMessage(GetWindow(PColontitulCB.Handle,GW_CHILD), EM_SETREADONLY, 1, 0);
OpenCB.Visible := not SlaveExport;
if OverwritePrompt then
SaveDialog1.Options := SaveDialog1.Options + [ofOverwritePrompt];
if SlaveExport then
FOpenAfterExport := False;
if (FileName = '') and (not SlaveExport) then
SaveDialog1.FileName := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(Report.FileName)), SaveDialog1.DefaultExt)
else
SaveDialog1.FileName := FileName;
ContinuousCB.Checked := SuppressPageHeadersFooters;
PicturesCB.Checked := FExportPictures;
PageBreaksCB.Checked := FExportPageBreaks;
WCB.Checked := FWysiwyg;
OpenCB.Checked := FOpenAfterExport;
if PageNumbers <> '' then
begin
PageNumbersE.Text := PageNumbers;
PageNumbersRB.Checked := True;
end;
if FHeaderFooterMode = hfText then
PColontitulCB.ItemIndex := 0
else if FHeaderFooterMode = hfPrint then
PColontitulCB.ItemIndex := 1
else
PColontitulCB.ItemIndex := 2;
Result := ShowModal;
if Result = mrOk then
begin
if PColontitulCB.ItemIndex = 0 then
FHeaderFooterMode := hfText
else if PColontitulCB.ItemIndex = 1 then
FHeaderFooterMode := hfPrint
else
FHeaderFooterMode := hfNone;
PageNumbers := '';
CurPage := False;
if CurPageRB.Checked then
CurPage := True
else if PageNumbersRB.Checked then
PageNumbers := PageNumbersE.Text;
SuppressPageHeadersFooters := ContinuousCB.Checked;
if FHeaderFooterMode = hfPrint then
SuppressPageHeadersFooters := True;
FExportPictures := PicturesCB.Checked;
FExportPageBreaks := PageBreaksCB.Checked;
FWysiwyg := WCB.Checked;
FOpenAfterExport := OpenCB.Checked;
if not SlaveExport then
begin
if DefaultPath <> '' then
SaveDialog1.InitialDir := DefaultPath;
if SaveDialog1.Execute then
FileName := SaveDialog1.FileName
else
Result := mrCancel;
end
end;
Free;
end;
end else
Result := mrOk;
end;
function TfrxRTFExport.Start: Boolean;
begin
if SlaveExport then
begin
if Report.FileName <> '' then
FileName := ChangeFileExt(GetTemporaryFolder + ExtractFileName(Report.FileName), frxGet(8505))
else
FileName := ChangeFileExt(GetTempFile, frxGet(8505))
end;
if (FileName <> '') or Assigned(Stream) then
begin
if (ExtractFilePath(FileName) = '') and (DefaultPath <> '') then
FileName := DefaultPath + '\' + FileName;
FFirstPage := True;
FCurrentPage := 0;
FMatrix := TfrxIEMatrix.Create(UseFileCache, Report.EngineOptions.TempDir);
FMatrix.ShowProgress := ShowProgress;
if FWysiwyg then
FMatrix.Inaccuracy := 0.5
else
FMatrix.Inaccuracy := 10;
FMatrix.RotatedAsImage := True;
FMatrix.RichText := True;
FMatrix.PlainRich := False;
FMatrix.AreaFill := True;
FMatrix.CropAreaFill := True;
FMatrix.DeleteHTMLTags := False;
FMatrix.BackgroundImage := False;
FMatrix.Background := False;
FMatrix.Printable := ExportNotPrintable;
FMatrix.EMFPictures := FExportEMF;
FFontTable := TStringList.Create;
FCharsetTable := TStringList.Create;
FColorTable := TStringList.Create;
FDataList := TList.Create;
Result := True
end
else
Result := False;
end;
procedure TfrxRTFExport.StartPage(Page: TfrxReportPage; Index: Integer);
begin
Inc(FCurrentPage);
if FFirstPage then
FFirstPage := False;
end;
procedure TfrxRTFExport.ExportObject(Obj: TfrxComponent);
begin
if (Obj is TfrxPageHeader) and (ExportNotPrintable or TfrxView(Obj).Printable) then
FMatrix.SetPageHeader(TfrxBand(Obj))
else if (Obj is TfrxPageFooter) and (ExportNotPrintable or TfrxView(Obj).Printable) then
FMatrix.SetPageFooter(TfrxBand(Obj))
else if (Obj is TfrxView) and (ExportNotPrintable or TfrxView(Obj).Printable) then
begin
if (Obj is TfrxCustomMemoView) or
(FExportPictures and (not (Obj is TfrxCustomMemoView))) then
FMatrix.AddObject(TfrxView(Obj))
end;
end;
procedure TfrxRTFExport.FinishPage(Page: TfrxReportPage; Index: Integer);
begin
FMatrix.AddPage(Page.Orientation, Page.Width, Page.Height, Page.LeftMargin,
Page.TopMargin, Page.RightMargin, Page.BottomMargin);
end;
procedure TfrxRTFExport.Finish;
var
Exp: TStream;
begin
FMatrix.Prepare;
if ShowProgress then
FProgress := TfrxProgress.Create(nil);
try
if Assigned(Stream) then
Exp := Stream
else
Exp := TFileStream.Create(FileName, fmCreate);
try
ExportPage(Exp);
finally
if not Assigned(Stream) then
Exp.Free;
end;
if FOpenAfterExport and (not Assigned(Stream)) then
ShellExecute(GetDesktopWindow, 'open', PChar(FileName), nil, nil, SW_SHOW);
except
on e: Exception do
case Report.EngineOptions.NewSilentMode of
simSilent: Report.Errors.Add(e.Message);
simMessageBoxes: frxErrorMsg(e.Message);
simReThrow: raise;
end;
end;
FMatrix.Clear;
FMatrix.Free;
FFontTable.Free;
FCharsetTable.Free;
FColorTable.Free;
FDataList.Free;
if ShowProgress then
FProgress.Free;
end;
{ TfrxRTFExportDialog }
procedure TfrxRTFExportDialog.FormCreate(Sender: TObject);
begin
Caption := frxGet(8500);
OkB.Caption := frxGet(1);
CancelB.Caption := frxGet(2);
GroupPageRange.Caption := frxGet(7);
AllRB.Caption := frxGet(3);
CurPageRB.Caption := frxGet(4);
PageNumbersRB.Caption := frxGet(5);
DescrL.Caption := frxGet(9);
GroupQuality.Caption := frxGet(8);
ContinuousCB.Caption := frxGet(8950);
PicturesCB.Caption := frxGet(8501);
PageBreaksCB.Caption := frxGet(6);
WCB.Caption := frxGet(8502);
OpenCB.Caption := frxGet(8503);
SaveDialog1.Filter := frxGet(8504);
SaveDialog1.DefaultExt := frxGet(8505);
HeadFootL.Caption := frxGet(8951);
PColontitulCB.Items[0] := frxGet(8952);
PColontitulCB.Items[1] := frxGet(8953);
PColontitulCB.Items[2] := frxGet(8954);
if UseRightToLeftAlignment then
FlipChildren(True);
end;
procedure TfrxRTFExportDialog.PageNumbersEChange(Sender: TObject);
begin
PageNumbersRB.Checked := True;
end;
procedure TfrxRTFExportDialog.PageNumbersEKeyPress(Sender: TObject;
var Key: Char);
begin
case key of
'0'..'9':;
#8, '-', ',':;
else
key := #0;
end;
end;
procedure TfrxRTFExportDialog.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_F1 then
frxResources.Help(Self);
end;
end.