Delphi/FastReport_2022_VCL
Delphi/FastReport_2022_VCL
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
7062982b35
FastReport_2022_VCL/LibD28/frxHTMLUn2.pas
Daso e6303fc1c0 Inicijalizacija
2024-01-01 16:13:08 +01:00

2279 lines
64 KiB
ObjectPascal
Raw Blame History

{
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.
Reference in New Issue View Git Blame Copy Permalink