e8149045e9
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7314 8e941d3f-bd1b-0410-a28a-d453659cc2b4
980 lines
27 KiB
ObjectPascal
980 lines
27 KiB
ObjectPascal
unit RichMemoRTF;
|
||
|
||
interface
|
||
|
||
{$mode objfpc}{$h+}
|
||
|
||
uses
|
||
Classes, SysUtils, LCLProc, LCLIntf, LConvEncoding, Graphics,
|
||
RichMemo, RTFParsPre211;
|
||
|
||
function MVCParserLoadStream(ARich: TCustomRichMemo; Source: TStream): Boolean;
|
||
procedure RegisterRTFLoader;
|
||
|
||
type
|
||
TEncConvProc = function (const s: string): string;
|
||
|
||
//todo: rewrite! it's not language based but fontchar-set based
|
||
procedure LangConvAdd(lang: Integer; convproc: TEncConvProc);
|
||
function LangConvGet(lang: Integer; var convproc: TEncConvProc): Boolean;
|
||
|
||
type
|
||
TSaveParams = record // reserved
|
||
start : Integer; // the first character for the extract
|
||
len : Integer; // the number of characters to extract
|
||
end;
|
||
|
||
// the function depends on GetStyleRange and to be implemented properly
|
||
// if GetStyleRange, GetParaMetric, GetParaAlignment is not working properly
|
||
// the resulting RTF would not contain any styles or the text styles would be wrong
|
||
procedure IntSaveStream(ARich: TcustomRichMemo; SaveParams: TSaveParams; Dst: TStream);
|
||
function SaveStream(ARich: TCustomRichMemo; Dst: TStream): Boolean;
|
||
procedure RegisterRTFSaver;
|
||
|
||
implementation
|
||
uses LazUTF8;
|
||
|
||
var
|
||
LangConvTable : array of record lang: integer; proc: TEncConvProc end;
|
||
LangCount : Integer = 0;
|
||
|
||
procedure LangConvAdd(lang: Integer; convproc: TEncConvProc);
|
||
var
|
||
i : integer;
|
||
begin
|
||
for i:=0 to LangCount-1 do
|
||
if LangConvTable[i].lang=lang then begin
|
||
LangConvTable[i].proc:=convproc;
|
||
Exit;
|
||
end;
|
||
if LangCount=length(LangConvTable) then begin
|
||
if LangCount=0 then SetLength(LangConvTable, 64)
|
||
else SetLength(LangConvTable, LangCount*2);
|
||
end;
|
||
LangConvTable[LangCount].lang:=lang;
|
||
LangConvTable[LangCount].proc:=convproc;
|
||
inc(LangCount);
|
||
end;
|
||
|
||
type
|
||
{ TRTFMemoParser }
|
||
|
||
{ TRTFParams }
|
||
|
||
TRTFParams = class(TObject)
|
||
public
|
||
fnt : TFontParams;
|
||
pm : TParaMetric;
|
||
pa : TParaAlignment;
|
||
fnum : Integer; // font index in the font table
|
||
|
||
prev : TRTFParams;
|
||
tabs : TTabStopList;
|
||
constructor Create(aprev: TRTFParams);
|
||
procedure ResetDefault;
|
||
procedure AddTab(AOffset: double; ta: TTabAlignment);
|
||
end;
|
||
|
||
TRTFMemoParser = class(TRTFParser)
|
||
private
|
||
txtbuf : String; // keep it UTF8 encoded!
|
||
txtlen : Integer;
|
||
|
||
HLFromCTable : Boolean;
|
||
|
||
prm : TRTFParams;
|
||
lang : Integer;
|
||
langproc : TEncConvProc;
|
||
deflang : integer;
|
||
|
||
skipNextCh: Boolean; // For a Unicode escape the control word \u is used,
|
||
// followed by a 16-bit signed decimal integer giving
|
||
// the Unicode UTF-16 code unit number. For the benefit
|
||
// of programs without Unicode support, this must be followed
|
||
// by the nearest representation of this character in the specified code page.
|
||
// For example, \u1576? would give the Arabic letter bāʼ ب, specifying that
|
||
// older programs which do not have Unicode support should render it as a
|
||
// question mark instead.
|
||
|
||
procedure AddText(const atext: string);
|
||
protected
|
||
procedure classUnk;
|
||
procedure classText;
|
||
procedure classControl;
|
||
procedure classGroup;
|
||
procedure classEof;
|
||
procedure doChangePara(aminor, aparam: Integer);
|
||
|
||
procedure doDestination(aminor, aparam: Integer);
|
||
procedure doSpecialChar;
|
||
procedure doChangeCharAttr(aminor, aparam: Integer);
|
||
|
||
procedure SetLanguage(AlangCode: integer);
|
||
|
||
function DefaultTextColor: TColor;
|
||
procedure PushText;
|
||
public
|
||
Memo : TCustomRichMemo;
|
||
constructor Create(AMemo: TCustomRichMemo; AStream: TStream);
|
||
destructor Destroy; override;
|
||
procedure StartReading;
|
||
end;
|
||
|
||
function LangConvGet(lang: Integer; var convproc: TEncConvProc): Boolean;
|
||
var
|
||
i : integer;
|
||
begin
|
||
for i:=0 to LangCount-1 do
|
||
if LangConvTable[i].lang=lang then begin
|
||
convproc:=LangConvTable[i].proc;
|
||
Result:=true;
|
||
Exit;
|
||
end;
|
||
Result:=false;
|
||
end;
|
||
|
||
procedure LangConvInit;
|
||
begin
|
||
LangConvAdd(1052, @CP1250ToUTF8); // Albanian
|
||
LangConvAdd(1050, @CP1250ToUTF8); // Croatian
|
||
LangConvAdd(1029, @CP1250ToUTF8); // Czech
|
||
LangConvAdd(1038, @CP1250ToUTF8); // Hungarian
|
||
LangConvAdd(1045, @CP1250ToUTF8); // Polish
|
||
LangConvAdd(1048, @CP1250ToUTF8); // Romanian
|
||
LangConvAdd(2074, @CP1250ToUTF8); // Serbian - Latin
|
||
LangConvAdd(1051, @CP1250ToUTF8); // Slovak
|
||
LangConvAdd(1060, @CP1250ToUTF8); // Slovenian
|
||
|
||
LangConvAdd(2092, @CP1251ToUTF8); // Azeri - Cyrillic
|
||
LangConvAdd(1059, @CP1251ToUTF8); // Belarusian
|
||
LangConvAdd(1026, @CP1251ToUTF8); // Bulgarian
|
||
LangConvAdd(1071, @CP1251ToUTF8); // FYRO Macedonia
|
||
LangConvAdd(1087, @CP1251ToUTF8); // Kazakh
|
||
LangConvAdd(1088, @CP1251ToUTF8); // Kyrgyz - Cyrillic
|
||
LangConvAdd(1104, @CP1251ToUTF8); // Mongolian
|
||
LangConvAdd(1049, @CP1251ToUTF8); // Russian
|
||
LangConvAdd(3098, @CP1251ToUTF8); // Serbian - Cyrillic
|
||
LangConvAdd(1092, @CP1251ToUTF8); // Tatar
|
||
LangConvAdd(1058, @CP1251ToUTF8); // Ukrainian
|
||
LangConvAdd(2115, @CP1251ToUTF8); // Uzbek - Cyrillic
|
||
|
||
LangConvAdd(1078, @CP1252ToUTF8); // Afrikaans
|
||
LangConvAdd(1069, @CP1252ToUTF8); // Basque
|
||
LangConvAdd(1027, @CP1252ToUTF8); // Catalan
|
||
LangConvAdd(1030, @CP1252ToUTF8); // Danish
|
||
LangConvAdd(2067, @CP1252ToUTF8); // Dutch - Belgium
|
||
LangConvAdd(1043, @CP1252ToUTF8); // Dutch - Netherlands
|
||
LangConvAdd(3081, @CP1252ToUTF8); // English - Australia
|
||
LangConvAdd(10249,@CP1252ToUTF8); // English - Belize
|
||
LangConvAdd(4105, @CP1252ToUTF8); // English - Canada
|
||
LangConvAdd(9225, @CP1252ToUTF8); // English - Caribbean
|
||
LangConvAdd(2057, @CP1252ToUTF8); // English - Great Britain
|
||
LangConvAdd(6153, @CP1252ToUTF8); // English - Ireland
|
||
LangConvAdd(8201, @CP1252ToUTF8); // English - Jamaica
|
||
LangConvAdd(5129, @CP1252ToUTF8); // English - New Zealand
|
||
LangConvAdd(13321,@CP1252ToUTF8); // English - Phillippines
|
||
LangConvAdd(7177, @CP1252ToUTF8); // English - Southern Africa
|
||
LangConvAdd(11273,@CP1252ToUTF8); // English - Trinidad
|
||
LangConvAdd(1033, @CP1252ToUTF8); // English - United States
|
||
LangConvAdd(12297,@CP1252ToUTF8); // English - Zimbabwe
|
||
LangConvAdd(1080, @CP1252ToUTF8); // Faroese
|
||
LangConvAdd(1035, @CP1252ToUTF8); // Finnish
|
||
LangConvAdd(2060, @CP1252ToUTF8); // French - Belgium
|
||
LangConvAdd(3084, @CP1252ToUTF8); // French - Canada
|
||
LangConvAdd(1036, @CP1252ToUTF8); // French - France
|
||
LangConvAdd(5132, @CP1252ToUTF8); // French - Luxembourg
|
||
LangConvAdd(6156, @CP1252ToUTF8); // French - Monaco
|
||
LangConvAdd(4108, @CP1252ToUTF8); // French - Switzerland
|
||
LangConvAdd(1110, @CP1252ToUTF8); // Galician
|
||
LangConvAdd(3079, @CP1252ToUTF8); // German - Austria
|
||
LangConvAdd(1031, @CP1252ToUTF8); // German - Germany
|
||
LangConvAdd(5127, @CP1252ToUTF8); // German - Liechtenstein
|
||
LangConvAdd(4103, @CP1252ToUTF8); // German - Luxembourg
|
||
LangConvAdd(2055, @CP1252ToUTF8); // German - Switzerland
|
||
LangConvAdd(1039, @CP1252ToUTF8); // Icelandic
|
||
LangConvAdd(1057, @CP1252ToUTF8); // Indonesian
|
||
LangConvAdd(1040, @CP1252ToUTF8); // Italian - Italy
|
||
LangConvAdd(2064, @CP1252ToUTF8); // Italian - Switzerland
|
||
LangConvAdd(2110, @CP1252ToUTF8); // Malay - Brunei
|
||
LangConvAdd(1086, @CP1252ToUTF8); // Malay - Malaysia
|
||
LangConvAdd(1044, @CP1252ToUTF8); // Norwegian - Bokml
|
||
LangConvAdd(2068, @CP1252ToUTF8); // Norwegian - Nynorsk
|
||
LangConvAdd(1046, @CP1252ToUTF8); // Portuguese - Brazil
|
||
LangConvAdd(2070, @CP1252ToUTF8); // Portuguese - Portugal
|
||
LangConvAdd(1274, @CP1252ToUTF8); // Spanish - Argentina
|
||
LangConvAdd(16394,@CP1252ToUTF8); // Spanish - Bolivia
|
||
LangConvAdd(13322,@CP1252ToUTF8); // Spanish - Chile
|
||
LangConvAdd(9226, @CP1252ToUTF8); // Spanish - Colombia
|
||
LangConvAdd(5130, @CP1252ToUTF8); // Spanish - Costa Rica
|
||
LangConvAdd(7178, @CP1252ToUTF8); // Spanish - Dominican Republic
|
||
LangConvAdd(12298,@CP1252ToUTF8); // Spanish - Ecuador
|
||
LangConvAdd(17418,@CP1252ToUTF8); // Spanish - El Salvador
|
||
LangConvAdd(4106, @CP1252ToUTF8); // Spanish - Guatemala
|
||
LangConvAdd(18442,@CP1252ToUTF8); // Spanish - Honduras
|
||
LangConvAdd(2058, @CP1252ToUTF8); // Spanish - Mexico
|
||
LangConvAdd(19466,@CP1252ToUTF8); // Spanish - Nicaragua
|
||
LangConvAdd(6154, @CP1252ToUTF8); // Spanish - Panama
|
||
LangConvAdd(15370,@CP1252ToUTF8); // Spanish - Paraguay
|
||
LangConvAdd(10250,@CP1252ToUTF8); // Spanish - Peru
|
||
LangConvAdd(20490,@CP1252ToUTF8); // Spanish - Puerto Rico
|
||
LangConvAdd(1034, @CP1252ToUTF8); // Spanish - Spain (Traditional)
|
||
LangConvAdd(14346,@CP1252ToUTF8); // Spanish - Uruguay
|
||
LangConvAdd(8202, @CP1252ToUTF8); // Spanish - Venezuela
|
||
LangConvAdd(1089, @CP1252ToUTF8); // Swahili
|
||
LangConvAdd(2077, @CP1252ToUTF8); // Swedish - Finland
|
||
LangConvAdd(1053, @CP1252ToUTF8); // Swedish - Sweden
|
||
|
||
LangConvAdd(1032, @CP1253ToUTF8); // greek
|
||
|
||
LangConvAdd(1068, @CP1254ToUTF8); // Azeri - Latin
|
||
LangConvAdd(1055, @CP1254ToUTF8); // turkish
|
||
LangConvAdd(1091, @CP1254ToUTF8); // Uzbek - Latin
|
||
|
||
LangConvAdd(1037, @CP1255ToUTF8); // hebrew
|
||
|
||
LangConvAdd(5121, @CP1256ToUTF8); // Arabic - Algeria
|
||
LangConvAdd(15361,@CP1256ToUTF8); // Arabic - Bahrain
|
||
LangConvAdd(3073, @CP1256ToUTF8); // Arabic - Egypt
|
||
LangConvAdd(2049, @CP1256ToUTF8); // Arabic - Iraq
|
||
LangConvAdd(11265,@CP1256ToUTF8); // Arabic - Jordan
|
||
LangConvAdd(13313,@CP1256ToUTF8); // Arabic - Kuwait
|
||
LangConvAdd(12289,@CP1256ToUTF8); // Arabic - Lebanon
|
||
LangConvAdd(4097, @CP1256ToUTF8); // Arabic - Libya
|
||
LangConvAdd(6145, @CP1256ToUTF8); // Arabic - Morocco
|
||
LangConvAdd(8193, @CP1256ToUTF8); // Arabic - Oman
|
||
LangConvAdd(16385,@CP1256ToUTF8); // Arabic - Qatar
|
||
LangConvAdd(1025, @CP1256ToUTF8); // Arabic - Saudi Arabia
|
||
LangConvAdd(10241,@CP1256ToUTF8); // Arabic - Syria
|
||
LangConvAdd(7169, @CP1256ToUTF8); // Arabic - Tunisia
|
||
LangConvAdd(14337,@CP1256ToUTF8); // Arabic - United Arab Emirates
|
||
LangConvAdd(9217, @CP1256ToUTF8); // Arabic - Yemen
|
||
LangConvAdd(1065, @CP1256ToUTF8); // Farsi - Persian
|
||
LangConvAdd(1056, @CP1256ToUTF8); // Urdu
|
||
|
||
LangConvAdd(1061, @CP1257ToUTF8); // Estonian
|
||
LangConvAdd(1062, @CP1257ToUTF8); // Latvian
|
||
LangConvAdd(1063, @CP1257ToUTF8); // Lithuanian
|
||
|
||
LangConvAdd(1066, @CP1258ToUTF8); // vietnam
|
||
end;
|
||
|
||
{ TRTFParams }
|
||
|
||
constructor TRTFParams.Create(aprev: TRTFParams);
|
||
begin
|
||
prev:=aprev;
|
||
if Assigned(prev) then begin
|
||
fnt:=prev.fnt;
|
||
pm:=prev.pm;
|
||
pa:=prev.pa;
|
||
fnum:=prev.fnum;
|
||
end else begin
|
||
InitFontParams(fnt);
|
||
InitParaMetric(pm)
|
||
end;
|
||
end;
|
||
|
||
procedure TRTFParams.ResetDefault;
|
||
begin
|
||
// default values are taken from RTF specs
|
||
// see section "Paragraph Formatting Properties"
|
||
pa:=paLeft;
|
||
pm.FirstLine:=0;
|
||
pm.HeadIndent:=0;
|
||
pm.TailIndent:=0;
|
||
pm.SpaceBefore:=0;
|
||
pm.SpaceAfter:=0;
|
||
pm.LineSpacing:=0;
|
||
tabs.Count:=0;
|
||
end;
|
||
|
||
procedure TRTFParams.AddTab(AOffset: double; ta: TTabAlignment);
|
||
begin
|
||
if tabs.Count=length(tabs.Tabs) then begin
|
||
if tabs.Count=0 then SetLength(tabs.Tabs, 4)
|
||
else SetLength(tabs.Tabs, tabs.Count*2);
|
||
end;
|
||
tabs.Tabs[tabs.Count].Offset:=AOffset;
|
||
tabs.Tabs[tabs.Count].Align:=ta;
|
||
inc(tabs.Count);
|
||
end;
|
||
|
||
{ TRTFMemoParserr }
|
||
|
||
procedure TRTFMemoParser.AddText(const atext: string);
|
||
var
|
||
nl : Integer;
|
||
l : Integer;
|
||
begin
|
||
nl:=txtlen+length(atext);
|
||
if nl>length(txtbuf) then begin
|
||
l:=length(txtbuf);
|
||
while l<nl do
|
||
if l=0 then l:=256
|
||
else l:=l*2;
|
||
SetLength(txtbuf, l);
|
||
end;
|
||
Move(atext[1], txtbuf[txtlen+1], length(atext));
|
||
inc(txtlen, length(atext));
|
||
end;
|
||
|
||
procedure TRTFMemoParser.classUnk;
|
||
var
|
||
txt : string;
|
||
ws : UnicodeString;
|
||
begin
|
||
if not Assigned(prm) then exit;
|
||
|
||
txt:=GetRtfText;
|
||
if (txt='\object') then begin
|
||
SkipGroup;
|
||
Exit;
|
||
end;
|
||
if (length(txt)>2) and (txt[1]='\') and (txt[2]='u') and (txt[3] in ['0'..'9']) then begin
|
||
SetLength(Ws,1);
|
||
ws[1]:=UnicodeChar(rtfParam);
|
||
AddText( UTF8Encode(ws) );
|
||
skipNextCh:=true;
|
||
end;
|
||
end;
|
||
|
||
function CharToByte(const ch: AnsiChar): Byte;
|
||
begin
|
||
Result:=0;
|
||
if ch in ['0'..'9'] then Result:=byte(ch)-byte('0')
|
||
else if ch in ['a'..'f'] then Result:=byte(ch)-byte('a')+10
|
||
else if ch in ['A'..'F'] then Result:=byte(ch)-byte('A')+10
|
||
end;
|
||
|
||
function RTFCharToByte(const s: string): byte; inline;
|
||
begin
|
||
// \'hh A hexadecimal value, based on the specified character set (may be used to identify 8-bit values).
|
||
Result:=(CharToByte(s[3]) shl 4) or (CharToByte(s[4]));
|
||
end;
|
||
|
||
procedure TRTFMemoParser.classText;
|
||
var
|
||
txt : string;
|
||
bt : Char;
|
||
begin
|
||
if not Assigned(prm) then exit;
|
||
if skipNextCh then begin
|
||
skipNextCh:=false;
|
||
Exit;
|
||
end;
|
||
|
||
txt:=Self.GetRtfText;
|
||
|
||
if (length(txt)=4) and (txt[1]='\') and (txt[2]=#39) then begin
|
||
if Assigned(langproc) then begin
|
||
bt:=char(RTFCharToByte(txt));
|
||
|
||
AddText( langproc(bt) );
|
||
end;
|
||
end else if (length(txt)=2) and (txt[1]='\') and (txt[2] in ['\','{','}']) then begin
|
||
AddText(txt[2]);
|
||
end else begin
|
||
AddText(txt);
|
||
end;
|
||
end;
|
||
|
||
procedure TRTFMemoParser.classControl;
|
||
begin
|
||
if not Assigned(prm) then exit;
|
||
|
||
if txtlen>0 then begin
|
||
PushText;
|
||
end;
|
||
//writeln('ctrl: ', rtfClass,' ', rtfMajor, ' ', Self.GetRtfText, ' ',rtfMinor,' ', rtfParam);
|
||
case rtfMajor of
|
||
rtfDestination: doDestination(rtfMinor, rtfParam);
|
||
rtfSpecialChar: doSpecialChar;
|
||
rtfCharAttr: doChangeCharAttr(rtfMinor, rtfParam);
|
||
rtfParAttr: doChangePara(rtfMinor, rtfParam);
|
||
end;
|
||
end;
|
||
|
||
procedure TRTFMemoParser.classGroup;
|
||
var
|
||
t : TRTFParams;
|
||
begin
|
||
if not Assigned(prm) then exit;
|
||
|
||
case rtfMajor of
|
||
rtfBeginGroup: begin
|
||
t:=TRTFParams.Create(prm);
|
||
prm:=t;
|
||
end;
|
||
rtfEndGroup: begin
|
||
if Assigned(prm) then begin
|
||
t:=prm.prev;
|
||
prm.Free;
|
||
prm:=t;
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TRTFMemoParser.classEof;
|
||
begin
|
||
PushText;
|
||
end;
|
||
|
||
procedure TRTFMemoParser.doDestination(aminor, aparam: Integer);
|
||
begin
|
||
case aminor of
|
||
rtfDefaultLanguage:
|
||
deflang:=aparam;
|
||
end;
|
||
end;
|
||
|
||
procedure TRTFMemoParser.doChangePara(aminor, aparam: Integer);
|
||
const
|
||
TabAl : array [rtfTabPos..rtfTabDecimal] of TTabAlignment = (
|
||
tabLeft, tabRight, tabCenter, tabDecimal);
|
||
begin
|
||
case aminor of
|
||
rtfParDef: prm.ResetDefault; // reset clear formatting
|
||
rtfQuadLeft: prm.pa:=paLeft;
|
||
rtfQuadRight: prm.pa:=paRight;
|
||
rtfQuadJust: prm.pa:=paJustify;
|
||
rtfQuadCenter: prm.pa:=paCenter;
|
||
rtfFirstIndent: begin
|
||
prm.pm.FirstLine:=aparam / 20;
|
||
end;
|
||
rtfLeftIndent: begin
|
||
prm.pm.HeadIndent:=aparam / 20;
|
||
end;
|
||
rtfRightIndent: prm.pm.TailIndent := aparam / 20;
|
||
rtfSpaceBefore: prm.pm.SpaceBefore := aparam / 20;
|
||
rtfSpaceAfter: prm.pm.SpaceAfter := aparam / 20;
|
||
rtfSpaceBetween: prm.pm.LineSpacing := aparam / 200;
|
||
// \slN - surprise! the "line spacing" is actually a multiplier based on the FONT size, not linesize
|
||
// where linesize = fontsize * 1.2
|
||
rtfLanguage: begin
|
||
SetLanguage(rtfParam);
|
||
end;
|
||
rtfTabPos,//; rtfKstr : 'tx'; rtfkHash : 0),
|
||
rtfTabRight, // rtfKstr : 'tqr'; rtfkHash : 0),
|
||
rtfTabCenter, //; rtfKstr : 'tqc'; rtfkHash : 0),
|
||
rtfTabDecimal: //; rtfKstr : 'tqdec'; rtfkHash : 0),
|
||
prm.AddTab(aparam / 20, TabAl[aminor]);
|
||
end;
|
||
end;
|
||
|
||
procedure TRTFMemoParser.doSpecialChar;
|
||
const
|
||
{$ifdef MSWINDOWS}
|
||
CharPara = #13#10;
|
||
{$else}
|
||
CharPara = #10;
|
||
{$endif}
|
||
CharTab = #9;
|
||
CharLine = #13;
|
||
begin
|
||
case rtfMinor of
|
||
rtfOptDest: SkipGroup;
|
||
rtfLine: AddText(CharLine);
|
||
rtfPar: begin
|
||
AddText(CharPara);
|
||
if deflang<>0 then
|
||
SetLanguage(deflang);
|
||
end;
|
||
rtfTab: AddText(CharTab);
|
||
end;
|
||
end;
|
||
|
||
procedure TRTFMemoParser.doChangeCharAttr(aminor, aparam: Integer);
|
||
var
|
||
p : PRTFColor;
|
||
const
|
||
HColor : array [1..16] of TColor = (
|
||
clBlack
|
||
,clBlue
|
||
,clAqua // Cyan
|
||
,clLime // Green
|
||
,clFuchsia //Magenta
|
||
,clRed
|
||
,clYellow
|
||
,clGray // unused!
|
||
,clNavy // DarkBlue
|
||
,clTeal // DarkCyan
|
||
,clGreen // DarkGreen
|
||
,clPurple // clDarkMagenta
|
||
,clMaroon // clDarkRed
|
||
,clOlive // clDarkYellow
|
||
,clGray //clDarkGray
|
||
,clSilver //clLightGray
|
||
);
|
||
begin
|
||
case aminor of
|
||
rtfPlain: prm.fnt.Style:=[];
|
||
rtfBold: if aparam=0 then Exclude(prm.fnt.Style,fsBold) else Include(prm.fnt.Style, fsBold);
|
||
rtfItalic: if aparam=0 then Exclude(prm.fnt.Style,fsItalic) else Include(prm.fnt.Style, fsItalic);
|
||
rtfStrikeThru: if aparam=0 then Exclude(prm.fnt.Style,fsStrikeOut) else Include(prm.fnt.Style, fsStrikeOut);
|
||
rtfFontNum: prm.fnum:=aparam;
|
||
rtfFontSize: prm.fnt.Size:=round(aparam/2);
|
||
rtfUnderline: if aparam=0 then Exclude(prm.fnt.Style,fsUnderline) else Include(prm.fnt.Style, fsUnderline);
|
||
rtfNoUnderline: Exclude(prm.fnt.Style, fsUnderline);
|
||
|
||
rtfSuperScript: prm.fnt.VScriptPos:=vpSuperscript;
|
||
rtfSubScript : prm.fnt.VScriptPos:=vpSubScript;
|
||
rtfNoSuperSub : prm.fnt.VScriptPos:=vpNormal;
|
||
|
||
rtfHighlight: begin
|
||
prm.fnt.HasBkClr := (aparam>0) and (aparam<=high(HColor));
|
||
if prm.fnt.HasBkClr then begin
|
||
if HLFromCTable then prm.fnt.BkColor:=HColor[aparam]
|
||
else begin
|
||
p:=Colors[aparam];
|
||
if Assigned(p) then prm.fnt.BkColor:=RGBToColor(p^.rtfCRed, p^.rtfCGreen, p^.rtfCBlue)
|
||
// fallback?
|
||
else prm.fnt.BkColor:=HColor[aparam];
|
||
end;
|
||
end;
|
||
end;
|
||
rtfForeColor: begin
|
||
if rtfParam<>0 then p:=Colors[rtfParam]
|
||
else p:=nil;
|
||
if not Assigned(p) then
|
||
prm.fnt.Color:=DefaultTextColor
|
||
else
|
||
prm.fnt.Color:=RGBToColor(p^.rtfCRed, p^.rtfCGreen, p^.rtfCBlue);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TRTFMemoParser.SetLanguage(AlangCode: integer);
|
||
begin
|
||
lang:=AlangCode;
|
||
langproc:=nil;
|
||
LangConvGet(lang, langproc);
|
||
end;
|
||
|
||
function TRTFMemoParser.DefaultTextColor:TColor;
|
||
begin
|
||
Result:=ColorToRGB(Memo.Font.Color);
|
||
end;
|
||
|
||
procedure TRTFMemoParser.PushText;
|
||
var
|
||
len : Integer;
|
||
pf : PRTFFONT;
|
||
selst : Integer;
|
||
b : string;
|
||
begin
|
||
if not Assigned(prm) then exit;
|
||
if txtlen=0 then Exit;
|
||
|
||
b:=Copy(txtbuf, 1, txtlen);
|
||
len:=UTF8Length(b);
|
||
|
||
txtlen:=0;
|
||
txtbuf:='';
|
||
if len=0 then Exit;
|
||
|
||
Memo.SelStart:=MaxInt;
|
||
selst:=Memo.SelStart;
|
||
// in order to get the start selection, we need to switch to the last character
|
||
// and then get the value. SelStart doesn't match GetTextLen, since
|
||
// "StartSel" is based on number of visible characters (i.e. line break is 1 character)
|
||
// while GetTextLen is based on number of actual string characters
|
||
// selst:=Memo.GetTextLen;
|
||
|
||
Memo.SelStart:=selst;
|
||
Memo.SelLength:=0;
|
||
Memo.SelText:=b;
|
||
|
||
if Assigned(prm) then begin
|
||
prm.pm.FirstLine:=prm.pm.HeadIndent+prm.pm.FirstLine;
|
||
Memo.SetParaMetric(selst, 1, prm.pm );
|
||
prm.pm.FirstLine:=prm.pm.FirstLine-prm.pm.HeadIndent;
|
||
|
||
Memo.SetParaAlignment(selst, 1, prm.pa );
|
||
|
||
if prm.tabs.Count>0 then
|
||
Memo.SetParaTabs(selst, 1, prm.tabs);
|
||
end;
|
||
|
||
// Memo.GetTextAttributes(selst, font);
|
||
pf:=Fonts[prm.fnum];
|
||
if Assigned(pf) then prm.fnt.Name:=pf^.rtfFName;
|
||
//prm.fnt.Size:=round(fsz);
|
||
//prm.fnt.Style:=fst;
|
||
//prm.fnt.Color:=ColorToRGB(fColor);
|
||
//prm.fnt.HasBkClr:=hasbk;
|
||
//prm.fnt.BkColor:=bcolor;
|
||
Memo.SetTextAttributes(selst, len, prm.fnt);
|
||
end;
|
||
|
||
constructor TRTFMemoParser.Create(AMemo:TCustomRichMemo;AStream:TStream);
|
||
begin
|
||
inherited Create(AStream);
|
||
Memo:=AMemo;
|
||
ClassCallBacks[rtfText]:=@classText;
|
||
ClassCallBacks[rtfControl]:=@classControl;
|
||
ClassCallBacks[rtfGroup]:=@classGroup;
|
||
ClassCallBacks[rtfUnknown]:=@classUnk;
|
||
ClassCallBacks[rtfEof]:=@classEof;
|
||
end;
|
||
|
||
destructor TRTFMemoParser.Destroy;
|
||
var
|
||
t: TRTFParams;
|
||
begin
|
||
// cleanup
|
||
while Assigned(prm) do begin
|
||
t:=prm;
|
||
prm:=prm.prev;
|
||
t.Free;
|
||
end;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
procedure TRTFMemoParser.StartReading;
|
||
var
|
||
t : TRTFParams;
|
||
begin
|
||
Memo.Lines.BeginUpdate;
|
||
try
|
||
|
||
prm:=TRTFParams.Create(nil);
|
||
prm.fnt.Size:=12; //\fsN Font size in half-points (the default is 24).
|
||
prm.fnum:=0;
|
||
prm.ResetDefault;
|
||
|
||
inherited StartReading;
|
||
PushText;
|
||
|
||
// clear the stack, if overflow
|
||
while Assigned(prm) do begin
|
||
t:=prm.prev;
|
||
prm.Free;
|
||
prm:=t;
|
||
end;
|
||
|
||
Memo.SelStart:=0;
|
||
Memo.SelLength:=0;
|
||
finally
|
||
Memo.Lines.EndUpdate;
|
||
end;
|
||
end;
|
||
|
||
function MVCParserLoadStream(ARich: TCustomRichMemo; Source: TStream): Boolean;
|
||
var
|
||
p : TRTFMemoParser;
|
||
begin
|
||
Result:=Assigned(ARich) and Assigned(Source);
|
||
if not Result then Exit;
|
||
|
||
p:=TRTFMemoParser.Create(ARich, Source);
|
||
try
|
||
p.StartReading;
|
||
finally
|
||
p.Free;
|
||
end;
|
||
Result:=True;
|
||
end;
|
||
|
||
procedure RegisterRTFLoader;
|
||
begin
|
||
RTFLoadStream:=@MVCParserLoadStream;
|
||
LangConvInit;
|
||
end;
|
||
|
||
function SaveStream(ARich: TcustomRichMemo; Dst: TStream): Boolean;
|
||
var
|
||
p : TSaveParams;
|
||
begin
|
||
FillChar(p, sizeof(p), 0);
|
||
p.start:=-1;
|
||
p.len:=-1;
|
||
IntSaveStream(ARich, p, Dst);
|
||
Result:=True;
|
||
end;
|
||
|
||
procedure RegisterRTFSaver;
|
||
begin
|
||
RTFSaveStream:=@SaveStream;
|
||
end;
|
||
|
||
type
|
||
TStyleRange = class(TObject)
|
||
font : TFontParams;
|
||
fontId : Integer; // assigned font ID
|
||
colorId : Integer;
|
||
textStart : Integer;
|
||
textLength : Integer;
|
||
next : TStyleRange;
|
||
end;
|
||
|
||
procedure FreeStyleList(var root: TStyleRange);
|
||
var
|
||
t: TStyleRange;
|
||
begin
|
||
while Assigned(root) do begin
|
||
t:=root.next;
|
||
root.Free;
|
||
root:=t;
|
||
end;
|
||
end;
|
||
|
||
procedure PrepareFontTable(styleslist: TStyleRange; afontTable: TStringList);
|
||
var
|
||
rng : TStyleRange;
|
||
i : integer;
|
||
begin
|
||
rng:=styleslist;
|
||
while Assigned(rng) do begin
|
||
i:=afontTable.IndexOf(rng.font.Name);
|
||
if i<0 then
|
||
i:=afontTable.Add(rng.font.Name);
|
||
rng.fontId:=i;
|
||
rng:=rng.next;
|
||
end;
|
||
// {\f0\fswiss\fcharset0 Arial;}
|
||
end;
|
||
|
||
function ColorToRtfText(const cl: TColor): string;
|
||
var
|
||
r: integer;
|
||
begin
|
||
r:=ColorToRGB(cl);
|
||
Result:=
|
||
'\red'+IntToStR( byte( (r and clRed) shr 0) )
|
||
+'\green'+IntToStR( byte( (r and clLime) shr 8) )
|
||
+'\blue'+IntToStR( byte( (r and clBlue) shr 16) );
|
||
end;
|
||
|
||
procedure PrepareColorTable(styleslist: TStyleRange; acolorTable: TStringList);
|
||
var
|
||
rng : TStyleRange;
|
||
i : integer;
|
||
t : string;
|
||
begin
|
||
rng:=styleslist;
|
||
acolorTable.Add('');
|
||
while Assigned(rng) do begin
|
||
if rng.font.Color=clBlack then
|
||
rng.colorId:=0
|
||
else begin
|
||
t:=ColorToRtfText(rng.font.Color);
|
||
i:=acolorTable.IndexOf(t);
|
||
if i<0 then i:=acolorTable.Add(t);
|
||
rng.colorId:=i;
|
||
end;
|
||
rng:=rng.next;
|
||
end;
|
||
// {\f0\fswiss\fcharset0 Arial;}
|
||
end;
|
||
|
||
function GetRTFWriteText(const u: UnicodeString; var idx : integer; var isNewPara: Boolean): string;
|
||
var
|
||
i : integer;
|
||
begin
|
||
Result:='';
|
||
i:=idx;
|
||
isNewPara:=false;
|
||
while i<=length(u) do begin
|
||
if u[i]='\' then Result:=Result+'\\'
|
||
else if u[i]='{' then Result:=Result+'\{'
|
||
else if u[i]='}' then Result:=Result+'\}'
|
||
else if u[i]=#10 then begin
|
||
Result:=Result+'\par ';
|
||
isNewPara:=true;
|
||
inc(i);
|
||
Break;
|
||
end else if u[i]=#13 then begin
|
||
Result:=Result+'\par ';
|
||
isNewPara:=true;
|
||
inc(i);
|
||
Break;
|
||
end else if u[i]<#127 then Result:=Result+char(byte(u[i]))
|
||
else Result:=Result+'\u'+IntToStr(word(u[i]))+' '; // adding a blank "space" character replacement
|
||
inc(i);
|
||
end;
|
||
idx:=i;
|
||
end;
|
||
|
||
procedure IntSaveStream(ARich: TCustomRichMemo; SaveParams: TSaveParams; Dst: TStream);
|
||
var
|
||
ofs : Integer;
|
||
needlen : Integer;
|
||
endless : Boolean;
|
||
root : TStyleRange; // first in the list
|
||
last : TStyleRange; // last in the list
|
||
rng : TStyleRange; // temproray
|
||
st, len : Integer;
|
||
u : UnicodeString;
|
||
fontTable : TStringList;
|
||
colorTable : TStringList;
|
||
i : Integer;
|
||
isnewpara : Boolean;
|
||
s : string;
|
||
|
||
isbold : Boolean;
|
||
isitalic : Boolean;
|
||
isuline : Boolean;
|
||
issupersub: Boolean;
|
||
isColor : integer;
|
||
|
||
pm : TParaMetric;
|
||
|
||
procedure RtfOut(const s: string);
|
||
begin
|
||
Dst.Write(s[1], length(s));
|
||
end;
|
||
|
||
begin
|
||
if SaveParams.start<0 then ofs:=0
|
||
else ofs:=SaveParams.start;
|
||
root:=nil;
|
||
last:=nil;
|
||
needlen:=SaveParams.len;
|
||
endless:=needlen<0;
|
||
|
||
while ARich.GetStyleRange(ofs, st, len) do begin
|
||
rng:=TStyleRange.Create;
|
||
rng.textStart:=st;
|
||
if not endless then begin
|
||
if needlen<len then rng.textLength:=needlen
|
||
else rng.textLength:=len;
|
||
dec(needLen, len);
|
||
end else
|
||
rng.textLength:=len;
|
||
ARich.GetTextAttributes(ofs, rng.font);
|
||
|
||
if not Assigned(root) then root:=rng;
|
||
if Assigned(last) then last.next:=rng;
|
||
last:=rng;
|
||
|
||
inc(ofs, len);
|
||
if not endless and (needLen<=0) then break;
|
||
end;
|
||
|
||
if root=nil then begin
|
||
// GetStyleRange failed - fallback to simple style export!
|
||
root:=TStyleRange.Create;
|
||
root.textStart:=0;
|
||
root.textLength:=MaxInt;
|
||
root.font.Name:=ARich.Font.Name;
|
||
root.font.Size:=ARich.Font.Size;
|
||
end;
|
||
|
||
fontTable:=TStringList.Create;
|
||
colorTable:=TStringList.Create;
|
||
try
|
||
PrepareFontTable(root, fontTable);
|
||
PrepareColorTable(root, colorTable);
|
||
|
||
RtfOut('{\rtf1\ansi\ansicp1252\deff0\deflan1033');
|
||
|
||
// start of RTF
|
||
if fontTable.Count>0 then begin
|
||
// at least on font should be present anyway.
|
||
RtfOut('{\fonttbl');
|
||
for i:=0 to fontTable.Count-1 do begin
|
||
// setting font id, charset to 0 and name
|
||
RtfOut('{\f'+IntToStR(i)+'\fcharset0 '+fontTable[i]+';}');
|
||
end;
|
||
RtfOut('}');
|
||
end;
|
||
if colorTable.Count>1 then begin
|
||
RtfOut('{\colortbl');
|
||
for i:=0 to colorTable.Count-1 do begin
|
||
RtfOut( colortable[i] );
|
||
RtfOut( ';');
|
||
end;
|
||
RtfOut('}');
|
||
end;
|
||
|
||
isnewpara := true;
|
||
rng:=root;
|
||
isbold:=false;
|
||
isitalic:=false;
|
||
issupersub:=false;
|
||
iscolor:=0;
|
||
while Assigned(rng) do begin
|
||
u:=ARich.GetUText(rng.textStart, rng.textLength);
|
||
RtfOut('\f'+IntToStr(rng.fontId));
|
||
RtfOut('\fs'+IntToStr(rng.font.Size*2));
|
||
if (fsBold in rng.font.Style) then begin
|
||
RtfOut('\b');
|
||
isbold:=true;
|
||
end else begin
|
||
if isbold then RtfOut('\b0');
|
||
isbold:=false;
|
||
end;
|
||
if (fsUnderline in rng.font.Style) then begin
|
||
RtfOut('\ul');
|
||
isuline:=true
|
||
end else begin
|
||
if isuline then RtfOut('\ulnone');
|
||
isuline:=false;
|
||
end;
|
||
if isColor<>rng.colorId then begin
|
||
RtfOut('\cf'+IntToStR(rng.colorId));
|
||
isColor:=rng.ColorId;
|
||
end;
|
||
if (fsItalic in rng.font.Style) then begin
|
||
RtfOut('\i');
|
||
isitalic:=true;
|
||
end else begin
|
||
if isitalic then RtfOut('\i0');
|
||
isitalic:=false;
|
||
end;
|
||
|
||
if rng.font.VScriptPos=vpSuperScript then begin
|
||
RtfOut('\super');
|
||
issupersub:=true;
|
||
end;
|
||
if rng.font.VScriptPos=vpSubScript then begin
|
||
RtfOut('\sub');
|
||
issupersub:=true;
|
||
end;
|
||
if rng.font.VScriptPos=vpNormal then begin
|
||
if issupersub then RtfOut('\nosupersub');
|
||
issupersub:=false;
|
||
end;
|
||
|
||
RtfOut(' ');
|
||
|
||
i:=1;
|
||
while i<=length(u) do begin
|
||
if isNewPara then begin
|
||
ARich.GetParaMetric(i+rng.textStart, pm);
|
||
RtfOut('\pard');
|
||
case ARich.GetParaAlignment(i+rng.TextStart) of
|
||
paRight: RtfOut('\qr');
|
||
paCenter: RtfOut('\qc');
|
||
paJustify: RtfOut('\qj');
|
||
else
|
||
end;
|
||
RtfOut('\li'+IntToStr(round(pm.HeadIndent*20)));
|
||
if pm.FirstLine-pm.HeadIndent<>0 then
|
||
RtfOut('\fi'+IntToStr(round((pm.FirstLine-pm.HeadIndent)*20)));
|
||
if pm.TailIndent<>0 then RtfOut('\ri'+IntToStr(round(pm.TailIndent*20)));
|
||
if pm.SpaceAfter<>0 then RtfOut('\sa'+IntToStr(round(pm.SpaceAfter*20)));
|
||
if pm.SpaceBefore<>0 then RtfOut('\sb'+IntToStr(round(pm.SpaceBefore*20)));
|
||
if pm.LineSpacing<>0 then RtfOut('\sl'+IntToStr(round(pm.LineSpacing*200))+'\slmult1');
|
||
RtfOut(' ');
|
||
end;
|
||
s:=GetRTFWriteText(u, i, isnewpara);
|
||
RtfOut(s);
|
||
end;
|
||
rng:=rng.next;
|
||
end;
|
||
|
||
// end of RTF
|
||
RtfOut('}');
|
||
finally
|
||
fontTable.Free;
|
||
colorTable.Free;
|
||
end;
|
||
FreeStyleList(root);
|
||
end;
|
||
|
||
initialization
|
||
|
||
end.
|