RichEdit

开发平台：

Delphi

RVRTF.pas：源码内容

if (Copy(UpperCase(s),1, Length(Code1))<>Code1) and
(Copy(UpperCase(s),1, Length(Code2))<>Code2) then
exit;
s := GetFieldCommandValue(s);
if s='' then
exit;
while true do begin
p := pos('\', s);
if p=0 then break;
Delete(s,p, 1);
end;
if (BasePath<>'') and (BasePath[Length(BasePath)] in ['', '/']) and
(s<>'') and (s[1] in ['', '/']) then
s := Copy(s, 2, Length(s)-1);
try
if Pos(':', s)=0 then
s := BasePath+s;
//RV_ReplaceStr(s, '/', '');
gr := LoadGraphic(s, Invalid);
if (gr=nil) or Invalid then begin
s2 := RV_DecodeURL(s);
//RV_ReplaceStr(s2, '', '/');
if s2<>s then begin
s := s2;
gr2 := LoadGraphic(s, Invalid);
if gr2<>nil then begin
gr.Free;
gr := gr2;
end;
end;
end;
if gr<>nil then begin
if Invalid then
FRTFState.FInvalidFieldPicture := gr
else begin
FRTFState.ParaProps.Finalize;
RV_AfterImportGraphic(gr);
FOnNewPicture(Self, nil, gr, Position, s, Inserted);
Position := rtf_ts_ContinuePara;
FRTFState.FFieldPictureIncluded := True;
end;
end;
except
;
end;
end;
{------------------------------------------------------------------------------}
function TRVRTFReader.InsertSymbol: TRVRTFErrorCode;
const Code = 'SYMBOL';
var s: String;
p: Integer;
ch: Char;
FontName: String;
OldFontSize, FontSize: Integer;
begin
Result := rtf_ec_OK;
OldFontSize := RTFState.CharProps.FSize;
s := Trim(FRTFState.FFieldCode);
if Copy(UpperCase(s),1, Length(Code))<>Code then
exit;
s := Copy(s,Length(Code)+2,Length(s)+1);
p := Pos(' ', s);
if p=0 then
exit;
ch := Chr(StrToInt(Copy(s, 1, p-1)));
p := Pos('f', s);
if p=0 then
exit;
FontName := Copy(s, p+3, Length(s));
if s='' then
exit;
if FontName[1]<>'"' then
exit;
FontName := Copy(FontName, 2,Length(FontName));
p := Pos('"', FontName);
if p=0 then
exit;
FontName := Copy(FontName, 1, p-1);
p := Pos('s', s);
if p=0 then
exit;
s := Copy(s, p+3, Length(s));
p := Pos(' ',s);
if p>0 then
s := Copy(s, 1, p-1);
FontSize := StrToInt(s);
RTFState.CharProps.FFontName := FontName;
RTFState.CharProps.FSize := FontSize;
OutputChar(ch, False, False);
OutputChar(#0, False, False);
RTFState.CharProps.FSize := OldFontSize;
RTFState.CharProps.FFontName := '';
end;
{------------------------------------------------------------------------------}
type
PBitmap = ^TBitmap;
function RVEnhMetaFileProc(DC: THandle; PHTable: PHandleTable;
PEMFR: PENHMetaRecord; Obj: Integer; Data: Pointer): Integer; export; stdcall;
var PEMRSDIB: PEMRStretchDIBits;
PEMRSDIBTD: PEMRSetDIBitsToDevice;
bi: PBitmapInfo;
begin
case PEMFR.iType of
1, 9..11, 14, 17, 21, 24, 25, 33, 34, 37, 48, 70, 75:
Result := 1;
EMR_SETDIBITSTODEVICE:
begin
if Assigned(PBitmap(Data)^) then begin
(PBitmap(Data)^).Free;
PBitmap(Data)^ := nil;
Result := 0;
exit;
end;
PBitmap(Data)^ := TBitmap.Create;
PEMRSDIBTD := PEMRSetDIBitsToDevice(PEMFR);
bi := PBitmapInfo(PChar(PEMRSDIBTD)+PEMRSDIBTD.offBmiSrc);
PBitmap(Data)^.Handle := CreateDIBitmap(DC, bi.bmiHeader,
CBM_INIT, PChar(PEMRSDIBTD)+ PEMRSDIBTD.offBitsSrc,
bi^, PEMRSDIBTD.iUsageSrc);
Result := 1;
end;
EMR_STRETCHDIBITS:
begin
if Assigned(PBitmap(Data)^) then begin
(PBitmap(Data)^).Free;
PBitmap(Data)^ := nil;
Result := 0;
exit;
end;
PBitmap(Data)^ := TBitmap.Create;
PEMRSDIB := PEMRStretchDIBits(PEMFR);
bi := PBitmapInfo(PChar(PEMRSDIB)+PEMRSDIB.offBmiSrc);
PBitmap(Data)^.Handle := CreateDIBitmap(DC, bi.bmiHeader,
CBM_INIT, PChar(PEMRSDIB)+ PEMRSDIB.offBitsSrc,
bi^, PEMRSDIB.iUsageSrc);
Result := 1;
end;
else begin
(PBitmap(Data)^).Free;
PBitmap(Data)^ := nil;
Result := 0;
end;
end;
end;
{------------------------------------------------------------------------------}
function ConvertMetafileToBitmap(wmf: TMetafile): TBitmap;
var bmp: TBitmap;
DC: THandle;
begin
bmp := nil;
DC := GetDC(0);
try
EnumEnhMetaFile(DC, wmf.Handle, @RVEnhMetaFileProc, @bmp,
Bounds(0, 0, wmf.Width, wmf.Height));
finally
ReleaseDC(0, DC);
end;
Result := bmp;
end;
{------------------------------------------------------------------------------}
// The destination specified by rds is coming to a close.
// If there's any cleanup that needs to be done, do it now.
function TRVRTFReader.EndGroupAction(rds: TRTFrds): TRVRTFErrorCode;
{.........................................}
procedure FinalizeDIB;
var header: TBitmapFileHeader;
begin
header.bfType := 19778; // 'BM'
header.bfSize := FPicture.FData.Size;
header.bfReserved1 := 0;
header.bfReserved2 := 0;
header.bfOffBits := 0; // ignored by TBitmap.LoadFromStream
FPicture.FData.Position := 0;
FPicture.FData.WriteBuffer(header, sizeof(Header));
end;
{.........................................}
function CreateGraphic: TGraphic;
begin
case FPicture.FType of
rtf_pict_EMF:
begin
Result := TMetafile.Create;
TMetafile(Result).Enhanced := True;
end;
rtf_pict_WMF:
begin
Result := TMetafile.Create;
TMetafile(Result).Enhanced := False;
end;
rtf_pict_DIB:
begin
FinalizeDIB;
Result := TBitmap.Create;
end;
rtf_pict_DDB:
begin
Result := TBitmap.Create;
end;
{$IFDEF RICHVIEW}
rtf_pict_PNG:
begin
if RVPngGraphiClass<>nil then
Result := RV_CreateGraphics(RVPngGraphiClass)
else
Result := nil;
end;
{$ENDIF}
{$IFNDEF RVDONOTUSEJPEGIMAGE}
rtf_pict_JPEG:
Result := TJpegImage.Create;
{$ENDIF}
else
Result := nil;
end;
end;
{.........................................}
procedure LoadGraphic(var gr: TGraphic);
var HM: HMetafile;
MFP: TMetaFilePict;
wmf: TMetafile;
{$IFDEF RICHVIEWDEF4}
//HM2: HMetafile;
//gr2: TMetafile;
{$ENDIF}
begin
case FPicture.FType of
rtf_pict_WMF:
begin
with MFP do begin
mm := FPicture.FMetafileMapMode;
xExt := FPicture.FPicW;
yExt := FPicture.FPicH;
hMF := 0;
end;
if (FPicture.FPicW>0) and (FPicture.FPicH>0) and
((FPicture.FMetafileMapMode=MM_ISOTROPIC) or (FPicture.FMetafileMapMode=MM_ANISOTROPIC))then begin
FPicture.SuggestedWidth := Round(FPicture.FPicW/2540*PixelsPerInch);
FPicture.SuggestedHeight := Round(FPicture.FPicH/2540*PixelsPerInch);
end;
HM := SetWinMetaFileBits(FPicture.FData.Size, FPicture.FData.Memory, 0, MFP);
if (HM=0) then
Exception.Create('Invalid metafile');
TMetafile(gr).Handle := HM;
{$IFDEF RICHVIEWDEF4}
// black magic starts...
{
with MFP do begin
mm := FPicture.FMetafileMapMode;
xExt := 0;
yExt := 0;
hMF := 0;
end;
HM2 := SetWinMetaFileBits(FPicture.FData.Size, FPicture.FData.Memory, 0, MFP);
gr2 := TMetafile.Create;
gr2.Handle := HM2;
if (gr.Width<>gr2.Width) or
(gr.Height<>gr2.Height) then
TMetafile(gr).Inch := PixelsPerInch*100;
gr2.Free;
}
// black magic ends...
{$ENDIF}
TMetafile(gr).Enhanced := True;
if FExtractMetafileBitmaps then begin
wmf := TMetafile(gr);
gr := ConvertMetafileToBitmap(wmf);
if gr=nil then
gr := wmf
else
wmf.Free;
end;
end;
rtf_pict_DDB:
begin
TBitmap(gr).Handle := CreateBitmap(FPicture.FPicW, FPicture.FPicH,
FPicture.FWBMPlanes, FPicture.FWBMBitsPixel, FPicture.FData.Memory);
end;
else
begin
FPicture.FData.Position := 0;
gr.LoadFromStream(FPicture.FData);
end;
end;
if (FPicture.FPicWGoalTw<>0) and (FPicture.FPicHGoalTw<>0) then begin
FPicture.SuggestedWidth := Round(FPicture.FPicWGoalTw * PixelsPerInch / (72*20));
FPicture.SuggestedHeight := Round(FPicture.FPicHGoalTw * PixelsPerInch / (72*20));
end;
end;
{.........................................}
var gr: TGraphic;
s: String;
{$IFDEF RICHVIEWCBDEF3}
ws: WideString;
{$ELSE}
ws: String;
{$ENDIF}
Inserted: Boolean;
begin
Result := rtf_ec_OK;
case rds of
rdsFontTable:
FFontTable.RemoveChasetFromNames;
rdsFldInst:
begin
InsertExternalPicture;
InsertSymbol;
end;
rdsField:
begin
if Assigned(FOnNewPicture) and (RTFState.FInvalidFieldPicture<>nil) then begin
FRTFState.ParaProps.Finalize;
RV_AfterImportGraphic(RTFState.FInvalidFieldPicture);
FOnNewPicture(Self, nil, RTFState.FInvalidFieldPicture, Position, '', Inserted);
if Inserted then
RTFState.FInvalidFieldPicture := nil;
Position := rtf_ts_ContinuePara;
end;
FRTFState.FFieldCode := '';
FRTFState.FFieldPictureIncluded := False;
FRTFState.FInvalidFieldPicture.Free;
FRTFState.FInvalidFieldPicture := nil;
end;
rdsObjData:
begin
Result := OutputChar(#0,False,True);
if Result<>rtf_ec_OK then
exit;
Result := DoNewObject;
end;
rdsObject:
begin
FObject.Free;
FObject := nil;
end;
rdsPict:
begin
Result := OutputChar(#0,False,True);
if Result<>rtf_ec_OK then
exit;
if not FRTFState.FFieldPictureIncluded then begin
if (FPicture=nil) then begin
if Assigned(FOnNewPicture) then
Result := rtf_ec_InvalidPicture;
exit;
end;
gr := CreateGraphic;
if gr<>nil then begin
try
LoadGraphic(gr);
except
gr.Free;
gr := nil;
Result := rtf_ec_InvalidPicture;
end;
end;
if gr<>nil then
RV_AfterImportGraphic(gr);
Inserted := False;
if Result = rtf_ec_OK then
Result := DoNewPicture(gr, Inserted);
if (Result=rtf_ec_OK) and not Inserted and Assigned(FOnNewPicture) and
(RTFState.FInvalidFieldPicture<>nil) then begin
FRTFState.ParaProps.Finalize;
RV_AfterImportGraphic(RTFState.FInvalidFieldPicture);
FOnNewPicture(Self, nil, RTFState.FInvalidFieldPicture, Position, '', Inserted);
if Inserted then
RTFState.FInvalidFieldPicture := nil;
Position := rtf_ts_ContinuePara;
end;
end;
FPicture.Free;
FPicture := nil;
RTFState.FInvalidFieldPicture.Free;
RTFState.FInvalidFieldPicture := nil;
end;
rdsListLevelText:
begin
s := FListTable.GetLastList.GetLastLevel.Text;
if (Length(s)>0) then begin
s := Copy(s,1, ord(s[1])+1);
FListTable.GetLastList.GetLastLevel.FText := s;
end;
ws := FListTable.GetLastList.GetLastLevel.TextW;
if (Length(ws)>0) then begin
ws := Copy(ws,1, Word(ws[1])+1);
FListTable.GetLastList.GetLastLevel.FTextW := ws;
//FListTable.GetLastList.GetLastLevel.FText := UnicodeToAnsi(ws);
end;
end;
rdsListLevelNumbers:
begin
s := FListTable.GetLastList.GetLastLevel.Numbers;
if (Length(s)>0) then begin
s := Copy(s,1, ord(s[1])+1);
FListTable.GetLastList.GetLastLevel.FNumbers := s;
end;
end;
end;
end;
{------------------------------------------------------------------------------}
function TRVRTFReader.DoNewPicture(gr: TGraphic; var Inserted: Boolean): TRVRTFErrorCode;
begin
Inserted := False;
try
if Assigned(FOnNewPicture) then begin
FRTFState.ParaProps.Finalize;
FPicture.FData.Position := 0;
FOnNewPicture(Self, FPicture, gr, Position, '', Inserted);
if FPicture.ShpPict then
ShpPictInserted := Inserted;
if Inserted then
Position := rtf_ts_ContinuePara;
end;
Result := rtf_ec_OK;
except
Result := rtf_ec_Aborted;
end;
end;
{------------------------------------------------------------------------------}
function TRVRTFReader.DoNewObject: TRVRTFErrorCode;
begin
try
if Assigned(FOnNewObject) then begin
FRTFState.ParaProps.Finalize;
FObject.FData.Position := 0;
FOnNewObject(Self, FObject, Position, ObjectInserted);
Position := rtf_ts_ContinuePara;
end;
Result := rtf_ec_OK;
except
Result := rtf_ec_Aborted;
end;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFReader.DoTable(WhatHappens: TRVRTFTableEventKind);
begin
UpdateMarker;
if WhatHappens=rvf_tbl_TableStart then
FTableAlignmentDefined := False;
if Assigned(FOnTable) then
FOnTable(Self, WhatHappens);
end;
{------------------------------------------------------------------------------}
procedure TRVRTFReader.CheckTable(AllowEnd: Boolean);
var i, lev,newlev: Integer;
begin
if FRTFState.ParaProps.NoTableEv then
AllowEnd := False;
newlev := CurrentNestingLevel;
if FRTFState.ParaProps.InTable then
lev := FRTFState.ParaProps.NestingLevel
else
lev := 0;
if CurrentNestingLevel<lev then begin
for i := CurrentNestingLevel to lev-1 do
DoTable(rvf_tbl_TableStart);
newlev := lev;
end;
if AllowEnd and (CurrentNestingLevel>lev) then begin
for i := CurrentNestingLevel downto lev+1 do
DoTable(rvf_tbl_TableEnd);
newlev := lev;
end;
CurrentNestingLevel := newlev;
end;
{------------------------------------------------------------------------------}
// Evaluate an RTF control that needs special processing.
function TRVRTFReader.ParseSpecialKeyword(ipfn:TRTFIPFN): TRVRTFErrorCode;
begin
Result := rtf_ec_OK;
if (FRTFState.rds = rdsSkip) and (ipfn <> ipfnBin) then // if we're skipping, and it's not
exit; // the bin keyword, ignore it.
case ipfn of
ipfnBin:
begin
FRTFState.ris := risBin;
cbBin := lParam;
end;
ipfnSkipDest:
{if rds<>rdsStyleSheet then } fSkipDestIfUnk := True;
ipfnHex:
FRTFState.ris := risHex;
else
Result := rtf_ec_BadTable;
end;
end;
{------------------------------------------------------------------------------}
{.$DEFINE WORDDOCDEBUG}
{$IFDEF RVUSEWORDDOC}
function TRVRTFReader.ParseWordDocFile(const AFileName: String): TRVRTFErrorCode;
var
InitResult: TRVDOCErrorCode;
Res : TRVRTFErrorCode;
OutStruct : TOutPutStruct;
ListDescStruc : TListDescStruc;
ParseRes : Char;
iTab : Integer;
bFirstRunPass : Boolean;
i : Integer;
a : TRVRTFList97;
b : TRVRTFListLevel97;
pic : TPictStruc;
gr: TGraphic;
begin
{$IFDEF WORDDOCDEBUG}
Clear;
FFontTable.Add(0);
FFontTable.Items[0].Name := 'Arial';
RTFState.CharProps.FSize := 24;
GetPicture(pic);
FPicture := TRVRTFPicture.Create;
FPicture.FPicWGoalTw := pic.dxaGoal;
FPicture.FPicHGoalTw := pic.dyaGoal;
FPicture.FPicScaleX := pic.mx;
FPicture.FPicScaleY := pic.my;
//FPicture.FMetafileMapMode := 8;
FPicture.FPicW := 447;
FPicture.FPicH := 419;
FPicture.FType := TRVRTFPictureType(pic.picType);
FPicture.FData.Position := 0;
FPicture.FData.WriteBuffer(pic.pPicBytes^, pic.picSize);
Res := EndGroupAction(rdsPict);
OnNewText(Self, 'Hello', rtf_ts_NewPara);
Result := rtf_ec_OK;
{$ELSE}
{$R-}
Clear;
bFirstRunPass := false; // in the case table is in the beginning of the document
iTab := sizeof(TFontProps);
iTab := sizeof(OutStruct.ParaProps);
FFontTable.Add(0);
InitResult := InitializeWordDocument(AFileName, OutStruct);
if InitResult = doc_ec_OK then
begin
FListTable.AddNew;
//FListOverrideTable.AddNew;
//i := 0;
while GetNextListDesc(ListDescStruc) do begin
FListTable.GetLastList.AddNew;
with FListTable.GetLastList.GetLastLevel do begin
FStart := ListDescStruc.FStart;
FListType := RVRTF.TRVRTFParaListType(ListDescStruc.FListType And 7);
FAlignment := RVRTF.TRVRTFAlignment(ListDescStruc.FListType shr 3);
FColor := ListDescStruc.FColor;
FFontIndex := 0;//ListDescStruc.FFontIndex;
if ListDescStruc.FFontSize <> 0 then
begin
FFontSize := ListDescStruc.FFontSize;
FFontSizeDefined := True;
end;
FFontStyle := ListDescStruc.FFontStyle;
FLeftIndentTw := ListDescStruc.FLeftIndentTw;
FFirstIndentTw := ListDescStruc.FFirstIndentTw;
FTabPosTw := ListDescStruc.FTabPosTw;
FTextW := ListDescStruc.FTextW;
end;
FListOverrideTable.AddNew;
with FListOverrideTable.GetLastListOverride do begin
FListIndex := 0;
AddNew;
GetLastLevel.FUseStart := False;
GetLastLevel.FStart := 1;
end;
//Inc(i);
end;
while true do begin
//OutStruct.Text;
ParseRes := ParseWordDocument(OutStruct);
if (ParseRes = #255) then break;
//i := Integer(OutStruct.TableFlags);
// in the case the first character on the beginning of the row is the carry return
// the following to ifs should correct the situation, otherwise the carry is just disappear
if ((not bFirstRunPass) and (OutStruct.TableFlags=1) and (OutStruct.Text[0]='')) or ((OutStruct.TableFlags=1) and (OutStruct.Text[0]='') and (ParseRes=#10)) then
begin
OnTable(Self, rvf_tbl_TableStart);
OutStruct.TableFlags := 0;
end;
if (OutStruct.TableFlags=3) and (OutStruct.Text[0]='') and (ParseRes=#10) then
begin
TGetRowProperties;
CheckTable(True);
Position := rtf_ts_NewPara;
OnTable(Self, rvf_tbl_RowEnd);
OutStruct.TableFlags := 0;
end;
bFirstRunPass := true;
FFontTable.Items[0].Name := OutStruct.FontProps.FontName;
RTFState.CharProps.FSize := OutStruct.FontProps.FontSize;
RTFState.CharProps.FStyle := []; // clear all styles
RTFState.CharProps.FStyle := OutStruct.FontProps.FontStyle;
RTFState.CharProps.FColor := OutStruct.FontProps.FontColor;
RTFState.CharProps.FCharSpacingTw := OutStruct.FontProps.FCharSpacingTw;
RTFState.CharProps.FCharScaleX := OutStruct.FontProps.FCharScaleX;
RTFState.CharProps.FBackColor := OutStruct.FontProps.FBackColor;
RTFState.CharProps.FSScriptType:= TRVRTFSScriptType(OutStruct.FontProps.FSScriptType);
if OutStruct.ParaProps.bIsInList = 1 then
begin
RTFState.FParaProps.FListOverrideIndex := OutStruct.ParaProps.FListIndex;
b := FListTable[0].Items[OutStruct.ParaProps.FListIndex];//Reader.ListTable[i].Items[j]
//b := a.Items[OutStruct.ParaProps.FListIndex];
b.FFontSizeDefined := True;
b.FFontSize := 72;
end;
RTFState.FParaProps.FAlignment := RVRTF.TRVRTFAlignment(OutStruct.ParaProps.ParaAlignment);
RTFState.FParaProps.FFirstIndentTw := OutStruct.ParaProps.FFirstIndentTw;
RTFState.FParaProps.FLeftIndentTw := OutStruct.ParaProps.FLeftIndentTw;
RTFState.FParaProps.FRightIndentTw := OutStruct.ParaProps.FRightIndentTw;
RTFState.FParaProps.FSpaceBeforeTw := OutStruct.ParaProps.FSpaceBeforeTw;
RTFState.FParaProps.FSpaceAfterTw := OutStruct.ParaProps.FSpaceAfterTw;
RTFState.FParaProps.FLineSpacing := OutStruct.ParaProps.FLineSpacing;
RTFState.FParaProps.FColor := OutStruct.ParaProps.FColor;
RTFState.FParaProps.Border.Sides[rtf_side_Left].FBorderType := TRVRTFBorderType(OutStruct.ParaProps.FBorders.BrLeft.FBorderType);
RTFState.FParaProps.Border.Sides[rtf_side_Left].FWidthTw := OutStruct.ParaProps.FBorders.BrLeft.FWidthTw;
RTFState.FParaProps.Border.Sides[rtf_side_Left].FColor := OutStruct.ParaProps.FBorders.BrLeft.FColor;
RTFState.FParaProps.Border.Sides[rtf_side_Left].FSpaceTw := OutStruct.ParaProps.FBorders.BrLeft.FSpaceTw;
RTFState.FParaProps.Border.Sides[rtf_side_Right].FBorderType:= TRVRTFBorderType(OutStruct.ParaProps.FBorders.BrRight.FBorderType);
RTFState.FParaProps.Border.Sides[rtf_side_Right].FWidthTw := OutStruct.ParaProps.FBorders.BrRight.FWidthTw;
RTFState.FParaProps.Border.Sides[rtf_side_Right].FColor := OutStruct.ParaProps.FBorders.BrRight.FColor;
RTFState.FParaProps.Border.Sides[rtf_side_Right].FSpaceTw := OutStruct.ParaProps.FBorders.BrRight.FSpaceTw;
RTFState.FParaProps.Border.Sides[rtf_side_Top].FBorderType := TRVRTFBorderType(OutStruct.ParaProps.FBorders.BrTop.FBorderType);
RTFState.FParaProps.Border.Sides[rtf_side_Top].FWidthTw := OutStruct.ParaProps.FBorders.BrTop.FWidthTw;
RTFState.FParaProps.Border.Sides[rtf_side_Top].FColor := OutStruct.ParaProps.FBorders.BrTop.FColor;
RTFState.FParaProps.Border.Sides[rtf_side_Top].FSpaceTw := OutStruct.ParaProps.FBorders.BrTop.FSpaceTw;
RTFState.FParaProps.Border.Sides[rtf_side_Bottom].FBorderType:= TRVRTFBorderType(OutStruct.ParaProps.FBorders.BrBottom.FBorderType);
RTFState.FParaProps.Border.Sides[rtf_side_Bottom].FWidthTw := OutStruct.ParaProps.FBorders.BrBottom.FWidthTw;
RTFState.FParaProps.Border.Sides[rtf_side_Bottom].FColor := OutStruct.ParaProps.FBorders.BrBottom.FColor;
RTFState.FParaProps.Border.Sides[rtf_side_Bottom].FSpaceTw := OutStruct.ParaProps.FBorders.BrBottom.FSpaceTw;
// add some tabs if any
if (iTab = 0) and (OutStruct.ParaProps.FTabsCount>0) then begin
// make sure we have an empty tabs for this paragraph
if RTFState.FParaProps.FTabs <> nil then begin
RTFState.FParaProps.FTabs.Free;
RTFState.FParaProps.FTabs := nil;
end;
RTFState.FParaProps.FTabs := TRVRTFTabList.Create;
for i:=0 to OutStruct.ParaProps.FTabsCount-1 do begin
RTFState.FParaProps.FTabs.AddNew;
RTFState.FParaProps.FTabs.GetLastTab.FPositionTW := OutStruct.ParaProps.FTabsDescPtr[i].FPositionTW;
RTFState.FParaProps.FTabs.GetLastTab.FAlign := TRVRTFTabAlign(OutStruct.ParaProps.FTabsDescPtr[i].FAlign);
end;
RTFState.FParaProps.FTabs.AddNew;
end;
if (iTab >= OutStruct.ParaProps.FTabsCount) and (ParseRes=#09) then begin
if RTFState.FParaProps.FTabs = nil then
RTFState.FParaProps.FTabs := TRVRTFTabList.Create;
RTFState.FParaProps.FTabs.AddNew;
RTFState.FParaProps.FTabs.GetLastTab.FPositionTW := 720;
RTFState.FParaProps.FTabs.GetLastTab.FAlign := rtf_tab_Left;
RTFState.FParaProps.FTabs.AddNew;
end;
if (OutStruct.FontProps.SpChar<>'') then begin
TextW := OutStruct.FontProps.SpChar;
OutputChar(#0, False, True);
end
else begin
TextW := OutStruct.Text;
if (ParseRes = #12) then
begin
OutputChar(#10, True, True);
FOnRequiredPageBreak(Self);
end
else
OutputChar(ParseRes, False, False);
if ParseRes=#10 then
iTab := 0;
if ParseRes=#9 then
Inc(iTab);
end;
case TRVDOCTableEventKind(OutStruct.TableFlags) of
doc_tbl_TableStart:
begin
Position := rtf_ts_NewPara;
OnTable(Self, rvf_tbl_TableStart);
end;
doc_tbl_TableEnd:
begin
TGetRowProperties;
Position := rtf_ts_NewPara;
OnTable(Self, rvf_tbl_RowEnd);
OnTable(Self, rvf_tbl_TableEnd);
end;
doc_tbl_RowEnd:
begin
TGetRowProperties;
CheckTable(True);
Position := rtf_ts_NewPara;
OnTable(Self, rvf_tbl_RowEnd);
end;
doc_tbl_CellEnd:
begin
CheckTable(True);
OutputChar(ParseRes, True, True);
Position := rtf_ts_NewPara;
OnTable(Self, rvf_tbl_CellEnd);
end;
end;
end; // while...
WordDocumentFree(OutStruct);
end;
asm
mov al, InitResult
neg al
mov Result, al
end;
{$R+}
{$ENDIF}
end;
{$ENDIF}
{------------------------------------------------------------------------------}
// Isolate RTF keywords and send them to ParseRtfKeyword;
// Push and pop state at the start and end of RTF groups;
// Send text to ParseChar for further processing.
function TRVRTFReader.Parse: TRVRTFErrorCode;
var
cNibble,b,i: Integer;
ch: Char;
begin
cNibble := 2;
b := 0;
while not IsEOF do begin
ch := GetC;
if (cGroup < 0) then begin
Result := rtf_ec_StackUnderflow;
exit;
end;
if (FRTFState.ris = risBin) then begin // if we're parsing binary data, handle it directly
Result := ParseChar(ch);
if (Result <> rtf_ec_OK) then
exit;
end
else begin
case (ch) of
'{':
begin
SkipNext := 0;
Result := PushRtfState;
if (Result <> rtf_ec_OK) then
exit;
end;
'}':
begin
SkipNext := 0;
Result := PopRtfState;
if (Result <> rtf_ec_OK) then
exit;
if (cGroup=0) then
break;
end;
'':
begin
Result := ParseRtfKeyword;
if (Result <> rtf_ec_OK) then
exit;
end;
#$0d, #$0a: // cr and lf are noise characters...
begin
end;
else
begin
if (FRTFState.ris = risNorm) then begin
if SkipNext=0 then
Result := ParseChar(ch)
else begin
dec(SkipNext);
Result := rtf_ec_OK;
end;
if (Result <> rtf_ec_OK) then
exit;
end
else begin // parsing hex data
if (FRTFState.ris <> risHex) then begin
Result := rtf_ec_Assertion;
exit;
end;
b := b shl 4;
if (ch in ['0'..'9']) then
b := b + (ord(ch) - ord('0'))
else begin
if (ch in ['a'..'z']) then begin
if not (ch in ['a'..'f']) then begin
Result := rtf_ec_InvalidHex;
exit;
end;
b := b + 10+(ord(ch) - ord('a'));
end
else begin
if not (ch in ['A'..'F']) then begin
Result := rtf_ec_InvalidHex;
exit;
end;
b := b + 10+(ord(ch) - ord('A'));
end;
end;
dec(cNibble);
if (cNibble=0) then begin
if SkipNext=0 then
Result := ParseChar(Char(b))
else begin
dec(SkipNext);
Result := rtf_ec_OK;
end;
if (Result <> rtf_ec_OK) then
exit;
cNibble := 2;
b := 0;
FRTFState.ris := risNorm;
end;
end // end else (ris != risNorm)
end;
end; // case
end; // else (ris != risBin)
end; // while
UpdateMarker;
for i := CurrentNestingLevel downto 1 do
DoTable(rvf_tbl_TableEnd);
FColorTable.Finalize;
if (cGroup < 0) then
Result := rtf_ec_StackUnderflow
else if (cGroup > 0) then
Result := rtf_ec_UnmatchedBrace
else begin
if Text<>'' then
Result := OutputChar(#0,True,True)
else
Result := rtf_ec_OK;
end;
end;
{------------------------------------------------------------------------------}
// Save relevant info on a linked list of SAVE structures.
function TRVRTFReader.PushRtfState: TRVRTFErrorCode;
var SaveItem: TRVRTFReaderState;
begin
try
SaveItem := TRVRTFReaderState.Create;
except
SaveItem := nil;
end;
if (SaveItem=nil) then begin
Result := rtf_ec_StackOverflow;
exit;
end;
SaveItem.Assign(FRTFState);
SaveList.Add(SaveItem);
FRTFState.ris := risNorm;
inc(cGroup);
case FRTFState.rds of
rdsStyleSheet:
begin
FStyleSheet.AddPara(0);
FRTFState.rds := rdsStyleSheetEntry;
end;
end;
Result := rtf_ec_OK;
end;
{------------------------------------------------------------------------------}
// If we're ending a destination (that is, the destination is changing),
// call ecEndGroupAction.
// Always restore relevant info from the top of the SAVE list.
function TRVRTFReader.PopRtfState: TRVRTFErrorCode;
var SaveItem: TRVRTFReaderState;
CurRds: TRTFrds;
b: Boolean;
begin
if (SaveList.Count=0) then begin
Result := rtf_ec_StackUnderflow;
exit;
end;
if (SaveList.Count=1) then begin
UpdateMarker;
if Assigned(OnEndParsing) then
OnEndParsing(Self);
end;
SaveItem := TRVRTFReaderState(SaveList.Items[SaveList.Count-1]);
if (FRTFState.rds=rdsStyleSheetEntry) and (SaveItem.rds=rdsStyleSheet) then
FStyleSheet[FStyleSheet.Count-1].Assign(FRTFState);
if FRTFState.rds=rdsNorm then begin
Result := OutputChar(#0,False,False);
if Result<>rtf_ec_OK then
exit;
end;
CurRds := FRTFState.rds;
if CurRds <> SaveItem.rds then begin
Result := EndGroupAction(FRTFState.rds);
if (Result <> rtf_ec_OK) then
exit;
end;
if (FRTFState.FHFType<>SaveItem.FHFType) and
(FRTFState.FHFType in [rtf_hf_Header,rtf_hf_Footer]) and
Assigned(FOnHeaderFooter) then
FOnHeaderFooter(Self, FRTFState.FHFType, False, b);
FRTFState.Assign(SaveItem);
if (CurRds=rdsPN) and (FRTFState.rds<>rdsPN) and (FMarkerProps<>nil) then begin
FRTFState.ParaProps.MarkerProps.Assign(FMarkerProps, False);
FMarkerProps.Free;
FMarkerProps := nil;
end;
SaveList.Delete(SaveList.Count-1);
dec(cGroup);
Result := rtf_ec_OK;
end;
{------------------------------------------------------------------------------}
// get a control word (and its associated value) and
// call TranslateKeyword to dispatch the control.
function TRVRTFReader.ParseRtfKeyword: TRVRTFErrorCode;
var ch: Char;
fParam, fNeg: Boolean;
Keyword, szParameter: String;
{$IFDEF RVTEXTFOOTNOTES}
footnotetext : String;
footkeyword : String;
isym : Integer;
{$ENDIF}
begin
fParam := False;
fNeg := False;
lParam := 0;
//char *pch;
Keyword := '';
szParameter := '';
if IsEOF then begin
Result := rtf_ec_EndOfFile;
exit;
end;
ch := GetC;
if (not (ch in ['a'..'z','A'..'Z'])) then begin
// a control symbol; no delimiter.
Keyword := ch;
Result := TranslateKeyword(Keyword, 0, fParam);
exit;
end;
repeat
Keyword := Keyword + ch;
ch := GetC;
until (not (ch in ['a'..'z','A'..'Z'])) or IsEOF ;
if (ch = '-') then begin
fNeg := True;
ch := GetC;
end;
if (ch in ['0'..'9']) then begin
fParam := True; // a digit after the control means we have a parameter
repeat
szParameter := szParameter + ch;
ch := GetC;
until (not (ch in ['0'..'9'])) or IsEOF ;
lParam := StrToInt(szParameter);
if (fNeg) then
lParam := -lParam;
end;
{$IFDEF RVTEXTFOOTNOTES}
if keyword='footnote' then begin
repeat
ch := GetC;
until (ch=' ') or (ch='}');
footnotetext := '';
if ch <> '}' then begin
repeat
//need to parse any special characters out.
if ch = '' then begin
footKeyWord:='';
ch :=' ';
repeat
footKeyword := footKeyword + ch;
ch := GetC;
until (not (ch in ['a'..'z','A'..'Z'])) or IsEOF ;
isym := FindKeyword(trim(footKeyword));
ch := chr(rgsymRtf[isym].idx);
end;
footnotetext := footnotetext + ch;
ch := GetC;
until ch = '}';
trim(footnotetext);
end;
UngetC;
FRTFState.FCharProps.FFootnote:=footnotetext;
param:=1;
end;
{$ENDIF}
if (ch <> ' ') then
UngetC;
Result := TranslateKeyword(Keyword, lParam, fParam)
end;
{------------------------------------------------------------------------------}
// Route the character to the appropriate destination stream.
function TRVRTFReader.ParseChar(ch: Char): TRVRTFErrorCode;
{..............................................}
function AddChar(Stream: TMemoryStream; ch: Char): Boolean;
begin
Result := False;
PicHexVal := PicHexVal shl 4;
if (ch in ['0'..'9']) then
PicHexVal := PicHexVal + (ord(ch) - ord('0'))
else begin
if (ch in ['a'..'z']) then begin
if not (ch in ['a'..'f']) then
exit;
PicHexVal := PicHexVal + 10+(ord(ch) - ord('a'));
end
else begin
if not (ch in ['A'..'F']) then
exit;
PicHexVal := PicHexVal + 10+(ord(ch) - ord('A'));
end;
end;
if not PicHexStrt then begin
Stream.WriteBuffer(PicHexVal,1);
PicHexVal := 0;
end;
PicHexStrt := not PicHexStrt;
Result := True;
end;
{..............................................}
begin
Result := rtf_ec_OK;
case (FRTFState.rds) of
rdsSkip:
;
rdsStyleSheetEntry:
begin
if ch<>';' then
FStyleSheet[FStyleSheet.Count-1].FName := FStyleSheet[FStyleSheet.Count-1].Name+ch;
end;
rdsNorm:
begin
if (ch in [#$0a, #$0d]) and Assigned(FOnUpdateMarker) then
UpdateMarker;
Result := OutputChar(ch,True,True);
if (ch in [#$0a, #$0d]) and Assigned(FOnUpdateMarker) then
UpdateMarker;
end;
rdsFontTable:
begin
if ch<>';' then
FFontTable[FFontTable.Count-1].Name := FFontTable[FFontTable.Count-1].Name+ch;
end;
rdsColorTable:
begin
if ch=';' then
FColorTable.Add;
end;
rdsObjData:
begin
if FObject<>nil then
if FRTFState.ris = risBin then
FObject.FData.WriteBuffer(ch,1)
else if not AddChar(FObject.FData, ch) then
Result := rtf_ec_InvalidPicture;
end;
rdsPict:
begin
if FPicture<>nil then
if FRTFState.ris = risBin then
FPicture.FData.WriteBuffer(ch,1)
else if not AddChar(FPicture.FData, ch) then
Result := rtf_ec_InvalidPicture;
end;
rdsFldInst:
FRTFState.FFieldCode := FRTFState.FFieldCode+ch;
rdsPNTextAfter:
FMarkerProps.FTextAfter := FMarkerProps.FTextAfter+ch;
rdsPNTextBefore:
FMarkerProps.FTextBefore := FMarkerProps.FTextBefore+ch;
rdsListName:
FListTable.GetLastList.FName := FListTable.GetLastList.FName+ch;
rdsListLevelText:
with FListTable.GetLastList.GetLastLevel do begin
FText := FText+ch;
if FTextW<>'' then
{$IFDEF RICHVIEWCBDEF3}
FTextW := FTextW+AnsiToUnicode(ch, FCodePage);
{$ELSE}
FTextW := FTextW+ch;
{$ENDIF}
end;
rdsListLevelNumbers:
FListTable.GetLastList.GetLastLevel.FNumbers := FListTable.GetLastList.GetLastLevel.FNumbers+ch;
end;
if (FRTFState.ris = risBin) then begin
dec(cbBin);
if cbBin <= 0 then
FRTFState.ris := risNorm;
end;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFReader.UpdateMarker;
begin
if not Assigned(FOnUpdateMarker) then
exit;
if RTFState.ParaProps.HasMarker then
RTFState.ParaProps.MarkerProps.UpdateFrom(RTFState.CharProps);
FOnUpdateMarker(Self);
end;
{------------------------------------------------------------------------------}
function TRVRTFReader.FlushOutput(var NextPosition: TRVRTFPosition): TRVRTFErrorCode;
begin
{$IFDEF RICHVIEWCBDEF3}
if Length(TextW)>0 then
OutputWideChar(#0);
{$ENDIF}
Result := DoNewText(Position, NextPosition);
end;
{------------------------------------------------------------------------------}
{$IFDEF RICHVIEWCBDEF3}
function TRVRTFReader.OutputWideChar(ch: WideChar): TRVRTFErrorCode;
begin
Result := rtf_ec_OK;
case RTFState.rds of
rdsNorm:
begin
CheckTable(True);
if Assigned(FOnNewUnicodeText) then begin
if Text<>'' then
OutputChar(#0, False, False);
if ord(ch)>0 then begin
TextW := TextW+WideString(ch);
end;
end;
end;
rdsListLevelText:
begin
if FListTable.GetLastList.GetLastLevel.TextW='' then
FListTable.GetLastList.GetLastLevel.FTextW := AnsiToUnicode(FListTable.GetLastList.GetLastLevel.FText, FCodePage);
FListTable.GetLastList.GetLastLevel.FTextW := FListTable.GetLastList.GetLastLevel.FTextW+WideString(ch);
FListTable.GetLastList.GetLastLevel.FText := FListTable.GetLastList.GetLastLevel.FText+UnicodeToAnsi(ch);
end;
end;
end;
{$ENDIF}
{------------------------------------------------------------------------------}
function TRVRTFReader.OutputChar(ch: Char; ACheckTableEnd, ACheckTable: Boolean): TRVRTFErrorCode;
var NextPosition: TRVRTFPosition;
begin
if AcheckTable then
CheckTable(ACheckTableEnd);
if TabAsSeparateChar and (ch=#09) then begin
Result := OutputChar(#0, False, False);
if Result<>rtf_ec_OK then
exit;
Text := Text+ch;
Result := OutputChar(#0, False, False);
exit;
end;
if ch in [#0,#10,#13]then begin
case ch of
#10:
NextPosition := rtf_ts_NewPara;
#13:
NextPosition := rtf_ts_NewLine;
else
NextPosition := rtf_ts_ContinuePara;
end;
Result := FlushOutput(NextPosition);
if Result<>rtf_ec_OK then
exit;
if NextPosition<>rtf_ts_ContinuePara then
Position := NextPosition
else
case ch of
#10:
Position := rtf_ts_NewPara;
#13:
Position := rtf_ts_NewLine;
else
Position := rtf_ts_ContinuePara;
end;
end
else begin
{$IFDEF RICHVIEWCBDEF3}
if (TextW<>'') then begin
OutputChar(#0, False, False);
end;
{$ENDIF}
Text := Text+ch;
end;
Result := rtf_ec_OK;
end;
{------------------------------------------------------------------------------}
function TRVRTFReader.DoNewText(Position: TRVRTFPosition;
var NextPosition: TRVRTFPosition): TRVRTFErrorCode;
begin
Result := rtf_ec_OK;
if not ForceEvenEmptyNewLine and (Text='')
{$IFDEF RICHVIEWCBDEF3}
and (TextW='')
{$ENDIF}
then begin
if Position=rtf_ts_ContinuePara then
exit;
if NextPosition=rtf_ts_ContinuePara then begin
NextPosition := Position;
exit;
end;
end;
FRTFState.ParaProps.Finalize;
try
{$IFDEF RICHVIEWCBDEF3}
if Assigned(FOnNewUnicodeText) and (TextW<>'') then
FOnNewUnicodeText(Self,TextW,Position)
else
{$ENDIF}
if Assigned(FOnNewText) then
FOnNewText(Self, Text, Position);
except
Result := rtf_ec_Aborted;
end;
Text := '';
{$IFDEF RICHVIEWCBDEF3}
TextW := '';
{$ENDIF}
end;
{------------------------------------------------------------------------------}
function TRVRTFReader.ReadFromFile(const AFileName: String): TRVRTFErrorCode;
var Stream: TFileStream;
begin
Result := rtf_ec_FileOpenError;
try
Stream := TFileStream.Create(AFileName, fmOpenRead);
except
Stream := nil;
end;
if Stream<>nil then begin
Result := ReadFromStream(Stream);
Stream.Free;
end;
end;
{------------------------------------------------------------------------------}
{$IFDEF RVUSEWORDDOC}
function TRVRTFReader.ReadFromWordDocFile(const AFileName: String): TRVRTFErrorCode;
begin
Result := ParseWordDocFile(AFileName);
end;
{$ENDIF}
{------------------------------------------------------------------------------}
const BUFFERSIZE=4096;
function TRVRTFReader.ReadFromStream(AStream: TStream): TRVRTFErrorCode;
begin
Stream := AStream;
StreamSize := Stream.Size;
Clear;
SetLength(InputString, BUFFERSIZE);
InputStringIndex := BUFFERSIZE+1;
FCallProgress := (StreamSize>BUFFERSIZE*5) and Assigned(FOnProgress);
if FCallProgress then
FOnProgress(Self, rvprtfprStarting, 0);
try
Result := Parse;
except
Result := rtf_ec_Exception;
end;
InputString := '';
if FCallProgress then
FOnProgress(Self, rvprtfprEnding, 0);
end;
{------------------------------------------------------------------------------}
function TRVRTFReader.GetC: Char;
begin
if UseLastChar then begin
Result := LastChar;
UseLastChar := False;
exit;
end;
if InputStringIndex>Length(InputString) then begin
if FCallProgress then
FOnProgress(Self, rvprtfprRunning,
MulDiv(Stream.Position, 100, StreamSize));
if StreamSize-Stream.Position>=BUFFERSIZE then
Stream.ReadBuffer(PChar(InputString)^, BUFFERSIZE)
else begin
SetLength(InputString,StreamSize-Stream.Position);
Stream.ReadBuffer(PChar(InputString)^, Length(InputString))
end;
InputStringIndex := 1;
end;
Result := InputString[InputStringIndex];
LastChar := Result;
inc(InputStringIndex);
end;
{------------------------------------------------------------------------------}
procedure TRVRTFReader.UngetC;
begin
UseLastChar := True;
end;
{------------------------------------------------------------------------------}
function TRVRTFReader.IsEOF: Boolean;
begin
Result := not UseLastChar and (InputStringIndex>Length(InputString)) and (Stream.Position>=StreamSize);
end;
{------------------------------------------------------------------------------}
{$IFDEF RICHVIEWCBDEF3}
function TRVRTFReader.AnsiToUnicode(const s: String; CodePage: Cardinal): WideString;
var l: Integer;
begin
if Length(s)=0 then begin
Result := '';
exit;
end;
l := MultiByteToWideChar(CodePage,MB_PRECOMPOSED or MB_USEGLYPHCHARS, PChar(s), Length(s),
nil, 0);
if (l=0) and (CodePage<>CP_ACP) then begin
CodePage := CP_ACP;
l := MultiByteToWideChar(CodePage, MB_PRECOMPOSED or MB_USEGLYPHCHARS, PChar(s), Length(s),
nil, 0);
end;
if l<>0 then begin
SetLength(Result, l);
MultiByteToWideChar(CodePage, MB_PRECOMPOSED or MB_USEGLYPHCHARS, PChar(s), Length(s),
Pointer(Result), l);
end
else begin
SetLength(Result, Length(s));
for l := 0 to Length(s)-1 do
Result[l] := '?';
end;
end;
{------------------------------------------------------------------------------}
function TRVRTFReader.UnicodeToAnsi(const s: WideString): String;
var l: Integer;
DefChar: Char;
Flags: Integer;
Len: Integer;
CodePage: Cardinal;
begin
if Length(s)=0 then begin
Result := '';
exit;
end;
CodePage := FCodePage;
DefChar := '?';
Flags := WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR;
Len := Length(s);
l := WideCharToMultiByte(CodePage, Flags, Pointer(s), Len, nil, 0, @DefChar, nil);
if (l=0) and (CodePage<>CP_ACP) then begin
CodePage := CP_ACP;
l := WideCharToMultiByte(CodePage, Flags, Pointer(s), Len, nil, 0, @DefChar, nil);
end;
if l<>0 then begin
SetLength(Result, l);
WideCharToMultiByte(CodePage, Flags, Pointer(s), Len, PChar(Result), l, @DefChar, nil);
end
else begin
SetLength(Result, Len);
FillChar(PChar(Result)^, Len, '?');
end;
end;
{$ENDIF}
{============================ TRVRTFColorList =================================}
procedure TRVRTFColorList.Add;
begin
inherited Add(Pointer(clWindowText));
end;
{------------------------------------------------------------------------------}
procedure TRVRTFColorList.Finalize;
begin
if Count>0 then
Delete(Count-1);
end;
{------------------------------------------------------------------------------}
function TRVRTFColorList.Get(Index: Integer): TColor;
begin
Result := TColor(inherited Get(Index));
end;
{------------------------------------------------------------------------------}
procedure TRVRTFColorList.Put(Index: Integer; const Value: TColor);
begin
inherited Put(Index, Pointer(Value));
end;
{------------------------------------------------------------------------------}
procedure TRVRTFColorList.ResetLast;
begin
if Items[Count-1]=clWindowText then
Items[Count-1] := 0;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFColorList.SetLastBlue(Value: Integer);
begin
ResetLast;
Items[Count-1] := Items[Count-1] or (Value shl 16);
end;
{------------------------------------------------------------------------------}
procedure TRVRTFColorList.SetLastGreen(Value: Integer);
begin
ResetLast;
Items[Count-1] := Items[Count-1] or (Value shl 8);
end;
{------------------------------------------------------------------------------}
procedure TRVRTFColorList.SetLastRed(Value: Integer);
begin
ResetLast;
Items[Count-1] := Items[Count-1] or Value;
end;
{============================= TRVRTFFontList =================================}
function TRVRTFFontList.Get(Index: Integer): TRVRTFFont;
begin
Result := TRVRTFFont(inherited Get(Index));
end;
{------------------------------------------------------------------------------}
procedure TRVRTFFontList.Put(Index: Integer; const Value: TRVRTFFont);
begin
inherited Put(Index, Value);
end;
{------------------------------------------------------------------------------}
procedure TRVRTFFontList.RemoveChasetFromNames;
{$IFDEF RICHVIEWCBDEF3}
var i: Integer;
fontname,csname: String;
{$ENDIF}
begin
{$IFDEF RICHVIEWCBDEF3}
csname := '';
for i := 0 to Count-1 do begin
case Items[i].Charset of
RUSSIAN_CHARSET:
csname := 'cyr';
EASTEUROPE_CHARSET:
csname := 'ce';
GREEK_CHARSET:
csname := 'greek';
TURKISH_CHARSET:
csname := 'tur';
BALTIC_CHARSET:
csname := 'baltic';
else
continue;
end;
fontname := Items[i].Name;
if Length(fontname)<=Length(csname) then
continue;
if AnsiLowerCase(Copy(fontname, Length(fontname)-Length(csname), Length(csname)+1))=' '+csname then
Items[i].Name := Copy(fontname, 1, Length(fontname)-Length(csname)-1);
end;
{$ENDIF}
end;
{------------------------------------------------------------------------------}
function TRVRTFFontList.GetFontIndex(Number, Default: Integer): Integer;
var i: Integer;
begin
Result := -1;
for i := 0 to Count-1 do
if Items[i].Number=Number then begin
Result := i;
exit;
end;
if Number<>Default then
Result := GetFontIndex(Default, Default);
if Result<0 then
Result := 0;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFFontList.Add(Number: Integer);
var Item:TRVRTFFont;
begin
Item := TRVRTFFont.Create;
Item.Number := Number;
inherited Add(Item);
end;
{========================= TRVRTFTextProperties ================================}
constructor TRVRTFCharProperties.Create;
begin
inherited Create;
Reset(0,0);
end;
{------------------------------------------------------------------------------}
procedure TRVRTFCharProperties.Assign(Source: TRVRTFCharProperties);
begin
FSize := Source.Size;
FColor := Source.Color;
FBackColor := Source.BackColor;
FFontIndex := Source.FontIndex;
FStyle := Source.Style;
FStyleEx := Source.StyleEx;
FCharScaleX := Source.CharScaleX;
FSScriptType := Source.SScriptType;
FCharSpacingTw := Source.CharSpacingTw;
FHidden := Source.Hidden;
{$IFDEF RVTEXTFOOTNOTES}
FFootNote := Source.FootNote;
{$ENDIF}
end;
{------------------------------------------------------------------------------}
procedure TRVRTFCharProperties.Reset(DefLanguage: Cardinal; DefFontIndex: Integer);
begin
FSize := 12;
FColor := clWindowText;
FBackColor := clNone;
FFontIndex := DefFontIndex;
FStyle := [];
FStyleEx := [];
FCharScaleX := 100;
FSScriptType := rtf_ss_Normal;
FCharSpacingTw := 0;
FHidden := False;
FFontName := '';
FLanguage := DefLanguage;
{$IFDEF RVTEXTFOOTNOTES}
FFootNote := '';
{$ENDIF}
end;
{========================== TRVRTFParaProperties ==============================}
constructor TRVRTFParaProperties.Create;
begin
inherited Create;
Reset;
end;
{------------------------------------------------------------------------------}
destructor TRVRTFParaProperties.Destroy;
begin
FBorder.Free;
FMarkerProps.Free;
{$IFNDEF RVDONOTUSETABS}
FTabs.Free;
{$ENDIF}
inherited Destroy;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFParaProperties.Assign(Source: TRVRTFParaProperties);
begin
FLeftIndentTw := Source.LeftIndentTw;
FRightIndentTw := Source.RightIndentTw;
FFirstIndentTw := Source.FirstIndentTw;
FSpaceBeforeTw := Source.SpaceBeforeTw;
FSpaceAfterTw := Source.SpaceAfterTw;
FAlignment := Source.Alignment;
FColor := Source.Color;
FLineSpacing := Source.LineSpacing;
FLineSpacingMulti := Source.LineSpacingMulti;
if Source.FBorder<>nil then
Border.Assign(Source.FBorder)
else begin
FBorder.Free;
FBorder := nil;
end;
if Source.FMarkerProps<>nil then
MarkerProps.Assign(Source.FMarkerProps, False)
else begin
FMarkerProps.Free;
FMarkerProps := nil;
end;
FCurBorderSide := Source.FCurBorderSide;
FNestingLevel := Source.NestingLevel;
FInTable := Source.InTable;
NoTableEv := Source.NoTableEv;
NoResetLev := Source.NoResetLev;
FListOverrideIndex := Source.ListOverrideIndex;
FListLevel := Source.ListLevel;
Shading := Source.Shading;
ForeColor := Source.ForeColor;
FKeepLinesTogether := Source.KeepLinesTogether;
FKeepWithNext := Source.KeepWithNext;
{$IFNDEF RVDONOTUSETABS}
if Source.HasTabs then
Tabs.Assign(Source.FTabs)
else begin
FTabs.Free;
FTabs := nil;
end;
FTabsReady := Source.FTabsReady;
{$ENDIF}
end;
{------------------------------------------------------------------------------}
procedure TRVRTFParaProperties.Reset;
begin
FLeftIndentTw := 0;
FRightIndentTw := 0;
FFirstIndentTw := 0;
FSpaceBeforeTw := 0;
FSpaceAfterTw := 0;
FAlignment := rtf_al_Left;
FBorder.Free;
FBorder := nil;
FMarkerProps.Free;
FMarkerProps := nil;
FCurBorderSide := rtf_side_Left;
FColor := clNone;
FLineSpacing := 240; // single
FLineSpacingMulti := True; // / spacing
if not NoResetLev then begin
FNestingLevel := 1;
FInTable := False;
end;
NoTableEv := False;
NoResetLev := False;
FListOverrideIndex := -1;
FListLevel := 0;
Shading := 0;
ForeColor := clBlack;
FKeepLinesTogether := False;
FKeepWithNext := False;
{$IFNDEF RVDONOTUSETABS}
FTabs.Free;
FTabs := nil;
FTabsReady := False;
{$ENDIF}
end;
{------------------------------------------------------------------------------}
{$IFNDEF RVDONOTUSETABS}
function TRVRTFParaProperties.GetTabs: TRVRTFTabList;
begin
if FTabs=nil then
FTabs := TRVRTFTabList.Create;
Result := FTabs;
end;
{------------------------------------------------------------------------------}
function TRVRTFParaProperties.HasTabs: Boolean;
begin
Result := (FTabs<>nil) and (FTabs.Count>0);
end;
{$ENDIF}
{------------------------------------------------------------------------------}
function TRVRTFParaProperties.GetBorder: TRVRTFParaBorder;
begin
if FBorder=nil then
FBorder := TRVRTFParaBorder.Create;
Result := FBorder;
end;
{------------------------------------------------------------------------------}
function TRVRTFParaProperties.GetMarkerProps: TRVRTFMarkerProperties;
begin
if FMarkerProps=nil then
FMarkerProps := TRVRTFMarkerProperties.Create;
Result := FMarkerProps;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFParaProperties.Finalize;
{$IFNDEF RVDONOTUSETABS}
var i: Integer;
{$ENDIF}
begin
if Shading<>0 then begin
if (FColor=clNone) then
FColor := clWhite;
FColor := ShadeColor(ColorToRGB(Color), ColorToRGB(ForeColor), Shading);
Shading := 0;
end;
{$IFNDEF RVDONOTUSETABS}
if HasTabs and not FTabsReady then begin
Tabs.Delete(Tabs.Count-1);
for i := Tabs.Count-1 downto 0 do
if Tabs[i].IsListTab then
Tabs.Delete(i);
FTabsReady := True;
end;
{$ENDIF}
end;
{------------------------------------------------------------------------------}
function TRVRTFParaProperties.HasBorder: Boolean;
var i: TRVRTFSide;
begin
Result := (FBorder<>nil);
if Result then begin
Result := False;
for i := Low(TRVRTFSide) to High(TRVRTFSide) do
if (FBorder.FSides[i]<>nil) and (FBorder.FSides[i].FBorderType<>rtf_brdr_None) then begin
Result := True;
break;
end;
end;
end;
{------------------------------------------------------------------------------}
function TRVRTFParaProperties.HasMarker: Boolean;
begin
Result := (FMarkerProps<>nil);
end;
{========================== TRVRTFSectionProperties ===========================}
constructor TRVRTFSectionProperties.Create;
begin
inherited Create;
Reset;
end;
{------------------------------------------------------------------------------}
destructor TRVRTFSectionProperties.Destroy;
begin
FDefMarkerPropsList.Free;
inherited;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFSectionProperties.InitListDefaults;
var i: Integer;
begin
if FDefMarkerPropsList= nil then begin
FDefMarkerPropsList := TRVList.Create;
for i := 1 to 11 do
FDefMarkerPropsList.Add(TRVRTFMarkerProperties.Create);
end;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFSectionProperties.Assign(Source: TRVRTFSectionProperties);
var i: Integer;
begin
FColumnCount := Source.FColumnCount;
FPageNumberXTw := Source.FPageNumberXTw;
FPageNumberYTw := Source.FPageNumberYTw;
FPageNumberFormat := Source.FPageNumberFormat;
FSectionBreakType := Source.FSectionBreakType;
if Source.FDefMarkerPropsList=nil then begin
FDefMarkerPropsList.Free;
FDefMarkerPropsList := nil;
end
else begin
InitListDefaults;
for i := 1 to 11 do
TRVRTFMarkerProperties(FDefMarkerPropsList[i-1]).Assign(TRVRTFMarkerProperties(Source.FDefMarkerPropsList[i-1]), False);
end;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFSectionProperties.Reset;
begin
FColumnCount := 1;
FPageNumberXTw := 720;
FPageNumberYTw := 720;
FPageNumberFormat := rtf_pg_Decimal;
FSectionBreakType := rtf_sbk_Page;
FFooterYTw := 720;
FHeaderYTw := 720;
FDefMarkerPropsList.Free;
FDefMarkerPropsList := nil;
end;
{=========================== TRVRTFDocProperties ==============================}
constructor TRVRTFDocProperties.Create;
begin
inherited Create;
Reset;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFDocProperties.Assign(Source: TRVRTFDocProperties);
begin
FPaperWidthTw := Source.FPaperWidthTw;
FPaperHeightTw := Source.FPaperHeightTw;
FLeftMarginTw := Source.FLeftMarginTw;
FRightMarginTw := Source.FRightMarginTw;
FTopMarginTw := Source.FTopMarginTw;
FBottomMarginTw := Source.FBottomMarginTw;
FPageNumberStart := Source.FPageNumberStart;
FFacingPages := Source.FFacingPages;
FLandscape := Source.FLandscape;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFDocProperties.Reset;
begin
FPaperWidthTw := 12240;
FPaperHeightTw := 15480;
FLeftMarginTw := 1800;
FRightMarginTw := 1800;
FTopMarginTw := 1440;
FBottomMarginTw := 1440;
FPageNumberStart := 1;
FFacingPages := False;
FLandscape := False;
end;
{============================ TRVRTFStyleSheetEntry ============================}
constructor TRVRTFStyleSheetEntry.Create;
begin
inherited Create;
FParaProps := TRVRTFParaProperties.Create;
FCharProps := TRVRTFCharProperties.Create;
FAdditive := False;
FHidden := False;
FStyleType := rtf_sst_Char;
FNumber := 0;
FBasedOn := nil;
FNext := Self;
end;
{------------------------------------------------------------------------------}
destructor TRVRTFStyleSheetEntry.Destroy;
begin
FParaProps.Free;
FCharProps.Free;
inherited Destroy;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFStyleSheetEntry.Assign(Source: TRVRTFReaderState);
begin
FParaProps.Assign(Source.ParaProps);
FCharProps.Assign(Source.CharProps);
end;
{============================ TRVRTFStyleSheet ================================}
procedure TRVRTFStyleSheet.AddPara(Number: Integer);
var item: TRVRTFStyleSheetEntry;
begin
item := TRVRTFStyleSheetEntry.Create;
item.FNumber := Number;
item.FStyleType := rtf_sst_Par;
Add(item);
end;
{------------------------------------------------------------------------------}
function TRVRTFStyleSheet.Get(Index: Integer): TRVRTFStyleSheetEntry;
begin
Result := TRVRTFStyleSheetEntry(inherited Get(Index));
end;
{------------------------------------------------------------------------------}
function TRVRTFStyleSheet.GetEntry(Number: Integer): TRVRTFStyleSheetEntry;
var i: Integer;
begin
Result := nil;
for i := 0 to Count-1 do
if Items[i].Number = Number then begin
Result := Items[i];
break;
end;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFStyleSheet.Put(Index: Integer;
const Value: TRVRTFStyleSheetEntry);
begin
inherited Put(Index, Value);
end;
{========================= TRVRTFReaderState ==================================}
constructor TRVRTFReaderState.Create;
begin
inherited Create;
FParaProps := TRVRTFParaProperties.Create;
FCharProps := TRVRTFCharProperties.Create;
FSectProps := TRVRTFSectionProperties.Create;
FDocProps := TRVRTFDocProperties.Create;
end;
{------------------------------------------------------------------------------}
destructor TRVRTFReaderState.Destroy;
begin
FParaProps.Free;
FCharProps.Free;
FSectProps.Free;
FDocProps.Free;
FRowProps.Free;
FInvalidFieldPicture.Free;
inherited Destroy;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFReaderState.Assign(Source: TRVRTFReaderState);
begin
ParaProps.Assign(Source.ParaProps);
CharProps.Assign(Source.CharProps);
FSectProps.Assign(Source.SectProps);
FDocProps.Assign(Source.DocProps);
FDefLanguage := Source.FDefLanguage;
if Source.FRowProps<>nil then begin
if FRowProps=nil then
FRowProps := TRVRTFRowProperties.Create;
FRowProps.Assign(Source.FRowProps);
end
else begin
FRowProps.Free;
FRowProps := nil;
end;
rds := Source.rds;
ris := Source.ris;
FCurrentBorderType := Source.FCurrentBorderType;
FHFType := Source.FHFType;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFReaderState.ChangeFontStyle(fs: TFontStyle; Val: Integer);
begin
if Val=0 then
Exclude(CharProps.FStyle, fs)
else
Include(CharProps.FStyle, fs);
end;
{------------------------------------------------------------------------------}
procedure TRVRTFReaderState.ChangeFontStyleEx(fs: TRVRTFFontStyleEx;
Val: Integer);
begin
if Val=0 then
Exclude(CharProps.FStyleEx, fs)
else
Include(CharProps.FStyleEx, fs);
end;
{------------------------------------------------------------------------------}
procedure TRVRTFReaderState.Reset;
begin
FDefLanguage := 0;
CharProps.Reset(DefLanguage, 0);
ParaProps.Reset;
SectProps.Reset;
DocProps.Reset;
FRowProps.Free;
FRowProps := nil;
FFieldCode := '';
FFieldPictureIncluded := False;
FCurrentBorderType := rtf_bt_Para;
DefFontNumber := 0;
DefFontIndex := -1;
FHFType := rtf_hf_MainText;
FInvalidFieldPicture.Free;
FInvalidFieldPicture := nil;
end;
{------------------------------------------------------------------------------}
function TRVRTFReaderState.GetRowProps: TRVRTFRowProperties;
begin
if FRowProps=nil then
FRowProps := TRVRTFRowProperties.Create;
Result := FRowProps;
end;
{------------------------------------------------------------------------------}
function TRVRTFReaderState.GetCurrentBorderSide: TRVRTFBorderSide;
begin
case FCurrentBorderType of
rtf_bt_Row:
Result := RowProps.Border.Sides[RowProps.FCurBorderSide];
rtf_bt_Cell:
Result := RowProps.GetLastCellProp.Border.Sides[RowProps.GetLastCellProp.FCurBorderSide];
else
Result := ParaProps.Border.Sides[ParaProps.FCurBorderSide];
end;
end;
{============================== TRVRTFBorderSide ==============================}
procedure TRVRTFBorderSide.Assign(Source: TRVRTFBorderSide);
begin
FBorderType := Source.BorderType;
FWidthTw := Source.WidthTw;
FColor := Source.Color;
FSpaceTw := Source.SpaceTw;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFBorderSide.Reset;
begin
FBorderType := rtf_brdr_None;
FWidthTw := 0;
FColor := clNone;
FSpaceTw := 0;
end;
{============================== TRVRTFParaBorder ==============================}
destructor TRVRTFParaBorder.Destroy;
var i: TRVRTFSide;
begin
for i := Low(TRVRTFSide) to High(TRVRTFSide) do
FSides[i].Free;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFParaBorder.Assign(Source: TRVRTFParaBorder);
var i: TRVRTFSide;
begin
for i := Low(TRVRTFSide) to High(TRVRTFSide) do
if Source.FSides[i]=nil then begin
FSides[i].Free;
FSides[i] := nil;
end
else
Sides[i].Assign(Source.FSides[i]);
end;
{------------------------------------------------------------------------------}
procedure TRVRTFParaBorder.Reset;
var i: TRVRTFSide;
begin
for i := Low(TRVRTFSide) to High(TRVRTFSide) do
if FSides[i]<>nil then
FSides[i].Reset;
end;
{------------------------------------------------------------------------------}
function TRVRTFParaBorder.GetSides(Index: TRVRTFSide): TRVRTFBorderSide;
begin
if FSides[Index]=nil then
FSides[Index] := TRVRTFBorderSide.Create;
Result := FSides[Index];
end;
{============================= TRVRTFPicture ==================================}
constructor TRVRTFPicture.Create;
begin
inherited Create;
FData := TMemoryStream.Create;
FPicScaleX := 100;
FPicScaleY := 100;
FWBMBitsPixel := 1;
FWBMPlanes := 1;
end;
{------------------------------------------------------------------------------}
destructor TRVRTFPicture.Destroy;
begin
FData.Free;
inherited Destroy;
end;
{============================== TRVRTFObject ==================================}
constructor TRVRTFObject.Create;
begin
inherited;
FData := TMemoryStream.Create;
end;
{------------------------------------------------------------------------------}
destructor TRVRTFObject.Destroy;
begin
FData.Free;
inherited;
end;
{============================ TRVRTFRowProperties =============================}
constructor TRVRTFRowProperties.Create;
begin
inherited Create;
FBorder := TRVRTFParaBorder.Create;
FCellProps := TRVRTFCellPropsList.Create;
Reset;
end;
{------------------------------------------------------------------------------}
destructor TRVRTFRowProperties.Destroy;
begin
FBorder.Free;
CellProps.Free;
inherited Destroy;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFRowProperties.Reset;
var side: TRVRTFSide;
begin
FGapHTw := 0;
FLeftTw := 0;
FHeightTw := 0;
FBestWidth := 0;
for side := Low(TRVRTFSide) to High(TRVRTFSide) do begin
FPaddingTw[side] := 0;
FSpacingTw[side] := 0;
FUsePadding[side] := False;
FUseSpacing[side] := False;
end;
FCurBorderSide := rtf_side_Left;
FBorder.Reset;
FCellProps.Clear;
FCellProps.AddNew;
NewCellProps := True;
AssumedLastCell := True;
FHeading := False;
{$IFDEF RICHVIEW}
RichViewSpecial := False;
{$ENDIF}
end;
{------------------------------------------------------------------------------}
procedure TRVRTFRowProperties.Assign(Source: TRVRTFRowProperties);
var side: TRVRTFSide;
begin
FGapHTw := Source.FGapHTw;
FLeftTw := Source.FLeftTw;
FHeightTw := Source.FHeightTw;
FBestWidth := Source.FBestWidth;
FCurBorderSide := Source.FCurBorderSide;
for side := Low(TRVRTFSide) to High(TRVRTFSide) do begin
FPaddingTw[side] := Source.FPaddingTw[side];
FSpacingTw[side] := Source.FSpacingTw[side];
FUsePadding[side] := Source.FUsePadding[side];
FUseSpacing[side] := Source.FUseSpacing[side];
end;
NewCellProps := Source.NewCellProps;
AssumedLastCell := Source.AssumedLastCell;
FBorder.Assign(Source.FBorder);
FCellProps.AssignItems(Source.FCellProps);
{$IFDEF RICHVIEW}
RichViewSpecial := Source.RichViewSpecial;
{$ENDIF}
end;
{------------------------------------------------------------------------------}
procedure TRVRTFRowProperties.Finalize;
var i: Integer;
begin
if AssumedLastCell then begin
CellProps.Delete(CellProps.Count-1);
AssumedLastCell := False;
end;
if NewCellProps then begin
for i := 0 to CellProps.Count-1 do
CellProps[i].Finalize;
NewCellProps := False;
end;
end;
{------------------------------------------------------------------------------}
function TRVRTFRowProperties.GetPaddingTw(Index: TRVRTFSide): Integer;
begin
Result := FPaddingTW[Index];
end;
{------------------------------------------------------------------------------}
function TRVRTFRowProperties.GetSpacingTw(Index: TRVRTFSide): Integer;
begin
Result := FSpacingTW[Index];
end;
{------------------------------------------------------------------------------}
function TRVRTFRowProperties.GetUsePadding(Index: TRVRTFSide): Boolean;
begin
Result := FUsePadding[Index];
end;
{------------------------------------------------------------------------------}
function TRVRTFRowProperties.GetUseSpacing(Index: TRVRTFSide): Boolean;
begin
Result := FUseSpacing[Index];
end;
{------------------------------------------------------------------------------}
function TRVRTFRowProperties.GetLastCellProp: TRVRTFCellProperties;
begin
//AssumedLastCell := False;
Result := CellProps[CellProps.Count-1];
end;
{============================ TRVRTFCellProperties ============================}
constructor TRVRTFCellProperties.Create;
begin
inherited Create;
FBorder := TRVRTFParaBorder.Create;
Reset;
end;
{------------------------------------------------------------------------------}
destructor TRVRTFCellProperties.Destroy;
begin
FBorder.Free;
inherited Destroy;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFCellProperties.Reset;
begin
FHMerge := rtf_cm_None;
FVMerge := rtf_cm_None;
FBestWidth := 0;
FColor := clNone;
FVAlign := rtf_val_Top;
FCurBorderSide := rtf_side_Left;
FRightBoundaryTw := 0;
ForeColor := clBlack;
Shading := 0;
FBorder.Reset;
{$IFDEF RICHVIEW}
BestHeight := 0;
{$ENDIF}
end;
{------------------------------------------------------------------------------}
procedure TRVRTFCellProperties.Assign(Source: TRVRTFCellProperties);
begin
FHMerge := Source.FHMerge;
FVMerge := Source.FVMerge;
FBestWidth := Source.FBestWidth;
FColor := Source.FColor;
FVAlign := Source.FVAlign;
FCurBorderSide := Source.FCurBorderSide;
FRightBoundaryTw := Source.FRightBoundaryTw;
ForeColor := Source.ForeColor;
Shading := Source.Shading;
FBorder.Assign(Source.FBorder);
{$IFDEF RICHVIEW}
BestHeight := Source.BestHeight;
{$ENDIF}
end;
{------------------------------------------------------------------------------}
procedure TRVRTFCellProperties.Finalize;
begin
if (Shading>0) then begin
if (FColor=clNone) then
FColor := clWhite;
FColor := ShadeColor(ColorToRGB(Color), ColorToRGB(ForeColor), Shading);
Shading := 0;
end;
end;
{=========================== TRVRTFCellPropsList ==============================}
procedure TRVRTFCellPropsList.AddNew;
var item: TRVRTFCellProperties;
begin
item := TRVRTFCellProperties.Create;
Add(item);
end;
{------------------------------------------------------------------------------}
procedure TRVRTFCellPropsList.AssignItems(Source: TRVRTFCellPropsList);
var i: Integer;
item: TRVRTFCellProperties;
begin
Clear;
Capacity := Source.Count;
for i := 0 to Source.Count-1 do begin
item := TRVRTFCellProperties.Create;
item.Assign(Source[i]);
Add(item);
end;
end;
{------------------------------------------------------------------------------}
function TRVRTFCellPropsList.Get(Index: Integer): TRVRTFCellProperties;
begin
Result := TRVRTFCellProperties(inherited Get(Index));
end;
{------------------------------------------------------------------------------}
procedure TRVRTFCellPropsList.Put(Index: Integer;
const Value: TRVRTFCellProperties);
begin
inherited Put(Index, Value);
end;
{============================ TRVRTFCustomMarkerProperties ====================}
constructor TRVRTFCustomMarkerProperties.Create;
begin
inherited Create;
Reset;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFCustomMarkerProperties.Assign(Source: TRVRTFCustomMarkerProperties; FromDefaults: Boolean);
procedure UpdateStyle(Fixed: TRVRTFMarkerProp; Style: TFontStyle);
begin
if not (Fixed in Source.FFixedProperties) then
if Style in Source.FontStyle then
Include(FFontStyle, Style)
else
Exclude(FFontStyle, Style);
end;
begin
FListType := Source.FListType;
FAlignment := Source.FAlignment;
FIndentTw := Source.FIndentTw;
FSpaceTw := Source.FSpaceTw;
FStart := Source.FStart;
FFixedProperties := Source.FFixedProperties;
if not FromDefaults then begin
FFontIndex := Source.FFontIndex;
FFontStyle := Source.FFontStyle;
FColor := Source.FColor;
FFontSize := Source.FFontSize;
end
else begin
if not (rtfmp_Color in FFixedProperties) then
FColor := Source.Color;
if not (rtfmp_FontIndex in FFixedProperties) then
FFontIndex := Source.FontIndex;
if not (rtfmp_Size in FFixedProperties) then
FFontSize := Source.FontSize;
UpdateStyle(rtfmp_Bold, fsBold);
UpdateStyle(rtfmp_Italic, fsItalic);
UpdateStyle(rtfmp_Underline, fsUnderline);
UpdateStyle(rtfmp_StrikeOut, fsStrikeOut);
end;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFCustomMarkerProperties.Reset;
begin
FListType := rtf_pn_Default;
FFontIndex := -1;
FFontStyle := [];
FColor := clWindowText;
FFontSize := 12;
FAlignment := rtf_al_Left;
FIndentTw := 0;
FSpaceTw := 0;
FStart := 0;
FFixedProperties := [];
end;
{------------------------------------------------------------------------------}
procedure TRVRTFCustomMarkerProperties.UpdateFrom(
CharProps: TRVRTFCharProperties);
procedure UpdateStyle(Fixed: TRVRTFMarkerProp; Style: TFontStyle);
begin
if not (Fixed in FFixedProperties) then
if Style in CharProps.Style then
Include(FFontStyle, Style)
else
Exclude(FFontStyle, Style);
end;
begin
if not (rtfmp_Color in FFixedProperties) then
FColor := CharProps.Color;
if not (rtfmp_FontIndex in FFixedProperties) then
FFontIndex := CharProps.FontIndex;
if not (rtfmp_Size in FFixedProperties) then
FFontSize := CharProps.Size;
UpdateStyle(rtfmp_Bold, fsBold);
UpdateStyle(rtfmp_Italic, fsItalic);
UpdateStyle(rtfmp_StrikeOut, fsStrikeOut);
end;
{------------------------------------------------------------------------------}
procedure TRVRTFCustomMarkerProperties.ChangeFontStyle(fs: TFontStyle;
Val: Integer);
begin
if Val=0 then
Exclude(FFontStyle, fs)
else
Include(FFontStyle, fs);
end;
{=========================== TRVRTFMarkerProperties ===========================}
procedure TRVRTFMarkerProperties.Assign(Source: TRVRTFMarkerProperties; FromDefaults: Boolean);
begin
inherited Assign(Source, FromDefaults);
FTextAfter := Source.FTextAfter;
FTextBefore := Source.FTextBefore;
FHanging := Source.FHanging;
if not FromDefaults then
FLevel := Source.FLevel;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFMarkerProperties.Reset;
begin
inherited Reset;
FLevel := 0;
FTextAfter := '';
FTextBefore := '';
FHanging := False;
end;
{============================== TRVRTFListLevel97 =============================}
procedure TRVRTFListLevel97.Assign(Source: TRVRTFListLevel97);
begin
inherited Assign(Source, False);
FOldStyle := Source.FOldStyle;
FLegal := Source.FLegal;
FNoRestart:= Source.FNoRestart;
FText := Source.FText;
FNumbers := Source.FNumbers;
FFollow := Source.FFollow;
FIndentsUpdated := Source.FIndentsUpdated;
end;
{------------------------------------------------------------------------------}
procedure TRVRTFListLevel97.Reset;
begin
inherited;
FOldStyle := False;
FLegal := False;
FNoRestart:= False;
FText := '';
FNumbers := '';
FFollow := rtf_lf_Tab;
FFontSizeDefined := False;
FIndentsUpdated := False;
end;
{============================== TRVRTFList97 ==================================}
procedure TRVRTFList97.AddNew;
begin
Add(TRVRTFListLevel97.Create);
end;
{------------------------------------------------------------------------------}
function TRVRTFList97.Get(Index: Integer): TRVRTFListLevel97;
begin
Result := TRVRTFListLevel97(inherited Get(Index));
end;
{------------------------------------------------------------------------------}
function TRVRTFList97.GetLastLevel: TRVRTFListLevel97;
begin
Result := Items[Count-1];
end;
{------------------------------------------------------------------------------}
procedure TRVRTFList97.Put(Index: Integer; const Value: TRVRTFListLevel97);
begin
inherited Put(Index, Value);
end;
{============================== TRVRTFListTable97 =============================}
procedure TRVRTFListTable97.AddNew;
begin
Add(TRVRTFList97.Create);
end;
{------------------------------------------------------------------------------}
function TRVRTFListTable97.FindList(ID: Integer): Integer;
var i: Integer;
begin
for i := 0 to Count-1 do
if Items[i].Id = ID then begin
Result := i;
exit;
end;
Result := -1;
end;
{------------------------------------------------------------------------------}
function TRVRTFListTable97.Get(Index: Integer): TRVRTFList97;
begin
Result := TRVRTFList97(inherited Get(Index));
end;
{------------------------------------------------------------------------------}
function TRVRTFListTable97.GetLastList: TRVRTFList97;
begin
Result := Items[Count-1];
end;
{------------------------------------------------------------------------------}
procedure TRVRTFListTable97.Put(Index: Integer; const Value: TRVRTFList97);
begin
inherited Put(Index, Value);
end;
{============================ TRVRTFListOverrideLevel =========================}
constructor TRVRTFListOverrideLevel97.Create;
begin
inherited Create;
FStart := 1;
end;
{============================= TRVRTFListOverride97 ===========================}
procedure TRVRTFListOverride97.AddNew;
begin
Add(TRVRTFListOverrideLevel97.Create);
end;
{------------------------------------------------------------------------------}
function TRVRTFListOverride97.GetLastLevel: TRVRTFListOverrideLevel97;
begin
Result := Items[Count-1];
end;
{------------------------------------------------------------------------------}
function TRVRTFListOverride97.Get(Index: Integer): TRVRTFListOverrideLevel97;
begin
Result := TRVRTFListOverrideLevel97(inherited Get(Index));
end;
{------------------------------------------------------------------------------}
procedure TRVRTFListOverride97.Put(Index: Integer;
const Value: TRVRTFListOverrideLevel97);
begin
inherited Put(Index, Value);
end;
{=========================== TRVRTFListOverrideTable97 ========================}
procedure TRVRTFListOverrideTable97.AddNew;
begin
Add(TRVRTFListOverride97.Create);
end;
{------------------------------------------------------------------------------}
function TRVRTFListOverrideTable97.FindListOverride(Number: Integer): Integer;
var i: Integer;
begin
for i := 0 to Count-1 do
if Items[i].Number = Number then begin
Result := i;
exit;
end;
Result := -1;
end;
{------------------------------------------------------------------------------}
function TRVRTFListOverrideTable97.Get(
Index: Integer): TRVRTFListOverride97;
begin
Result := TRVRTFListOverride97(inherited Get(Index));
end;
{------------------------------------------------------------------------------}
function TRVRTFListOverrideTable97.GetLastListOverride: TRVRTFListOverride97;
begin
Result := Items[Count-1];
end;
{------------------------------------------------------------------------------}
procedure TRVRTFListOverrideTable97.Put(Index: Integer;
const Value: TRVRTFListOverride97);
begin
inherited Put(Index, Value);
end;
{================================== TRVRTFFont ================================}
constructor TRVRTFFont.Create;
begin
inherited;
{$IFDEF RICHVIEWCBDEF3}
Charset := DEFAULT_CHARSET;
{$ENDIF}
end;
{================================ TRVRTFTab ===================================}
{$IFNDEF RVDONOTUSETABS}
procedure TRVRTFTab.Assign(Source: TRVRTFTab);
begin
FPositionTW := Source.PositionTW;
FAlign := Source.Align;
FLeader := Source.Leader;
FIsListTab := Source.IsListTab;
end;
{============================== TRVRTFTabList =================================}
procedure TRVRTFTabList.AddNew;
var Item: TRVRTFTab;
begin
Item := TRVRTFTab.Create;
Add(Item);
end;
{------------------------------------------------------------------------------}
function TRVRTFTabList.GetLastTab: TRVRTFTab;
begin
Result := Items[Count-1];
end;
{------------------------------------------------------------------------------}
function TRVRTFTabList.Get(Index: Integer): TRVRTFTab;
begin
Result := TRVRTFTab(inherited Get(Index));
end;
{------------------------------------------------------------------------------}
procedure TRVRTFTabList.Put(Index: Integer; const Value: TRVRTFTab);
begin
inherited Put(Index, Value);
end;
{------------------------------------------------------------------------------}
procedure TRVRTFTabList.Assign(Source: TRVRTFTabList);
var i: Integer;
begin
Clear;
if Source=nil then
exit;
Capacity := Source.Count;
for i := 0 to Source.Count-1 do begin
AddNew;
Items[i].Assign(Source[i]);
end;
end;
{$ENDIF}
{==============================================================================}
procedure QSort(L, R: Integer);
var
I, J: Integer;
P: TRVRTFsymbol;
T: TRVRTFsymbol;
begin
repeat
I := L;
J := R;
P := rgsymRtf[(L + R) shr 1];
repeat
while rgsymRtf[I].Keyword < P.Keyword do
inc(I);
while rgsymRtf[J].Keyword > P.Keyword do
dec(J);
if I <= J then begin
T := rgsymRtf[I];
rgsymRtf[I] := rgsymRtf[J];
rgsymRtf[J] := T;
inc(I);
dec(J);
end;
until I > J;
if L < J then
QSort(L, J);
L := I;
until I >= R;
end;
const KWSorted: Boolean = False;
procedure SortKeywords;
begin
if KWSorted then
exit;
KWSorted := True;
QSort(0,isymMax);
end;
{$IFNDEF RICHVIEW}
{------------------------------------------------------------------------------}
function RV_CreateGraphicsDefault(GraphicClass: TGraphicClass): TGraphic;
begin
Result := GraphicClass.Create;
end;
{------------------------------------------------------------------------------}
procedure RV_AfterImportGraphicDefault(Graphic: TGraphic);
begin
end;
initialization
RV_CreateGraphics := RV_CreateGraphicsDefault;
RV_AfterImportGraphic := RV_AfterImportGraphicDefault;
{$ENDIF}
end.