2279 lines
64 KiB
ObjectPascal
2279 lines
64 KiB
ObjectPascal
{
|
|
Version 11.9
|
|
Copyright (c) 1995-2008 by L. David Baldwin
|
|
Copyright (c) 2008-2018 by HtmlViewer Team
|
|
|
|
Permission is hereby granted, free of charge, to any person obtaining a copy of
|
|
this software and associated documentation files (the "Software"), to deal in
|
|
the Software without restriction, including without limitation the rights to
|
|
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
|
|
of the Software, and to permit persons to whom the Software is furnished to do
|
|
so, subject to the following conditions:
|
|
|
|
The above copyright notice and this permission notice shall be included in all
|
|
copies or substantial portions of the Software.
|
|
|
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
|
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
|
|
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
|
|
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
|
|
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
|
|
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
|
|
|
Note that the source modules HTMLGIF1.PAS and DITHERUNIT.PAS
|
|
are covered by separate copyright notices located in those modules.
|
|
}
|
|
|
|
{$I frxHTMLCons.inc}
|
|
|
|
unit frxHTMLUn2;
|
|
|
|
interface
|
|
|
|
uses
|
|
{$ifdef UseInline}
|
|
Math,
|
|
{$endif}
|
|
{$ifdef LCL}
|
|
LclIntf, IntfGraphics, FpImage, LclType, LResources, LMessages, frxHTMLMisc,
|
|
{$else}
|
|
Windows,
|
|
{$endif}
|
|
SysUtils, Contnrs, Classes, Graphics, ClipBrd, Messages, Variants, Types,
|
|
{$ifdef Compiler20_Plus}
|
|
CommCtrl,
|
|
{$endif}
|
|
frxHTMLBuffer,
|
|
frxGif2,
|
|
frxHTMLGlobals,
|
|
frxHTMLImages,
|
|
frxHTMLStyleTypes,
|
|
frxHTMLSymb;
|
|
|
|
const
|
|
VersionNo = '11.9';
|
|
MaxHScroll = 100000; {max horizontal display in pixels}
|
|
Tokenleng = 300;
|
|
TopLim = -200; {drawing limits}
|
|
BotLim = 5000;
|
|
FmCtl = WideChar(#2);
|
|
ImgPan = WideChar(#4);
|
|
BrkCh = WideChar(#8);
|
|
htDefFontName = 'Serif';
|
|
htDefPreFontName = 'Monospace';
|
|
|
|
|
|
type
|
|
// BG, 26.12.2011:
|
|
TWidthType = (
|
|
wtNone,
|
|
wtAbsolute,
|
|
wtPercent,
|
|
wtRelative);
|
|
|
|
// BG, 26.12.2011:
|
|
TSpecWidth = record
|
|
Value: Integer;
|
|
VType: TWidthType; // treat wtNone like "0*" (Value = 0.0, CType = wtRelative)
|
|
end;
|
|
|
|
ThtJustify = (NoJustify, Left, Centered, Right, FullJustify);
|
|
ThtDirection = (diLTR, diRTL, diAuto);
|
|
TRowType = (THead, TBody, TFoot);
|
|
|
|
//------------------------------------------------------------------------------
|
|
// tag attributes
|
|
//------------------------------------------------------------------------------
|
|
|
|
TfrxHtAttribute = class {holds a tag attribute}
|
|
public
|
|
Which: TAttrSymb; {symbol of attribute such as HrefSy}
|
|
WhichName: ThtString;
|
|
Value: Integer; {numeric value if appropriate}
|
|
DblValue: Double; {numeric value if appropriate}
|
|
Name: ThtString; {ThtString (mixed case), value after '=' sign}
|
|
CodePage: Integer;
|
|
constructor Create(ASym: TAttrSymb; const AValue: Double; const NameStr, ValueStr: ThtString; ACodePage: Integer);
|
|
constructor CreateCopy(ASource: TfrxHtAttribute);
|
|
property AsString: ThtString read Name;
|
|
property AsInteger: Integer read Value;
|
|
property AsDouble: Double read DblValue;
|
|
end;
|
|
|
|
TfrxHtAttributeList = class(TObjectList) {a list of tag attributes,(TAttributes)}
|
|
private
|
|
SaveID: ThtString;
|
|
function GetClass: ThtString;
|
|
function GetID: ThtString;
|
|
function GetTitle: ThtString;
|
|
function GetAttribute(Index: Integer): TfrxHtAttribute; {$ifdef UseInline} inline; {$endif}
|
|
public
|
|
constructor CreateCopy(ASource: TfrxHtAttributeList);
|
|
function Clone: TfrxHtAttributeList; virtual;
|
|
procedure Clear; override;
|
|
function Find(const Name: ThtString; var T: TfrxHtAttribute): Boolean; overload; {$ifdef UseInline} inline; {$endif}
|
|
function Find(Sy: TAttrSymb; var T: TfrxHtAttribute): Boolean; overload; {$ifdef UseInline} inline; {$endif}
|
|
function CreateStringList: ThtStringList;
|
|
property TheClass: ThtString read GetClass;
|
|
property TheID: ThtString read GetID;
|
|
property TheTitle: ThtString read GetTitle;
|
|
property Items[Index: Integer]: TfrxHtAttribute read GetAttribute; default;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
//
|
|
//------------------------------------------------------------------------------
|
|
|
|
TfrxHtFontObjBaseList = class;
|
|
|
|
{holds start and end point of URL text}
|
|
TutText = record //BG, 03.03.2011: changed to record. no need to use a class
|
|
Start: Integer;
|
|
Last: Integer;
|
|
end;
|
|
|
|
TfrxHtUrlTarget = class
|
|
public
|
|
URL: ThtString;
|
|
Target: ThtString;
|
|
ID: Integer;
|
|
Attr: ThtString;
|
|
utText: TutText;
|
|
TabIndex: Integer;
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Assign(const AnUrl, ATarget: ThtString; L: TfrxHtAttributeList; AStart: Integer); overload;
|
|
procedure Assign(const UT: TfrxHtUrlTarget); overload;
|
|
procedure Clear;
|
|
procedure SetLast(List: TfrxHtFontObjBaseList; ALast: Integer);
|
|
property Start: Integer read utText.Start;
|
|
property Last: Integer read utText.Last;
|
|
end;
|
|
|
|
TfrxHtFontObjBase = class {font information}
|
|
public
|
|
UrlTarget: TfrxHtUrlTarget;
|
|
end;
|
|
|
|
TfrxHtFontObjBaseList = class(TObjectList)
|
|
private
|
|
function GetBase(Index: Integer): TfrxHtFontObjBase; {$ifdef UseInline} inline; {$endif}
|
|
public
|
|
property Items[Index: Integer]: TfrxHtFontObjBase read GetBase; default;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
// indentation manager
|
|
//------------------------------------------------------------------------------
|
|
|
|
TfrxHtIndentRec = class
|
|
public
|
|
X: Integer; // left or right indentation relative to LfEdge.
|
|
YT: Integer; // top Y inclusive coordinate for this record relative to document top.
|
|
YB: Integer; // bottom Y exclusive coordinate for this record relative to document top.
|
|
ID: TObject; // block level indicator for this record, 0 for not applicable
|
|
end;
|
|
|
|
TfrxHtIndentRecList = class(TObjectList)
|
|
private
|
|
function Get(Index: Integer): TfrxHtIndentRec; {$ifdef UseInline} inline; {$endif}
|
|
public
|
|
property Items[Index: Integer]: TfrxHtIndentRec read Get; default;
|
|
end;
|
|
|
|
TfrxHtIndentManager = class
|
|
private
|
|
function LeftEdge(Y: Integer): Integer;
|
|
function RightEdge(Y: Integer): Integer;
|
|
public
|
|
LfEdge: Integer; // left edge of the block content area.
|
|
// TfrxHtCell.DoLogic calculates with LfEdge = 0.
|
|
// TfrxHtCell.Draw then may shift the block by setting LfEdge to X.
|
|
Width: Integer; // width of the block content area.
|
|
ClipWidth: Integer; // clip width ???
|
|
L: TfrxHtIndentRecList; // list of left side indentations of type IndentRec.
|
|
R: TfrxHtIndentRecList; // list of right side indentations of type IndentRec.
|
|
CurrentID: TObject; // the current block level (a TfrxHTBlock pointer)
|
|
LTopMin: Integer;
|
|
RTopMin: Integer;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function AddLeft(YT, YB, W: Integer): TfrxHtIndentRec;
|
|
function AddRight(YT, YB, W: Integer): TfrxHtIndentRec;
|
|
function AlignLeft(var Y: Integer; W: Integer): Integer;
|
|
function AlignRight(var Y: Integer; W: Integer): Integer;
|
|
function GetNextWiderY(Y: Integer): Integer;
|
|
function ImageBottom: Integer;
|
|
function LeftIndent(Y: Integer): Integer;
|
|
function RightSide(Y: Integer): Integer;
|
|
function SetLeftIndent(XLeft, Y: Integer): Integer;
|
|
function SetRightIndent(XRight, Y: Integer): Integer;
|
|
procedure FreeLeftIndentRec(I: Integer);
|
|
procedure FreeRightIndentRec(I: Integer);
|
|
procedure GetClearY(out CL, CR: Integer);
|
|
procedure Init(Lf, Wd: Integer);
|
|
procedure Reset(Lf: Integer);
|
|
// AdjustY() is called after an inline row has been produced. If floating objects have been moved
|
|
// down before the actual height of the entire row was computed, their Y coordinates aren't too
|
|
// small now. AdjustY() moves them down below given Y + Height.
|
|
procedure AdjustY(FirstLeftIndex, FirstRightIndex, Y, Height: Integer);
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
// parser
|
|
//------------------------------------------------------------------------------
|
|
|
|
{Simplified variant of TokenObj, to temporarily keep a ThtString of unicode
|
|
characters along with their original indices.}
|
|
|
|
{ TfrxHtCharCollection }
|
|
|
|
TfrxHtCharCollection = class
|
|
private
|
|
FChars: ThtString;
|
|
FIndices: array of Integer;
|
|
FCurrentIndex: Integer;
|
|
function GetSize: Integer;
|
|
function GetAsString: ThtString;
|
|
function GetCapacity: Integer;
|
|
procedure SetCapacity(NewCapacity: Integer);
|
|
public
|
|
constructor Create;
|
|
procedure Add(C: ThtChar; Index: Integer); overload;
|
|
procedure Add(const S: ThtString; Index: Integer); overload;
|
|
procedure Clear;
|
|
// procedure Concat(T: TfrxHtCharCollection);
|
|
|
|
property AsString: ThtString read GetAsString;
|
|
property Capacity: Integer read GetCapacity write SetCapacity;
|
|
property Size: Integer read GetSize;
|
|
end;
|
|
|
|
{ TokenObj }
|
|
|
|
TfrxHtTokenObj = class
|
|
private
|
|
St: UnicodeString;
|
|
StringOK: boolean;
|
|
FCount: Integer;
|
|
function GetCapacity: Integer;
|
|
function GetString: UnicodeString;
|
|
procedure SetCapacity(NewCapacity: Integer);
|
|
public
|
|
C: array of ThtChar;
|
|
I: array of Integer;
|
|
constructor Create;
|
|
procedure AddUnicodeChar(Ch: WideChar; Ind: Integer);
|
|
procedure AddString(S: TfrxHtCharCollection);
|
|
procedure Clear;
|
|
|
|
property Capacity: Integer read GetCapacity write SetCapacity;
|
|
property Count: Integer read FCount;
|
|
property S: UnicodeString read GetString;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
// TfrxHtIDObject is base class for all tag objects.
|
|
//------------------------------------------------------------------------------
|
|
// If they have an ID, the parser puts them into the HtmlViewer's IDNameList,
|
|
// a TfrxHtIDObjectList, where they can be obtained from by ID.
|
|
// Their Y coordinates can be retrieved and HtmlViewer can scroll to them.
|
|
//
|
|
// Most descendants are objects representing an HTML tag, except TfrxHtChPosObj.
|
|
//------------------------------------------------------------------------------
|
|
|
|
TfrxHtIDObject = class
|
|
private
|
|
function GetId(): ThtString; //>-- DZ
|
|
protected
|
|
FHtmlId: ThtString; //>-- DZ real ID from HTML if any
|
|
FGlobalId: ThtString; //>-- DZ global unique ID
|
|
|
|
function GetYPosition: Integer; virtual; abstract;
|
|
function FreeMe: Boolean; virtual; // some objects the TIDObjectsList owns, some others not.
|
|
public
|
|
constructor Create(const AHtmlID: ThtString);
|
|
|
|
property YPosition: Integer read GetYPosition;
|
|
property Id: ThtString read GetId; //>-- DZ if FhtmlId then FglobalId will be returned as result
|
|
property HtmlId: ThtString read FHtmlId; //>-- DZ
|
|
property GlobalId: ThtString read FGlobalId; //>-- DZ
|
|
end;
|
|
|
|
//BG, 04.03.2011: TIDNameList renamed to TfrxHtIDObjectList and used TObject changed to TfrxHtIDObject.
|
|
TfrxHtIDObjectList = class(ThtStringList)
|
|
private
|
|
function GetObject(Index: Integer): TfrxHtIDObject; reintroduce;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function AddObject(const S: ThtString; AObject: TfrxHtIDObject): Integer; reintroduce;
|
|
procedure Clear; override;
|
|
property Objects[Index: Integer]: TfrxHtIDObject read GetObject; default;
|
|
end;
|
|
|
|
ThtColorArray = packed array[0..3] of TColor;
|
|
ThtBorderStyleArray = packed array[0..3] of ThtBorderStyle;
|
|
|
|
//BG, 11.09.2010: moved to this unit to reduce circular dependencies:
|
|
|
|
ThtguResultType = set of (guUrl, guControl, guTitle);
|
|
|
|
//------------------------------------------------------------------------------
|
|
// TfrxHtControlBase is base class for TfrxHtViewerBase and TFrameBase
|
|
//------------------------------------------------------------------------------
|
|
|
|
TfrxHtControlBase = class(TPersistent);
|
|
|
|
//------------------------------------------------------------------------------
|
|
// TfrxHtViewerBase is base class for THtmlViewer and TFrameViewer
|
|
//------------------------------------------------------------------------------
|
|
|
|
TGetStreamEvent = procedure(Sender: TObject; const SRC: ThtString; var Stream: TStream) of object;
|
|
TGottenStreamEvent = TGetStreamEvent;
|
|
TIncludeType = procedure(Sender: TObject; const Command: ThtString; Params: ThtStrings; out IncludedDocument: TBuffer) of object;
|
|
TLinkType = procedure(Sender: TObject; const Rel, Rev, Href: ThtString) of object;
|
|
TMetaType = procedure(Sender: TObject; const HttpEq, Name, Content: ThtString) of object;
|
|
TPagePrinted = procedure(Sender: TObject; Canvas: TCanvas; NumPage, W, H: Integer; var StopPrinting: Boolean) of object;
|
|
TParseEvent = procedure(Sender: TObject; var Source: TBuffer) of object;
|
|
TProcessingEvent = procedure(Sender: TObject; ProcessingOn: Boolean) of object;
|
|
TScriptEvent = procedure(Sender: TObject; const Name, ContentType, Src, Script: ThtString) of object;
|
|
TSoundType = procedure(Sender: TObject; const SRC: ThtString; Loop: Integer; Terminate: boolean) of object;
|
|
THTMLViewPrinted = TNotifyEvent;
|
|
THTMLViewPrinting = procedure(Sender: TObject; var StopPrinting: Boolean) of object;
|
|
TLinkDrawnEvent = procedure(Sender: TObject; Page: Integer; const Url, Target: ThtString; ARect: TRect) of object;
|
|
TFileBrowseEvent = procedure(Sender, Obj: TObject; var S: ThtString) of object;
|
|
TGetImageEvent = procedure(Sender: TObject; const SRC: ThtString; var Stream: TStream) of object;
|
|
TGottenImageEvent = TGetImageEvent;
|
|
|
|
TfrxHtViewerBase = class(TfrxHtControlBase)
|
|
private
|
|
FBackGround, FHotSpotColor, FVisitedColor, FOverColor: TColor;
|
|
FCharset: TFontCharset;
|
|
FCodePage: TBuffCodePage;
|
|
FFontColor: TColor;
|
|
FFontName, FPreFontName: TFontName;
|
|
FFontSize: Double;
|
|
FHistoryMaxCount, FVisitedMaxCount: Integer;
|
|
FMarginWidth, FMarginHeight: Integer;
|
|
FNoSelect: Boolean;
|
|
FPrintMarginLeft, FPrintMarginRight, FPrintMarginTop, FPrintMarginBottom: Double;
|
|
FPrintMaxHPages: Integer;
|
|
FServerRoot: ThtString;
|
|
//
|
|
function StoreFontName: Boolean;
|
|
function StorePreFontName: Boolean;
|
|
protected
|
|
procedure SetActiveColor(const Value: TColor); virtual;
|
|
procedure SetCharset(const Value: TFontCharset); virtual;
|
|
procedure SetCodePage(const Value: Integer); virtual;
|
|
procedure SetDefBackground(const Value: TColor); virtual;
|
|
procedure SetFontColor(const Value: TColor); virtual;
|
|
procedure SetFontName(const Value: TFontName); virtual;
|
|
procedure SetFontSize(const Value: Double); virtual;
|
|
procedure SetHistoryMaxCount(const Value: Integer); virtual;
|
|
procedure SetHotSpotColor(const Value: TColor); virtual;
|
|
procedure SetMarginHeight(const Value: Integer); virtual;
|
|
procedure SetMarginWidth(const Value: Integer); virtual;
|
|
procedure SetNoSelect(const Value: Boolean); virtual;
|
|
procedure SetPreFontName(const Value: TFontName); virtual;
|
|
procedure SetPrintMarginBottom(const Value: Double); virtual;
|
|
procedure SetPrintMarginLeft(const Value: Double); virtual;
|
|
procedure SetPrintMarginRight(const Value: Double); virtual;
|
|
procedure SetPrintMarginTop(const Value: Double); virtual;
|
|
procedure SetPrintMaxHPages(const Value: Integer); virtual;
|
|
procedure SetServerRoot(const Value: ThtString); virtual;
|
|
procedure SetVisitedColor(const Value: TColor); virtual;
|
|
procedure SetVisitedMaxCount(const Value: Integer); virtual;
|
|
public
|
|
constructor Create; virtual;
|
|
constructor CreateCopy(Source: TfrxHtViewerBase); virtual;
|
|
// Load(Url): Url might be an absolute Url or an absolute PathName or a relative Url/PathName.
|
|
procedure Load(const Url: ThtString); virtual; abstract;
|
|
// HtmlExpandFilename(Filename, CurrentFilename): Try to get the absolute pathname of the given filename in the local filesystem
|
|
function HtmlExpandFilename(const Filename: ThtString; const CurrentFilename: ThtString = ''): ThtString; virtual; abstract;
|
|
// set to determine if child objects should be in "quirks" mode
|
|
property CodePage: Integer read FCodePage write SetCodePage default 0;
|
|
property CharSet: TFontCharset read FCharSet write SetCharset default DEFAULT_CHARSET;
|
|
property DefBackground: TColor read FBackground write SetDefBackground default clBtnFace;
|
|
property DefFontColor: TColor read FFontColor write SetFontColor default clBtnText;
|
|
property DefFontName: TFontName read FFontName write SetFontName stored StoreFontName;
|
|
property DefFontSize: Double read FFontSize write SetFontSize;
|
|
property DefHotSpotColor: TColor read FHotSpotColor write SetHotSpotColor default clBlue;
|
|
property DefOverLinkColor: TColor read FOverColor write SetActiveColor default clBlue;
|
|
property DefPreFontName: TFontName read FPreFontName write SetPreFontName stored StorePreFontName;
|
|
property DefVisitedLinkColor: TColor read FVisitedColor write SetVisitedColor default clPurple;
|
|
property HistoryMaxCount: Integer read FHistoryMaxCount write SetHistoryMaxCount;
|
|
property MarginHeight: Integer read FMarginHeight write SetMarginHeight default 5;
|
|
property MarginWidth: Integer read FMarginWidth write SetMarginWidth default 10;
|
|
property NoSelect: Boolean read FNoSelect write SetNoSelect;
|
|
property PrintMarginBottom: Double read FPrintMarginBottom write SetPrintMarginBottom;
|
|
property PrintMarginLeft: Double read FPrintMarginLeft write SetPrintMarginLeft;
|
|
property PrintMarginRight: Double read FPrintMarginRight write SetPrintMarginRight;
|
|
property PrintMarginTop: Double read FPrintMarginTop write SetPrintMarginTop;
|
|
property PrintMaxHPages: Integer read FPrintMaxHPages write SetPrintMaxHPages default 2;
|
|
property ServerRoot: ThtString read FServerRoot write SetServerRoot;
|
|
property VisitedMaxCount: Integer read FVisitedMaxCount write SetVisitedMaxCount default 50;
|
|
published
|
|
end;
|
|
|
|
TTablePartType = (Normal, DoHead, DoBody1, DoBody2, DoBody3, DoFoot);
|
|
TTablePartRec = class
|
|
public
|
|
TablePart: TTablePartType;
|
|
PartStart: Integer;
|
|
PartHeight: Integer;
|
|
FootHeight: Integer;
|
|
end;
|
|
|
|
TfrxHtmlViewerBase = class(TfrxHtViewerBase)
|
|
protected
|
|
FWidth: Integer;
|
|
FHeight: Integer;
|
|
public
|
|
TablePartRec: TTablePartRec;
|
|
|
|
property Width: Integer read FWidth write FWidth;
|
|
property Height: Integer read FHeight write FHeight;
|
|
end;
|
|
|
|
//------------------------------------------------------------------------------
|
|
// string methods
|
|
//------------------------------------------------------------------------------
|
|
|
|
function StrLenW(Str: PWideChar): Cardinal;
|
|
function StrPosW(Str, SubStr: PWideChar): PWideChar;
|
|
function StrScanW(const Str: PWideChar; Chr: WideChar): PWideChar;
|
|
function StrRScanW(const Str: PWideChar; Chr: WideChar): PWideChar;
|
|
function WidePos(SubStr, S: UnicodeString): Integer;
|
|
function WideSameText1(const S1, S2: UnicodeString): boolean; {$ifdef UseInline} inline; {$endif}
|
|
function WideSameStr1(const S1, S2: UnicodeString): boolean; {$ifdef UseInline} inline; {$endif}
|
|
|
|
//function WideStringToMultibyte(CodePage: Integer; W: UnicodeString): AnsiString;
|
|
|
|
function FitText(DC: HDC; S: PWideChar; Max, Width: Integer; out Extent: TSize): Integer;
|
|
function GetTextExtent(DC: HDC; P: PWideChar; N: Integer): TSize;
|
|
procedure WrapTextW(Canvas: TCanvas; X1, Y1, X2, Y2: Integer; S: UnicodeString);
|
|
|
|
//------------------------------------------------------------------------------
|
|
// misc. methods
|
|
//------------------------------------------------------------------------------
|
|
|
|
// BG, 26.12.2011: new type TSpecWidth
|
|
function SpecWidth(Value: Integer; VType: TWidthType): TSpecWidth;
|
|
function ToSpecWidth(AsInteger: Integer; AsString: ThtString): TSpecWidth;
|
|
|
|
//------------------------------------------------------------------------------
|
|
// canvas methods
|
|
//------------------------------------------------------------------------------
|
|
|
|
function CalcClipRect(Canvas: TCanvas; const Rect: TRect; Printing: boolean): TRect;
|
|
procedure GetClippingRgn(Canvas: TCanvas; const ARect: TRect; Printing: boolean; var Rgn, SaveRgn: HRgn);
|
|
|
|
procedure FillRectWhite(Canvas: TCanvas; X1, Y1, X2, Y2: Integer; Color: TColor);
|
|
procedure DrawBorder(Canvas: TCanvas; ORect, IRect: TRect; const C: ThtColorArray;
|
|
const S: ThtBorderStyleArray; BGround: TColor; Print: boolean);
|
|
|
|
function DirectionByText(WC: PWideChar; Len: Integer): ThtDirection;
|
|
|
|
type
|
|
THtBorderPointArray = array[0..3] of TPoint;
|
|
|
|
implementation
|
|
|
|
uses
|
|
Forms, {$ifndef UseInline} Math, {$endif}
|
|
{$ifdef UseVCLStyles}
|
|
Vcl.Themes,
|
|
VCL.Controls,
|
|
{$endif}
|
|
{$ifdef HasSystemUITypes}
|
|
System.UITypes,
|
|
{$endif}
|
|
{$ifndef FPC_TODO}jpeg, {$endif}
|
|
{$IFDEF UNICODE} PngImage, {$ENDIF}
|
|
frxHTMLStylePars;
|
|
|
|
function DirectionByText(WC: PWideChar; Len: Integer): ThtDirection;
|
|
var
|
|
i: Integer;
|
|
C: Word;
|
|
|
|
function Range(w1, w2: Word): Boolean;
|
|
begin
|
|
Result := (C >= w1) and (C <= w2);
|
|
end;
|
|
begin
|
|
Result := diLTR;
|
|
for i := 0 to Len - 1 do
|
|
begin
|
|
C := Word(WC[i]);
|
|
if (C = $200E) // LEFT-TO-RIGHT MARK
|
|
or Range($0041, $005A) or Range($0061, $007A) or Range($00C0, $00D6) or Range($00D8, $00F6) or Range($00F8, $01F1) // Latin
|
|
or Range($0400, $04FF) or Range($0500, $052F) or Range($2DE0, $2DFF) or Range($A640, $A69F) or Range($1C80, $1C8F) // Cyrillic
|
|
or Range($0370, $03FF) or Range($1F00, $1FFF) // Greek and Coptic
|
|
or Range($0530, $058F) or Range($FB00, $FB4F) // Armenian
|
|
or Range($10A0, $10FF) or Range($2D00, $2D2F) or Range($1C90, $1CBF) // Georgian
|
|
or Range($1200, $137F) or Range($1380, $139F) or Range($2D80, $2DDF) or Range($AB00, $AB2F) // Ethiopic
|
|
then
|
|
Break
|
|
else if (C = $200F) // RIGHT-TO-LEFT MARK (RLM)
|
|
or (C = $061C) // ARABIC LETTER MARK (ALM)
|
|
or Range($0590, $05FF) or Range($FB00, $FB4F) // Hebrew
|
|
or Range($0600, $06FF) or Range($0750, $077F) or Range($08A0, $08FF) or Range($0870, $089F) or Range($FB50, $FDFF) or Range($FB50, $FDFF) // Arabic
|
|
or Range($0700, $074F) or Range($0860, $086F) // Syriac
|
|
or Range($0840, $085F) // Mandaic
|
|
or Range($07C0, $07FF) // NKo
|
|
or Range($0800, $083F) // Samaritan
|
|
or Range($0780, $07BF) // Thaana
|
|
then
|
|
begin
|
|
Result := diRTL;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function StrLenW(Str: PWideChar): Cardinal;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
Result := 0;
|
|
if Str <> nil then
|
|
while Str[Result] <> #0 do
|
|
Inc(Result);
|
|
end;
|
|
|
|
function StrPosW(Str, SubStr: PWideChar): PWideChar;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
var
|
|
StrPos : PWideChar;
|
|
SubstrPos : PWideChar;
|
|
begin
|
|
if SubStr^ = #0 then // Make sure substring not null string
|
|
begin
|
|
Result := nil;
|
|
Exit;
|
|
end;
|
|
Result := Str;
|
|
while Result^ <> #0 do // Until reach end of string
|
|
begin
|
|
StrPos := Result;
|
|
SubstrPos := SubStr;
|
|
while SubstrPos^ <> #0 do // Until reach end of substring
|
|
begin
|
|
if StrPos^ <> SubstrPos^ then // No point in continuing?
|
|
Break;
|
|
StrPos := StrPos + 1;
|
|
SubstrPos := SubstrPos + 1;
|
|
end;
|
|
if SubstrPos^ = #0 then // Break because reached end of substring?
|
|
Exit;
|
|
Result := Result + 1;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
|
|
function StrRScanW(const Str: PWideChar; Chr: WideChar): PWideChar;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
Result := StrScanW(Str, #0);
|
|
if Chr = #0 then // Null-terminating char considered part of string.
|
|
Exit;
|
|
while Result <> Str do
|
|
begin
|
|
Result := Result - 1;
|
|
if Result^ = Chr then
|
|
Exit;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
|
|
function StrScanW(const Str: PWideChar; Chr: WideChar): PWideChar;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
Result := Str;
|
|
while Result^ <> #0 do
|
|
begin
|
|
if Result^ = Chr then
|
|
Exit;
|
|
Result := Result + 1;
|
|
end;
|
|
if Chr = #0 then
|
|
Exit; // Null-terminating char considered part of string. See call
|
|
// searching for #0 to find end of string.
|
|
Result := nil;
|
|
end;
|
|
|
|
{----------------FitText}
|
|
|
|
function FitText(DC: HDC; S: PWideChar; Max, Width: Integer; out Extent: TSize): Integer;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
{return count <= Max which fits in Width. Return X, the extent of chars that fit}
|
|
var
|
|
Ints: array of Integer;
|
|
begin
|
|
Extent.cx := 0;
|
|
Extent.cy := 0;
|
|
Result := 0;
|
|
if (Width <= 0) or (Max = 0) then
|
|
Exit;
|
|
|
|
SetLength(Ints, Max);
|
|
if GetTextExtentExPointW(DC, S, Max, Width, @Result, @Ints[0], Extent) then
|
|
if Result > 0 then
|
|
Extent.cx := Ints[Result - 1]
|
|
else
|
|
Extent.cx := 0;
|
|
|
|
end;
|
|
|
|
{----------------WidePos}
|
|
|
|
function WidePos(SubStr, S: UnicodeString): Integer;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
// Unicode equivalent for Pos() function.
|
|
var
|
|
P: PWideChar;
|
|
begin
|
|
P := StrPosW(PWideChar(S), PWideChar(SubStr));
|
|
if P = nil then
|
|
Result := 0
|
|
else
|
|
Result := P - PWideChar(S) + 1;
|
|
end;
|
|
|
|
function WideSameText1(const S1, S2: UnicodeString): boolean;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
Result := htUpperCase(S1) = htUpperCase(S2);
|
|
end;
|
|
|
|
function WideSameStr1(const S1, S2: UnicodeString): boolean;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
Result := S1 = S2;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 06.10.2010 --
|
|
function ScaleRect(const Rect: TRect; ScaleX, ScaleY: Double): TRect;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
Result.Left := Round(Rect.Left * ScaleX);
|
|
Result.Right := Round(Rect.Right * ScaleX);
|
|
Result.Top := Round(Rect.Top * ScaleY);
|
|
Result.Bottom := Round(Rect.Bottom * ScaleY);
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 06.10.2010 --
|
|
function CalcClipRect(Canvas: TCanvas; const Rect: TRect; Printing: boolean): TRect;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
var
|
|
Point: TPoint;
|
|
SizeV, SizeW: TSize;
|
|
begin
|
|
GetWindowOrgEx(Canvas.Handle, Point); {when scrolling or animated Gifs, canvas may not start at X=0, Y=0}
|
|
Result := Rect;
|
|
OffsetRect(Result, -Point.X, -Point.Y);
|
|
if Printing then
|
|
begin
|
|
GetViewportExtEx(Canvas.Handle, SizeV);
|
|
GetWindowExtEx(Canvas.Handle, SizeW);
|
|
Result := ScaleRect(Result, SizeV.cx / SizeW.cx, SizeV.cy / SizeW.cy);
|
|
end;
|
|
end;
|
|
|
|
procedure GetClippingRgn(Canvas: TCanvas; const ARect: TRect; Printing: boolean; var Rgn, SaveRgn: HRgn);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
var
|
|
Point: TPoint;
|
|
SizeV, SizeW: TSize;
|
|
HF, VF: double;
|
|
Rslt: Integer;
|
|
begin
|
|
{find a clipregion to prevent overflow. First check to see if there is
|
|
already a clip region. Return the old region, SaveRgn, (or 0) so it can be
|
|
restored later.}
|
|
SaveRgn := CreateRectRgn(0, 0, 1, 1);
|
|
Rslt := GetClipRgn(Canvas.Handle, SaveRgn); {Rslt = 1 for existing region, 0 for none}
|
|
if Rslt = 0 then
|
|
begin
|
|
DeleteObject(SaveRgn);
|
|
SaveRgn := 0;
|
|
end;
|
|
{Form the region}
|
|
GetWindowOrgEx(Canvas.Handle, Point); {when scrolling or animated Gifs, canvas may not start at X=0, Y=0}
|
|
with ARect do
|
|
if not Printing then
|
|
Rgn := CreateRectRgn(Left - Point.X, Top - Point.Y, Right - Point.X, Bottom - Point.Y)
|
|
else
|
|
begin
|
|
GetViewportExtEx(Canvas.Handle, SizeV);
|
|
GetWindowExtEx(Canvas.Handle, SizeW);
|
|
HF := (SizeV.cx / SizeW.cx); {Horizontal adjustment factor}
|
|
VF := (SizeV.cy / SizeW.cy); {Vertical adjustment factor}
|
|
Rgn := CreateRectRgn(Round(HF * (Left - Point.X)), Round(VF * (Top - Point.Y)), Round(HF * (Right - Point.X)), Round(VF * (Bottom - Point.Y)));
|
|
end;
|
|
if Rslt = 1 then {if there was a region, use the intersection with this region}
|
|
CombineRgn(Rgn, Rgn, SaveRgn, Rgn_And);
|
|
end;
|
|
|
|
function WideTrim(const S: UnicodeString): UnicodeString;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
var
|
|
I, L: Integer;
|
|
begin
|
|
L := Length(S);
|
|
I := 1;
|
|
while (I <= L) and (S[I] <= ' ') do
|
|
Inc(I);
|
|
if I > L then
|
|
Result := ''
|
|
else
|
|
begin
|
|
while S[L] <= ' ' do
|
|
Dec(L);
|
|
Result := Copy(S, I, L - I + 1);
|
|
end;
|
|
end;
|
|
|
|
procedure WrapTextW(Canvas: TCanvas; X1, Y1, X2, Y2: Integer; S: UnicodeString);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
{Wraps text in a clipping rectangle. Font must be set on entry}
|
|
var
|
|
ARect: TRect;
|
|
TAlign: Integer;
|
|
begin
|
|
TAlign := SetTextAlign(Canvas.Handle, TA_Top or TA_Left);
|
|
ARect := Rect(X1, Y1, X2, Y2);
|
|
DrawTextW(Canvas.Handle, PWideChar(S), Length(S), ARect, DT_Wordbreak);
|
|
SetTextAlign(Canvas.Handle, TAlign);
|
|
end;
|
|
|
|
function GetTextExtent(DC: HDC; P: PWideChar; N: Integer): TSize;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
var
|
|
Dummy: Integer;
|
|
begin
|
|
GetTextExtentExPointW(DC, P, N, 0, @Dummy, nil, Result)
|
|
end;
|
|
|
|
procedure FillRectWhite(Canvas: TCanvas; X1, Y1, X2, Y2: Integer; Color: TColor);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
var
|
|
OldBrushStyle: TBrushStyle;
|
|
OldBrushColor: TColor;
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
OldBrushStyle := Brush.Style; {save style first}
|
|
OldBrushColor := Brush.Color;
|
|
Brush.Color := ThemedColor(Color);
|
|
Brush.Style := bsSolid;
|
|
FillRect(Rect(X1, Y1, X2, Y2));
|
|
Brush.Color := OldBrushColor;
|
|
Brush.Style := OldBrushStyle; {style after color as color changes style}
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF Ver90}
|
|
|
|
procedure Assert(B: boolean; const S: ThtString);
|
|
begin {dummy Assert for Delphi 2}
|
|
end;
|
|
{$ENDIF}
|
|
|
|
//-- BG ---------------------------------------------------------- 26.12.2011 --
|
|
function SpecWidth(Value: Integer; VType: TWidthType): TSpecWidth;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
Result.Value := Value;
|
|
Result.VType := VType;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 26.12.2011 --
|
|
function ToSpecWidth(AsInteger: Integer; AsString: ThtString): TSpecWidth;
|
|
// Return a TSpecWidth prepared with values given in AsInteger *and* AsString.
|
|
// AsString is used to evaluate the type while AsInteger is used to evaluate the value.
|
|
// BG, 26.12.2011: Currently percentage is still converted to permille as done before Value became type Integer.
|
|
{$ifdef UseInline} inline; {$endif}
|
|
begin
|
|
if Pos('%', AsString) > 0 then
|
|
begin
|
|
Result.Value := Min(100, AsInteger) * 10;
|
|
Result.VType := wtPercent;
|
|
end
|
|
else if Pos('*', AsString) > 0 then // this is not specified for <td>, <th>. Only <col> and <colgroup> support it officially.
|
|
begin
|
|
Result.Value := AsInteger;
|
|
Result.VType := wtRelative;
|
|
end
|
|
else
|
|
begin
|
|
Result.Value := AsInteger;
|
|
Result.VType := wtAbsolute;
|
|
end;
|
|
end;
|
|
|
|
{ TfrxHtAttribute }
|
|
|
|
constructor TfrxHtAttribute.Create(ASym: TAttrSymb; const AValue: Double; const NameStr, ValueStr: ThtString; ACodePage: Integer);
|
|
begin
|
|
inherited Create;
|
|
Which := ASym;
|
|
DblValue := AValue;
|
|
Value := Trunc(AValue);
|
|
WhichName := NameStr;
|
|
Name := ValueStr;
|
|
CodePage := ACodePage;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 27.01.2013 --
|
|
constructor TfrxHtAttribute.CreateCopy(ASource: TfrxHtAttribute);
|
|
begin
|
|
inherited Create;
|
|
Which := ASource.Which;
|
|
WhichName := ASource.WhichName;
|
|
Value := ASource.Value;
|
|
DblValue := ASource.DblValue;
|
|
Name := ASource.Name;
|
|
CodePage := ASource.CodePage;
|
|
end;
|
|
|
|
{----------------TfrxHtAttributeList}
|
|
|
|
procedure TfrxHtAttributeList.Clear;
|
|
begin
|
|
inherited Clear;
|
|
SaveID := '';
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 21.10.2016 --
|
|
function TfrxHtAttributeList.Clone: TfrxHtAttributeList;
|
|
begin
|
|
Result := TfrxHtAttributeList.CreateCopy(Self);
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 27.01.2013 --
|
|
constructor TfrxHtAttributeList.CreateCopy(ASource: TfrxHtAttributeList);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
inherited Create;
|
|
if ASource <> nil then
|
|
for I := 0 to ASource.Count - 1 do
|
|
Add(TfrxHtAttribute.CreateCopy(ASource[I]));
|
|
end;
|
|
|
|
function TfrxHtAttributeList.CreateStringList: ThtStringList;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := ThtStringList.Create;
|
|
for I := 0 to Count - 1 do
|
|
with Items[I] do
|
|
Result.Add(WhichName + '=' + Name);
|
|
end;
|
|
|
|
function TfrxHtAttributeList.Find(const Name: ThtString; var T: TfrxHtAttribute): Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to Count - 1 do
|
|
if Items[I].WhichName = Name then
|
|
begin
|
|
Result := True;
|
|
T := Items[I];
|
|
Exit;
|
|
end;
|
|
Result := False;
|
|
end;
|
|
|
|
function TfrxHtAttributeList.Find(Sy: TAttrSymb; var T: TfrxHtAttribute): Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
for I := 0 to Count - 1 do
|
|
if Items[I].Which = Sy then
|
|
begin
|
|
Result := True;
|
|
T := Items[I];
|
|
Exit;
|
|
end;
|
|
Result := False;
|
|
end;
|
|
|
|
function TfrxHtAttributeList.GetAttribute(Index: Integer): TfrxHtAttribute;
|
|
begin
|
|
Result := Get(Index);
|
|
end;
|
|
|
|
function TfrxHtAttributeList.GetClass: ThtString;
|
|
var
|
|
T: TfrxHtAttribute;
|
|
S: ThtString;
|
|
I: Integer;
|
|
begin
|
|
Result := '';
|
|
T := nil;
|
|
if Find(ClassSy, T) then
|
|
begin
|
|
S := Lowercase(Trim(T.Name));
|
|
I := Pos(' ', S);
|
|
if I <= 0 then {a single class name}
|
|
Result := S
|
|
else
|
|
begin {multiple class names. Format as "class1.class2.class3"}
|
|
repeat
|
|
Result := Result + '.' + System.Copy(S, 1, I - 1);
|
|
System.Delete(S, 1, I);
|
|
S := Trim(S);
|
|
I := Pos(' ', S);
|
|
until I <= 0;
|
|
Result := Result + '.' + S;
|
|
Result := SortContextualItems(Result); {put in standard multiple order}
|
|
System.Delete(Result, 1, 1); {remove initial '.'}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TfrxHtAttributeList.GetID: ThtString;
|
|
var
|
|
T: TfrxHtAttribute;
|
|
begin
|
|
Result := SaveID;
|
|
T := nil;
|
|
if (Result = '') and Find(IDSy, T) then
|
|
begin
|
|
Result := Lowercase(T.Name);
|
|
SaveID := Result;
|
|
end;
|
|
end;
|
|
|
|
function TfrxHtAttributeList.GetTitle: ThtString;
|
|
var
|
|
T: TfrxHtAttribute;
|
|
begin
|
|
T := nil;
|
|
if Find(TitleSy, T) then
|
|
Result := T.Name
|
|
else
|
|
Result := '';
|
|
end;
|
|
|
|
{----------------TfrxHtUrlTarget.Create}
|
|
|
|
constructor TfrxHtUrlTarget.Create;
|
|
begin
|
|
inherited Create;
|
|
//utText := TutText.Create;
|
|
utText.Start := -1;
|
|
utText.Last := -1;
|
|
end;
|
|
|
|
destructor TfrxHtUrlTarget.Destroy;
|
|
begin
|
|
//FreeAndNil(utText);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
var
|
|
Sequence: Integer = 10;
|
|
|
|
procedure TfrxHtUrlTarget.Assign(const AnUrl, ATarget: ThtString; L: TfrxHtAttributeList; AStart: Integer);
|
|
var
|
|
SL: ThtStringList;
|
|
begin
|
|
Url := AnUrl;
|
|
Target := ATarget;
|
|
ID := Sequence;
|
|
Inc(Sequence);
|
|
utText.Start := AStart;
|
|
SL := L.CreateStringList;
|
|
try
|
|
Attr := SL.Text;
|
|
finally
|
|
SL.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxHtUrlTarget.Assign(const UT: TfrxHtUrlTarget);
|
|
begin
|
|
Url := UT.Url;
|
|
Target := UT.Target;
|
|
ID := UT.ID;
|
|
TabIndex := UT.TabIndex;
|
|
Attr := UT.Attr;
|
|
utText.Start := UT.utText.Start;
|
|
utText.Last := UT.utText.Last;
|
|
end;
|
|
|
|
procedure TfrxHtUrlTarget.Clear;
|
|
begin
|
|
Url := '';
|
|
Target := '';
|
|
ID := 0;
|
|
TabIndex := 0;
|
|
Attr := '';
|
|
utText.Start := -1;
|
|
utText.Last := -1;
|
|
end;
|
|
|
|
procedure TfrxHtUrlTarget.SetLast(List: TfrxHtFontObjBaseList; ALast: Integer);
|
|
var
|
|
I: Integer;
|
|
begin
|
|
utText.Last := ALast;
|
|
if List.Count > 0 then
|
|
for I := List.Count - 1 downto 0 do
|
|
if ID = List[I].UrlTarget.ID then
|
|
List[I].UrlTarget.utText.Last := ALast
|
|
else
|
|
Break;
|
|
end;
|
|
|
|
{ TfrxHtIndentManager }
|
|
|
|
constructor TfrxHtIndentManager.Create;
|
|
begin
|
|
inherited Create;
|
|
R := TfrxHtIndentRecList.Create;
|
|
L := TfrxHtIndentRecList.Create;
|
|
end;
|
|
|
|
destructor TfrxHtIndentManager.Destroy;
|
|
begin
|
|
R.Free;
|
|
L.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 05.02.2011 --
|
|
function TfrxHtIndentManager.AddLeft(YT, YB, W: Integer): TfrxHtIndentRec;
|
|
// For a floating block, update the left edge information.
|
|
begin
|
|
Result := TfrxHtIndentRec.Create;
|
|
Result.YT := YT;
|
|
Result.YB := YB;
|
|
Result.X := LeftEdge(YT) + W;
|
|
L.Add(Result);
|
|
LTopMin := YT;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 05.02.2011 --
|
|
function TfrxHtIndentManager.AddRight(YT, YB, W: Integer): TfrxHtIndentRec;
|
|
// For a floating block, update the right edge information.
|
|
begin
|
|
Result := TfrxHtIndentRec.Create;
|
|
Result.YT := YT;
|
|
Result.YB := YB;
|
|
Result.X := RightEdge(YT) - W;
|
|
R.Add(Result);
|
|
RTopMin := YT;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 12.08.2013 --
|
|
procedure TfrxHtIndentManager.AdjustY(FirstLeftIndex, FirstRightIndex, Y, Height: Integer);
|
|
var
|
|
I, D: Integer;
|
|
IR: TfrxHtIndentRec;
|
|
begin
|
|
D := 0;
|
|
for I := FirstLeftIndex to L.Count - 1 do
|
|
begin
|
|
IR := L[I];
|
|
if IR.YT > Y then
|
|
begin
|
|
if IR.YT < Y + Height then
|
|
D := Y + Height - IR.YT;
|
|
Inc(IR.YT, D);
|
|
Inc(IR.YB, D);
|
|
end;
|
|
end;
|
|
|
|
D := 0;
|
|
for I := FirstRightIndex to R.Count - 1 do
|
|
begin
|
|
IR := R[I];
|
|
if IR.YT > Y then
|
|
begin
|
|
if IR.YT < Y + Height then
|
|
D := Y + Height - IR.YT;
|
|
Inc(IR.YT, D);
|
|
Inc(IR.YB, D);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------TfrxHtIndentManager.Reset}
|
|
|
|
//-- BG ---------------------------------------------------------- 23.02.2011 --
|
|
procedure TfrxHtIndentManager.Init(Lf, Wd: Integer);
|
|
begin
|
|
LfEdge := Lf;
|
|
Width := Wd;
|
|
R.Clear;
|
|
L.Clear;
|
|
LTopMin := 0;
|
|
RTopMin := 0;
|
|
CurrentID := nil;
|
|
end;
|
|
|
|
procedure TfrxHtIndentManager.Reset(Lf: Integer);
|
|
begin
|
|
LfEdge := Lf;
|
|
CurrentID := nil;
|
|
end;
|
|
|
|
const
|
|
BigY = 9999999;
|
|
|
|
//-- BG ---------------------------------------------------------- 23.02.2011 --
|
|
function TfrxHtIndentManager.LeftEdge(Y: Integer): Integer;
|
|
// Returns the right most left indentation at Y relative to LfEdge.
|
|
// If there are no left indentations at Y, returns 0.
|
|
var
|
|
I: Integer;
|
|
IR: TfrxHtIndentRec;
|
|
MinX: Integer;
|
|
begin
|
|
Result := -MaxInt;
|
|
MinX := 0;
|
|
for I := 0 to L.Count - 1 do
|
|
begin
|
|
IR := L[I];
|
|
if (Y >= IR.YT) and (Y < IR.YB) and (Result < IR.X) then
|
|
if (IR.ID = nil) or (IR.ID = CurrentID) then
|
|
Result := IR.X;
|
|
if IR.ID = CurrentID then
|
|
MinX := IR.X;
|
|
end;
|
|
if Result = -MaxInt then
|
|
Result := MinX;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 23.02.2011 --
|
|
function TfrxHtIndentManager.LeftIndent(Y: Integer): Integer;
|
|
// Returns the right most left indentation at Y relative to block.
|
|
// If there are no left indentations at Y, returns LfEdge.
|
|
begin
|
|
Result := LeftEdge(Y) + LfEdge;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 23.02.2011 --
|
|
function TfrxHtIndentManager.RightEdge(Y: Integer): Integer;
|
|
// Returns the left most right indentation at Y relative LfEdge.
|
|
// If there are no indentations at Y, returns Width.
|
|
var
|
|
I: Integer;
|
|
IR: TfrxHtIndentRec;
|
|
MinX: Integer;
|
|
begin
|
|
Result := MaxInt;
|
|
for I := 0 to R.Count - 1 do
|
|
begin
|
|
IR := R[I];
|
|
if (Y >= IR.YT) and (Y < IR.YB) and (Result > IR.X) then
|
|
if (IR.ID = nil) or (IR.ID = CurrentID) then
|
|
Result := IR.X;
|
|
end;
|
|
if Result = MaxInt then
|
|
begin
|
|
//BG, 01.03.2011: Issue 77: Error of the elements
|
|
MinX := 0;
|
|
for I := L.Count - 1 downto 0 do
|
|
begin
|
|
IR := L[I];
|
|
if IR.ID = CurrentID then
|
|
begin
|
|
MinX := IR.X;
|
|
break;
|
|
end;
|
|
end;
|
|
Result := Width + MinX;
|
|
end;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 23.02.2011 --
|
|
function TfrxHtIndentManager.RightSide(Y: Integer): Integer;
|
|
// Returns the left most right indentation at Y relative to block.
|
|
// If there are no indentations at Y, returns Width + LfEdge.
|
|
begin
|
|
Result := RightEdge(Y) + LfEdge;
|
|
end;
|
|
|
|
function TfrxHtIndentManager.ImageBottom: Integer;
|
|
// Returns the bottom of the last floating image.
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := 0;
|
|
for I := 0 to L.Count - 1 do
|
|
with L[I] do
|
|
if (ID = nil) and (YB > Result) then
|
|
Result := YB;
|
|
for I := 0 to R.Count - 1 do
|
|
with R[I] do
|
|
if (ID = nil) and (YB > Result) then
|
|
Result := YB;
|
|
end;
|
|
|
|
procedure TfrxHtIndentManager.GetClearY(out CL, CR: Integer);
|
|
{returns the left and right Y values which will clear image margins}
|
|
var
|
|
I: Integer;
|
|
begin
|
|
CL := -1;
|
|
for I := 0 to L.Count - 1 do
|
|
with L[I] do
|
|
if (ID = nil) and (YB > CL) then
|
|
CL := YB;
|
|
CR := -1;
|
|
for I := 0 to R.Count - 1 do
|
|
with R[I] do
|
|
if (ID = nil) and (YB > CR) then
|
|
CR := YB;
|
|
Inc(CL);
|
|
Inc(CR);
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 06.02.2011 --
|
|
function TfrxHtIndentManager.AlignLeft(var Y: Integer; W: Integer): Integer;
|
|
// Find an available area to the left at or below Y with a width of W pixels.
|
|
//
|
|
// Returns the absolute X position of the found area.
|
|
// On return Y may be adjusted to a larger value if at original Y there is not
|
|
// enough width W.
|
|
var
|
|
I, CL, CR, LX, RX, XL, XR, YY, MinX: Integer;
|
|
begin
|
|
Y := Max(Y, LTopMin);
|
|
Result := LeftEdge(Y);
|
|
if Result + W > RightEdge(Y) then
|
|
begin
|
|
// too wide, must find a wider place below:
|
|
YY := Y;
|
|
MinX := 0;
|
|
|
|
CL := Y;
|
|
XL := Result; // valium for the compiler
|
|
for I := L.Count - 1 downto 0 do
|
|
with L[I] do
|
|
begin
|
|
if ID = CurrentID then
|
|
begin
|
|
MinX := X;
|
|
break;
|
|
end;
|
|
if (ID = nil) and (YB > Y) and ((YB < CL) or (CL = Y)) then
|
|
begin
|
|
if X = LeftEdge(YB - 1) then
|
|
begin
|
|
// This is the right most left indentation
|
|
LX := LeftEdge(YB);
|
|
RX := RightEdge(YB) - W;
|
|
if YY < YB then
|
|
YY := YB;
|
|
if RX >= LX then
|
|
begin
|
|
CL := YB;
|
|
XL := LX;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
CR := Y;
|
|
XR := Result; // valium for the compiler
|
|
for I := R.Count - 1 downto 0 do
|
|
with R[I] do
|
|
begin
|
|
if ID = CurrentID then
|
|
break;
|
|
if (ID = nil) and (YB > Y) and ((YB < CR) or (CR = Y)) then
|
|
begin
|
|
if X = RightEdge(YB - 1) then
|
|
begin
|
|
// This is the left most right indentation
|
|
LX := LeftEdge(YB);
|
|
RX := RightEdge(YB) - W;
|
|
if YY < YB then
|
|
YY := YB;
|
|
if RX >= LX then
|
|
begin
|
|
CR := YB;
|
|
XR := LX;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
if CL = Y then
|
|
begin
|
|
if CR = Y then
|
|
begin
|
|
// no better place found, just append at the end.
|
|
Y := YY;
|
|
Result := MinX;
|
|
end
|
|
else
|
|
begin
|
|
Y := CR;
|
|
Result := XR;
|
|
end
|
|
end
|
|
else if CR = Y then
|
|
begin
|
|
Y := CL;
|
|
Result := XL;
|
|
end
|
|
else if CL < CR then
|
|
begin
|
|
Y := CL;
|
|
Result := XL;
|
|
end
|
|
else
|
|
begin
|
|
Y := CR;
|
|
Result := XR;
|
|
end;
|
|
end;
|
|
Inc(Result, LfEdge);
|
|
end;
|
|
|
|
function TfrxHtIndentManager.AlignRight(var Y: Integer; W: Integer): Integer;
|
|
// Find an available area to the right at or below Y with a width of W pixels.
|
|
//
|
|
// Returns the absolute X position of the found area.
|
|
// On return Y may be adjusted to a larger value if at original Y there is not
|
|
// enough width W.
|
|
var
|
|
I, CL, CR, LX, RX, XL, XR, YY, MaxX: Integer;
|
|
begin
|
|
Y := Max(Y, RTopMin);
|
|
Result := RightEdge(Y) - W;
|
|
if Result < LeftEdge(Y) then
|
|
begin
|
|
// too wide, must find a wider place below:
|
|
YY := Y;
|
|
MaxX := Width - W;
|
|
|
|
CL := Y;
|
|
XL := Result; // valium for the compiler
|
|
for I := L.Count - 1 downto 0 do
|
|
with L[I] do
|
|
begin
|
|
if ID = CurrentID then
|
|
break;
|
|
if (ID = nil) and (YB > Y) and ((YB < CL) or (CL = Y)) then
|
|
begin
|
|
if X = LeftEdge(YB - 1) then
|
|
begin
|
|
// This is the right most left indentation
|
|
LX := LeftEdge(YB);
|
|
RX := RightEdge(YB) - W;
|
|
if YY < YB then
|
|
YY := YB;
|
|
if RX >= LX then
|
|
begin
|
|
CL := YB;
|
|
XL := RX;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
CR := Y;
|
|
XR := Result; // valium for the compiler
|
|
for I := R.Count - 1 downto 0 do
|
|
with R[I] do
|
|
begin
|
|
if ID = CurrentID then
|
|
begin
|
|
MaxX := X - W;
|
|
break;
|
|
end;
|
|
if (ID = nil) and (YB > Y) and ((YB < CR) or (CR = Y)) then
|
|
begin
|
|
if X = RightEdge(YB - 1) then
|
|
begin
|
|
// This is the left most right indentation
|
|
LX := LeftEdge(YB);
|
|
RX := RightEdge(YB) - W;
|
|
if YY < YB then
|
|
YY := YB;
|
|
if RX >= LX then
|
|
begin
|
|
CR := YB;
|
|
XR := RX;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
if CL = Y then
|
|
begin
|
|
if CR = Y then
|
|
begin
|
|
// no better place found, just append at the end.
|
|
Y := YY;
|
|
Result := MaxX;
|
|
end
|
|
else
|
|
begin
|
|
Y := CR;
|
|
Result := XR;
|
|
end
|
|
end
|
|
else if CR = Y then
|
|
begin
|
|
Y := CL;
|
|
Result := XL;
|
|
end
|
|
else if CL < CR then
|
|
begin
|
|
Y := CL;
|
|
Result := XL;
|
|
end
|
|
else
|
|
begin
|
|
Y := CR;
|
|
Result := XR;
|
|
end;
|
|
end;
|
|
Inc(Result, LfEdge);
|
|
end;
|
|
|
|
function TfrxHtIndentManager.GetNextWiderY(Y: Integer): Integer;
|
|
{returns the next Y value which offers a wider space or Y if none}
|
|
var
|
|
I, CL, CR: Integer;
|
|
begin
|
|
CL := Y;
|
|
for I := 0 to L.Count - 1 do
|
|
with L[I] do
|
|
if not Assigned(ID) and (YB > Y) and ((YB < CL) or (CL = Y)) then
|
|
CL := YB;
|
|
CR := Y;
|
|
for I := 0 to R.Count - 1 do
|
|
with R[I] do
|
|
if not Assigned(ID) and (YB > Y) and ((YB < CR) or (CR = Y)) then
|
|
CR := YB;
|
|
if CL = Y then
|
|
Result := CR
|
|
else if CR = Y then
|
|
Result := CL
|
|
else
|
|
Result := Min(CL, CR);
|
|
end;
|
|
|
|
function TfrxHtIndentManager.SetLeftIndent(XLeft, Y: Integer): Integer;
|
|
var
|
|
IR: TfrxHtIndentRec;
|
|
begin
|
|
IR := TfrxHtIndentRec.Create;
|
|
with IR do
|
|
begin
|
|
YT := Y;
|
|
YB := BigY;
|
|
X := XLeft;
|
|
ID := CurrentID;
|
|
end;
|
|
Result := L.Add(IR);
|
|
end;
|
|
|
|
function TfrxHtIndentManager.SetRightIndent(XRight, Y: Integer): Integer;
|
|
var
|
|
IR: TfrxHtIndentRec;
|
|
begin
|
|
IR := TfrxHtIndentRec.Create;
|
|
with IR do
|
|
begin
|
|
YT := Y;
|
|
YB := BigY;
|
|
X := XRight;
|
|
ID := CurrentID;
|
|
end;
|
|
Result := R.Add(IR);
|
|
end;
|
|
|
|
procedure TfrxHtIndentManager.FreeLeftIndentRec(I: Integer);
|
|
begin
|
|
L.Delete(I);
|
|
end;
|
|
|
|
procedure TfrxHtIndentManager.FreeRightIndentRec(I: Integer);
|
|
begin
|
|
R.Delete(I);
|
|
end;
|
|
|
|
function CopyPalette(Source: hPalette): hPalette;
|
|
{$ifdef UseInline} inline; {$endif}
|
|
var
|
|
LP: ^TLogPalette;
|
|
NumEntries: Integer;
|
|
begin
|
|
Result := 0;
|
|
if ColorBits > 8 then
|
|
Exit;
|
|
GetMem(LP, Sizeof(TLogPalette) + 256 * Sizeof(TPaletteEntry));
|
|
try
|
|
with LP^ do
|
|
begin
|
|
palVersion := $300;
|
|
palNumEntries := 256;
|
|
NumEntries := GetPaletteEntries(Source, 0, 256, palPalEntry);
|
|
if NumEntries > 0 then
|
|
begin
|
|
palNumEntries := NumEntries;
|
|
Result := CreatePalette(LP^);
|
|
end;
|
|
end;
|
|
finally
|
|
FreeMem(LP, Sizeof(TLogPalette) + 256 * Sizeof(TPaletteEntry));
|
|
end;
|
|
end;
|
|
|
|
{----------------TfrxHtCharCollection.GetAsString:}
|
|
|
|
function TfrxHtCharCollection.GetAsString: ThtString;
|
|
begin
|
|
Result := Copy(FChars, 1, FCurrentIndex);
|
|
end;
|
|
|
|
function TfrxHtCharCollection.GetCapacity: Integer;
|
|
begin
|
|
Result := Length(FChars);
|
|
end;
|
|
|
|
function TfrxHtCharCollection.GetSize: Integer;
|
|
begin
|
|
Result := FCurrentIndex;
|
|
end;
|
|
|
|
constructor TfrxHtCharCollection.Create;
|
|
begin
|
|
inherited;
|
|
FCurrentIndex := 0;
|
|
Capacity := TokenLeng;
|
|
end;
|
|
|
|
procedure TfrxHtCharCollection.SetCapacity(NewCapacity: Integer);
|
|
begin
|
|
if NewCapacity <> Capacity then
|
|
begin
|
|
SetLength(FChars, NewCapacity);
|
|
SetLength(FIndices, NewCapacity + 1);
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxHtCharCollection.Add(C: ThtChar; Index: Integer);
|
|
begin
|
|
Inc(FCurrentIndex);
|
|
if Capacity <= FCurrentIndex then
|
|
Capacity := Capacity + 50;
|
|
FIndices[FCurrentIndex] := Index;
|
|
FChars[FCurrentIndex] := C;
|
|
end;
|
|
|
|
procedure TfrxHtCharCollection.Add(const S: ThtString; Index: Integer);
|
|
var
|
|
K, L: Integer;
|
|
begin
|
|
L := Length(S);
|
|
if L > 0 then
|
|
begin
|
|
K := FCurrentIndex + L;
|
|
if Capacity <= K then
|
|
Capacity := K + 50;
|
|
Move(S[1], FChars[FCurrentIndex + 1], L * SizeOf(ThtChar));
|
|
while FCurrentIndex < K do
|
|
begin
|
|
Inc(FCurrentIndex);
|
|
FIndices[FCurrentIndex] := Index;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrxHtCharCollection.Clear;
|
|
begin
|
|
FCurrentIndex := 0;
|
|
SetLength(FChars, 0);
|
|
end;
|
|
|
|
{ TokenObj }
|
|
|
|
constructor TfrxHtTokenObj.Create;
|
|
begin
|
|
inherited;
|
|
Capacity := TokenLeng;
|
|
FCount := 0;
|
|
St := '';
|
|
StringOK := True;
|
|
end;
|
|
|
|
procedure TfrxHtTokenObj.AddUnicodeChar(Ch: WideChar; Ind: Integer);
|
|
{Ch must be Unicode in this method}
|
|
begin
|
|
if Capacity <= Count then
|
|
Capacity := Capacity + 50;
|
|
Inc(FCount);
|
|
C[Count] := Ch;
|
|
I[Count] := Ind;
|
|
StringOK := False;
|
|
end;
|
|
|
|
procedure TfrxHtTokenObj.Clear;
|
|
begin
|
|
FCount := 0;
|
|
St := '';
|
|
StringOK := True;
|
|
end;
|
|
|
|
procedure TfrxHtTokenObj.AddString(S: TfrxHtCharCollection);
|
|
var
|
|
K: Integer;
|
|
begin
|
|
K := Count + S.FCurrentIndex;
|
|
if Capacity <= K then
|
|
Capacity := K + 50;
|
|
Move(S.FChars[1], C[Count + 1], S.FCurrentIndex * Sizeof(ThtChar));
|
|
Move(S.FIndices[1], I[Count + 1], S.FCurrentIndex * Sizeof(Integer));
|
|
FCount := K;
|
|
StringOK := False;
|
|
end;
|
|
|
|
function TfrxHtTokenObj.GetCapacity: Integer;
|
|
begin
|
|
Result := Length(C) - 1;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 20.01.2011 --
|
|
procedure TfrxHtTokenObj.SetCapacity(NewCapacity: Integer);
|
|
begin
|
|
if NewCapacity <> Capacity then
|
|
begin
|
|
SetLength(C, NewCapacity + 1);
|
|
SetLength(I, NewCapacity + 1);
|
|
if NewCapacity < Count then
|
|
begin
|
|
FCount := NewCapacity;
|
|
if StringOK then
|
|
St := Copy(St, 1, Count);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TfrxHtTokenObj.GetString: UnicodeString;
|
|
begin
|
|
if not StringOK then
|
|
begin
|
|
SetLength(St, Count);
|
|
if Count > 0 then
|
|
Move(C[1], St[1], SizeOf(WideChar) * Count);
|
|
StringOK := True;
|
|
end;
|
|
Result := St;
|
|
end;
|
|
|
|
{----------------TfrxHtIDObjectList}
|
|
|
|
function TfrxHtIDObjectList.AddObject(const S: ThtString; AObject: TfrxHtIDObject): Integer;
|
|
var
|
|
I: Integer;
|
|
O: TfrxHtIDObject;
|
|
begin
|
|
I := -1;
|
|
if Find(S, I) then
|
|
begin
|
|
try
|
|
O := Objects[I];
|
|
if O.FreeMe then
|
|
O.Free;
|
|
except
|
|
end;
|
|
Delete(I);
|
|
end;
|
|
Result := inherited AddObject(S, AObject);
|
|
end;
|
|
|
|
procedure TfrxHtIDObjectList.Clear;
|
|
var
|
|
I: Integer;
|
|
O: TfrxHtIDObject;
|
|
begin
|
|
for I := 0 to Count - 1 do
|
|
try
|
|
O := Objects[I];
|
|
if O.FreeMe then
|
|
O.Free;
|
|
except
|
|
end;
|
|
inherited Clear;
|
|
end;
|
|
|
|
constructor TfrxHtIDObjectList.Create;
|
|
begin
|
|
inherited Create;
|
|
Sorted := True;
|
|
end;
|
|
|
|
destructor TfrxHtIDObjectList.Destroy;
|
|
begin
|
|
Clear;
|
|
inherited
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 04.03.2011 --
|
|
function TfrxHtIDObjectList.GetObject(Index: Integer): TfrxHtIDObject;
|
|
begin
|
|
Result := TfrxHtIDObject(inherited GetObject(Index));
|
|
end;
|
|
|
|
// BG, 17.04.2013: Color of DrawOnePolygon() must be a real RGB or palette value. Themed or system colors are not supported!
|
|
procedure DrawOnePolygon(Canvas: TCanvas; P: THtBorderPointArray; Color: TColor; Side: byte; Printing: Boolean);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
{Here we draw a 4 sided polygon (by filling a region). This represents one
|
|
side (or part of a side) of a border.
|
|
For single pixel thickness, drawing is done by lines for better printing}
|
|
//BG, 22.08.2010: in print preview results are better without the single pixel exception.
|
|
{$ifdef BorderSinglePixelException}
|
|
type
|
|
SideArray = array[0..3, 1..4] of Integer;
|
|
const
|
|
AD: SideArray = ((0, 1, 0, 3),
|
|
(0, 1, 1, 1),
|
|
(2, 0, 2, 1),
|
|
(1, 3, 3, 3));
|
|
AP: SideArray = ((0, 1, 0, 3),
|
|
(0, 1, 2, 1),
|
|
(2, 0, 2, 2),
|
|
(1, 3, 3, 3));
|
|
{$endif}
|
|
var
|
|
R: HRgn;
|
|
{$ifdef BorderSinglePixelException}
|
|
OldWidth: Integer;
|
|
OldStyle: TPenStyle;
|
|
OldColor: TColor;
|
|
Thickness: Integer;
|
|
P1, P2: TPoint;
|
|
I: SideArray;
|
|
{$endif}
|
|
begin
|
|
{$ifdef BorderSinglePixelException}
|
|
if Side in [0, 2] then
|
|
Thickness := Abs(P[2].X - P[1].X)
|
|
else
|
|
Thickness := Abs(P[1].Y - P[2].Y);
|
|
if Thickness = 1 then
|
|
begin
|
|
with Canvas do
|
|
begin
|
|
OldColor := Pen.Color;
|
|
OldStyle := Pen.Style;
|
|
OldWidth := Pen.Width;
|
|
Pen.Color := Color;
|
|
Pen.Style := psSolid;
|
|
Pen.Width := 1;
|
|
if Printing then
|
|
I := AP
|
|
else
|
|
I := AD;
|
|
P1 := Point(P[I[Side, 1]].X, P[I[Side, 2]].Y);
|
|
P2 := Point(P[I[Side, 3]].X, P[I[Side, 4]].Y);
|
|
MoveTo(P1.X, P1.Y);
|
|
LineTo(P2.X, P2.Y);
|
|
Pen.Width := OldWidth;
|
|
Pen.Style := OldStyle;
|
|
Pen.Color := OldColor;
|
|
end;
|
|
end
|
|
else
|
|
{$endif}
|
|
begin
|
|
R := CreatePolygonRgn(P, 4, Alternate);
|
|
try
|
|
with Canvas do
|
|
begin
|
|
Brush.Style := bsSolid;
|
|
Brush.Color := Color;
|
|
FillRgn(Handle, R, Brush.Handle);
|
|
end;
|
|
finally
|
|
DeleteObject(R);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{----------------DrawBorder}
|
|
procedure DrawBorder(Canvas: TCanvas; ORect, IRect: TRect; const C: ThtColorArray;
|
|
const S: ThtBorderStyleArray; BGround: TColor; Print: boolean);
|
|
{$ifdef UseInline} inline; {$endif}
|
|
{Draw the 4 sides of a border. The sides may be of different styles or colors.
|
|
The side indices, 0,1,2,3, represent left, top, right, bottom.
|
|
ORect is the outside rectangle of the border, IRect the inside Rectangle.
|
|
BGround is the background color used for the bssDouble style}
|
|
var
|
|
PO, PI, PM, P1, P2, Bnd: THtBorderPointArray;
|
|
I: Integer;
|
|
Cl, Color: TColor;
|
|
MRect: TRect;
|
|
lb: TLogBrush;
|
|
Pn, OldPn: HPen;
|
|
W, D: array[0..3] of Integer;
|
|
InPath: boolean;
|
|
PenType, Start: Integer;
|
|
StyleSet: set of ThtBorderStyle;
|
|
OuterRegion, InnerRegion: HRGN;
|
|
Brush: TBrush;
|
|
|
|
begin
|
|
{Limit the borders to somewhat more than the screen size}
|
|
|
|
ORect.Bottom := Min(ORect.Bottom, BotLim);
|
|
ORect.Top := Max(ORect.Top, TopLim);
|
|
IRect.Bottom := Min(IRect.Bottom, BotLim);
|
|
IRect.Top := Max(IRect.Top, TopLim);
|
|
|
|
{Widths are needed for Dashed, Dotted, and Double}
|
|
W[0] := IRect.Left - Orect.Left;
|
|
W[1] := IRect.Top - Orect.Top;
|
|
W[2] := ORect.Right - IRect.Right;
|
|
W[3] := ORect.Bottom - IRect.Bottom;
|
|
if (W[0] = 0) and (W[1] = 0) and (W[2] = 0) and (W[3] = 0) then
|
|
exit;
|
|
|
|
{Find out what style types are represented in this border}
|
|
StyleSet := [];
|
|
for I := 0 to 3 do
|
|
Include(StyleSet, S[I]);
|
|
|
|
{find the outside and inside corner points for the border segments}
|
|
with ORect do
|
|
begin
|
|
PO[0] := Point(Left, Bottom);
|
|
PO[1] := TopLeft;
|
|
PO[2] := Point(Right, Top);
|
|
PO[3] := BottomRight;
|
|
end;
|
|
with IRect do
|
|
begin
|
|
PI[0] := Point(Left, Bottom);
|
|
PI[1] := TopLeft;
|
|
PI[2] := Point(Right, Top);
|
|
PI[3] := BottomRight;
|
|
end;
|
|
|
|
{Points midway between the outer and inner rectangle are needed for
|
|
ridge, groove, dashed, dotted styles}
|
|
if [bssRidge, bssGroove, bssDotted, bssDashed] * StyleSet <> [] then
|
|
begin
|
|
MRect := Rect((ORect.Left + IRect.Left) div 2, (ORect.Top + IRect.Top) div 2,
|
|
(ORect.Right + IRect.Right) div 2, (ORect.Bottom + IRect.Bottom) div 2);
|
|
with MRect do
|
|
begin
|
|
PM[0] := Point(Left, Bottom);
|
|
PM[1] := TopLeft;
|
|
PM[2] := Point(Right, Top);
|
|
PM[3] := BottomRight;
|
|
end;
|
|
end;
|
|
|
|
{the Double style needs the space between inner and outer rectangles divided
|
|
into three parts}
|
|
if bssDouble in StyleSet then
|
|
begin
|
|
for I := 0 to 3 do
|
|
begin
|
|
D[I] := W[I] div 3;
|
|
if W[I] mod 3 = 2 then
|
|
Inc(D[I]);
|
|
end;
|
|
|
|
with ORect do
|
|
MRect := Rect(Left + D[0], Top + D[1], Right - D[2], Bottom - D[3]);
|
|
|
|
with MRect do
|
|
begin
|
|
P1[0] := Point(Left, Bottom);
|
|
P1[1] := TopLeft;
|
|
P1[2] := Point(Right, Top);
|
|
P1[3] := BottomRight;
|
|
end;
|
|
|
|
with IRect do
|
|
MRect := Rect(Left - D[0], Top - D[1], Right + D[2], Bottom + D[3]);
|
|
|
|
with MRect do
|
|
begin
|
|
P2[0] := Point(Left, Bottom);
|
|
P2[1] := TopLeft;
|
|
P2[2] := Point(Right, Top);
|
|
P2[3] := BottomRight;
|
|
end;
|
|
end;
|
|
|
|
{double, dotted, dashed styles need a background fill}
|
|
if (BGround <> clNone) and ([bssDouble, bssDotted, bssDashed] * StyleSet <> []) then
|
|
begin
|
|
with ORect do
|
|
OuterRegion := CreateRectRgn(Left, Top, Right, Bottom);
|
|
with IRect do
|
|
InnerRegion := CreateRectRgn(Left, Top, Right, Bottom);
|
|
CombineRgn(OuterRegion, OuterRegion, InnerRegion, RGN_DIFF);
|
|
Brush := TBrush.Create;
|
|
try
|
|
Brush.Color := ThemedColor(BGround) or PalRelative;
|
|
Brush.Style := bsSolid;
|
|
FillRgn(Canvas.Handle, OuterRegion, Brush.Handle);
|
|
finally
|
|
Brush.Free;
|
|
DeleteObject(OuterRegion);
|
|
DeleteObject(InnerRegion);
|
|
end;
|
|
end;
|
|
|
|
InPath := False;
|
|
Pn := 0;
|
|
OldPn := 0;
|
|
Start := 0;
|
|
|
|
try
|
|
for I := 0 to 3 do
|
|
begin
|
|
Color := ThemedColor(C[I]);
|
|
case S[I] of
|
|
bssSolid, bssInset, bssOutset:
|
|
begin
|
|
Bnd[0] := PO[I];
|
|
Bnd[1] := PO[(I + 1) mod 4];
|
|
Bnd[2] := PI[(I + 1) mod 4];
|
|
Bnd[3] := PI[I];
|
|
case S[I] of
|
|
bssInset:
|
|
if I in [0, 1] then
|
|
Color := Darker(Color)
|
|
else
|
|
Color := Lighter(Color);
|
|
|
|
bssOutset:
|
|
if I in [2, 3] then
|
|
Color := Darker(Color)
|
|
else
|
|
Color := Lighter(Color);
|
|
end;
|
|
DrawOnePolygon(Canvas, Bnd, Color or PalRelative, I, Print);
|
|
end;
|
|
|
|
bssRidge, bssGroove:
|
|
begin {ridge or groove}
|
|
Cl := Color;
|
|
Bnd[0] := PO[I];
|
|
Bnd[1] := PO[(I + 1) mod 4];
|
|
Bnd[2] := PM[(I + 1) mod 4];
|
|
Bnd[3] := PM[I];
|
|
case S[I] of
|
|
bssGroove:
|
|
if I in [0, 1] then
|
|
Color := Darker(Color)
|
|
else
|
|
Color := Lighter(Color);
|
|
|
|
bssRidge:
|
|
if I in [2, 3] then
|
|
Color := Darker(Color)
|
|
else
|
|
Color := Lighter(Color);
|
|
end;
|
|
DrawOnePolygon(Canvas, Bnd, Color or PalRelative, I, Print);
|
|
|
|
Color := Cl;
|
|
Bnd[0] := PM[I];
|
|
Bnd[1] := PM[(I + 1) mod 4];
|
|
Bnd[2] := PI[(I + 1) mod 4];
|
|
Bnd[3] := PI[I];
|
|
case S[I] of
|
|
bssRidge:
|
|
if I in [0, 1] then
|
|
Color := Darker(Color)
|
|
else
|
|
Color := Lighter(Color);
|
|
|
|
bssGroove:
|
|
if (I in [2, 3]) then
|
|
Color := Darker(Color)
|
|
else
|
|
Color := Lighter(Color);
|
|
end;
|
|
DrawOnePolygon(Canvas, Bnd, Color or PalRelative, I, Print);
|
|
end;
|
|
|
|
bssDouble:
|
|
begin
|
|
Color := Color or PalRelative;
|
|
|
|
Bnd[0] := PO[I];
|
|
Bnd[1] := PO[(I + 1) mod 4];
|
|
Bnd[2] := P1[(I + 1) mod 4];
|
|
Bnd[3] := P1[I];
|
|
DrawOnePolygon(Canvas, Bnd, Color, I, Print);
|
|
|
|
Bnd[0] := P2[I];
|
|
Bnd[1] := P2[(I + 1) mod 4];
|
|
Bnd[2] := PI[(I + 1) mod 4];
|
|
Bnd[3] := PI[I];
|
|
DrawOnePolygon(Canvas, Bnd, Color, I, Print);
|
|
end;
|
|
|
|
bssDashed, bssDotted:
|
|
begin
|
|
if not InPath then
|
|
begin
|
|
lb.lbStyle := BS_SOLID;
|
|
lb.lbColor := Color or PalRelative;
|
|
lb.lbHatch := 0;
|
|
if S[I] = bssDotted then
|
|
PenType := PS_Dot or ps_EndCap_Round
|
|
else
|
|
PenType := PS_Dash or ps_EndCap_Square;
|
|
Pn := ExtCreatePen(PS_GEOMETRIC or PenType or ps_Join_Miter, W[I], lb, 0, nil);
|
|
OldPn := SelectObject(Canvas.Handle, Pn);
|
|
BeginPath(Canvas.Handle);
|
|
MoveToEx(Canvas.Handle, PM[I].x, PM[I].y, nil);
|
|
Start := I;
|
|
InPath := True;
|
|
end;
|
|
LineTo(Canvas.Handle, PM[(I + 1) mod 4].x, PM[(I + 1) mod 4].y);
|
|
if (I = 3) or (S[I + 1] <> S[I]) or (C[I + 1] <> C[I]) or (W[I + 1] <> W[I]) then
|
|
begin
|
|
if (I = 3) and (Start = 0) then
|
|
CloseFigure(Canvas.Handle); {it's a closed path}
|
|
EndPath(Canvas.Handle);
|
|
StrokePath(Canvas.Handle);
|
|
SelectObject(Canvas.Handle, OldPn);
|
|
DeleteObject(Pn);
|
|
Pn := 0;
|
|
InPath := False;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
if Pn <> 0 then
|
|
begin
|
|
SelectObject(Canvas.Handle, OldPn);
|
|
DeleteObject(Pn);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ TfrxHtViewerBase }
|
|
|
|
//-- BG ---------------------------------------------------------- 24.11.2011 --
|
|
constructor TfrxHtViewerBase.Create;
|
|
begin
|
|
inherited;
|
|
PrintMarginLeft := 2.0;
|
|
PrintMarginRight := 2.0;
|
|
PrintMarginTop := 2.0;
|
|
PrintMarginBottom := 2.0;
|
|
PrintMaxHPages := 2;
|
|
Charset := DEFAULT_CHARSET;
|
|
MarginHeight := 5;
|
|
MarginWidth := 10;
|
|
DefBackground := clBtnFace;
|
|
DefFontColor := clBtnText;
|
|
DefHotSpotColor := clBlue;
|
|
DefOverLinkColor := clBlue;
|
|
DefVisitedLinkColor := clPurple;
|
|
VisitedMaxCount := 50;
|
|
DefFontSize := 12;
|
|
DefFontName := htDefFontName;
|
|
DefPreFontName := htDefPreFontName;
|
|
end;
|
|
|
|
//-- BG ---------------------------------------------------------- 16.11.2011 --
|
|
constructor TfrxHtViewerBase.CreateCopy(Source: TfrxHtViewerBase);
|
|
begin
|
|
Create;
|
|
|
|
Charset := Source.Charset;
|
|
CodePage := Source.CodePage;
|
|
DefBackGround := Source.DefBackGround;
|
|
DefFontColor := Source.DefFontColor;
|
|
DefFontName := Source.DefFontName;
|
|
DefFontSize := Source.DefFontSize;
|
|
DefHotSpotColor := Source.DefHotSpotColor;
|
|
DefOverLinkColor := Source.DefOverLinkColor;
|
|
DefPreFontName := Source.DefPreFontName;
|
|
DefVisitedLinkColor := Source.DefVisitedLinkColor;
|
|
NoSelect := Source.NoSelect;
|
|
ServerRoot := Source.ServerRoot;
|
|
|
|
MarginHeight := Source.MarginHeight;
|
|
MarginWidth := Source.MarginWidth;
|
|
PrintMarginBottom := Source.PrintMarginBottom;
|
|
PrintMarginLeft := Source.PrintMarginLeft;
|
|
PrintMarginRight := Source.PrintMarginRight;
|
|
PrintMarginTop := Source.PrintMarginTop;
|
|
PrintMaxHPages := Source.PrintMaxHPages;
|
|
HistoryMaxCount := Source.HistoryMaxCount;
|
|
VisitedMaxCount := Source.VisitedMaxCount;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetActiveColor(const Value: TColor);
|
|
begin
|
|
FOverColor := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetCharset(const Value: TFontCharset);
|
|
begin
|
|
FCharSet := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetCodePage(const Value: Integer);
|
|
begin
|
|
FCodePage := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetDefBackground(const Value: TColor);
|
|
begin
|
|
FBackground := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetFontColor(const Value: TColor);
|
|
begin
|
|
FFontColor := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetFontName(const Value: TFontName);
|
|
begin
|
|
FFontName := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetFontSize(const Value: Double);
|
|
begin
|
|
FFontSize := Value * 96.0 / Screen.PixelsPerInch;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetHistoryMaxCount(const Value: Integer);
|
|
begin
|
|
FHistoryMaxCount := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetHotSpotColor(const Value: TColor);
|
|
begin
|
|
FHotSpotColor := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetMarginHeight(const Value: Integer);
|
|
begin
|
|
FMarginHeight := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetMarginWidth(const Value: Integer);
|
|
begin
|
|
FMarginWidth := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetNoSelect(const Value: Boolean);
|
|
begin
|
|
FNoSelect := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetPreFontName(const Value: TFontName);
|
|
begin
|
|
FPreFontName := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetPrintMarginBottom(const Value: Double);
|
|
begin
|
|
FPrintMarginBottom := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetPrintMarginLeft(const Value: Double);
|
|
begin
|
|
FPrintMarginLeft := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetPrintMarginRight(const Value: Double);
|
|
begin
|
|
FPrintMarginRight := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetPrintMarginTop(const Value: Double);
|
|
begin
|
|
FPrintMarginTop := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetPrintMaxHPages(const Value: Integer);
|
|
begin
|
|
FPrintMaxHPages := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetServerRoot(const Value: ThtString);
|
|
begin
|
|
FServerRoot := ExcludeTrailingPathDelimiter(Trim(Value));
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetVisitedColor(const Value: TColor);
|
|
begin
|
|
FVisitedColor := Value;
|
|
end;
|
|
|
|
procedure TfrxHtViewerBase.SetVisitedMaxCount(const Value: Integer);
|
|
begin
|
|
FVisitedMaxCount := Value;
|
|
end;
|
|
|
|
function TfrxHtViewerBase.StoreFontName: Boolean;
|
|
begin
|
|
Result := FFontName <> htDefFontName;
|
|
end;
|
|
|
|
function TfrxHtViewerBase.StorePreFontName: Boolean;
|
|
begin
|
|
Result := FPreFontName <> htDefPreFontName;
|
|
end;
|
|
|
|
{ TfrxHtIDObject }
|
|
|
|
//-- BG ---------------------------------------------------------- 06.03.2011 --
|
|
function TfrxHtIDObject.FreeMe: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
//>-- DZ 18.09.2011
|
|
constructor TfrxHtIDObject.Create(const AHtmlId: ThtString);
|
|
begin
|
|
inherited Create;
|
|
FHtmlID:= Trim(AHtmlId);
|
|
end;
|
|
|
|
function TfrxHtIDObject.GetId(): ThtString;
|
|
begin
|
|
Result := FHtmlId;
|
|
end;
|
|
//<-- DZ
|
|
|
|
{ TfrxHtIndentRecList }
|
|
|
|
//-- BG ---------------------------------------------------------- 06.10.2016 --
|
|
function TfrxHtIndentRecList.Get(Index: Integer): TfrxHtIndentRec;
|
|
begin
|
|
Result := inherited Get(Index);
|
|
end;
|
|
|
|
{ TfrxHtFontObjBaseList }
|
|
|
|
//-- BG ---------------------------------------------------------- 06.10.2016 --
|
|
function TfrxHtFontObjBaseList.GetBase(Index: Integer): TfrxHtFontObjBase;
|
|
begin
|
|
Result := inherited Get(Index);
|
|
end;
|
|
|
|
end.
|
|
|