{******************************************************************} {* IPHTML.PAS - HTML Browser and associated classes *} {******************************************************************} { $Id$ } (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 * * The contents of this file are subject to the Mozilla Public License Version * 1.1 (the "License"); you may not use this file except in compliance with * the License. You may obtain a copy of the License at * http://www.mozilla.org/MPL/ * * Software distributed under the License is distributed on an "AS IS" basis, * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License * for the specific language governing rights and limitations under the * License. * * The Original Code is Turbo Power Internet Professional * * The Initial Developer of the Original Code is * TurboPower Software * * Portions created by the Initial Developer are Copyright (C) 2000-2002 * the Initial Developer. All Rights Reserved. * * 09/29/2007 DefaultTypeFace and FixedTypeFace are enabled * FactBAParag: Incremental factor for space between lines * default value is 1, * proof it with values of 0.5 = {... margin-top: 0.5em; margin-bottom: 0.5em; } * Delphi: adjustments * 10/01/2007 TextWidth of an anchor (), before = TextWidth (' ') now is only 1 * Delphi: adjustments (crush when TIpHtmlPanelH was run-time created) * 10/03/2007 Delphi: supports jpg, png, etc * * Contributor(s): * * adem baba * * ***** END LICENSE BLOCK ***** *) { Global defines potentially affecting this unit } {$I IPDEFINE.INC} {off $DEFINE IP_LAZARUS_DBG} unit IpHtml; interface uses // LCL LCLType, LCLIntf, Types, contnrs, SysUtils, Classes, TypInfo, Variants, // LCL LResources, LMessages, Messages, LCLMemManager, Graphics, Controls, StdCtrls, ExtCtrls, Buttons, Forms, ClipBrd, Dialogs, {$IFDEF UseGifImageUnit} //TODO all of this units not exists GifImage, {$ELSE} IpAnim, {$IFDEF AndersGIFImage } IpAnAGif, {$ENDIF} {$IFDEF ImageLibGIFImage } IpAnImgL, {$ENDIF} {$ENDIF} {$IFDEF UsePNGGraphic} IpPNGImg, {$ENDIF} // LazUtils LazStringUtils, LConvEncoding, LazUTF8, LazLoggerBase, AvgLvlTree, // TurboPower_ipro IpConst, IpUtils, IpHtmlTypes, IpHtmlClasses, IpHtmlProp, IpMsg, IpCSS, IpHtmlUtils, IpHtmlTabList; type {Note: Some of the code below relies on the fact that the end tag (when present) immediately follows the start tag.} {$I iphtmlgenerated.inc} type TIpEnumItemsMethod = TLCLEnumItemsMethod; TIpHtmlPoolManager = class(TLCLNonFreeMemManager) public constructor Create(TheItemSize, MaxItems : DWord); function NewItm : Pointer; end; TIpHtml = class; TIpAbstractHtmlDataProvider = class; TIpHtmlNode = class; TIpHtmlNodeCore = class; TIpHtmlNodeBlock = class; TIpHtmlNodeAlignInline = class; { TIpHtmlBaseLayouter } TIpHtmlNodeIterator = procedure (ANode: TIpHtmlNode; AProps: TIpHtmlProps; var Done: Boolean); // Abstract base class for the HTML Layout engine TIpHtmlBaseLayouter = class protected FOwner : TIpHtmlNodeCore; FElementQueue : TFPList; FCurProps : TIpHtmlProps; FBlockMin, FBlockMax : Integer; function GetProps: TIpHtmlProps; procedure ProcessDuplicateLFs; procedure RemoveLeadingLFs; public FPageRect : TRect; constructor Create(AOwner: TIpHtmlNodeCore); virtual; destructor Destroy; override; procedure ClearWordList; // Used by TIpHtmlNodeBlock descendants: Layout, CalcMinMaxPropWidth, Render procedure Layout(RenderProps: TIpHtmlProps; TargetRect: TRect); virtual; abstract; procedure CalcMinMaxPropWidth(RenderProps: TIpHtmlProps; var aMin, aMax: Integer); virtual; abstract; procedure Render(RenderProps: TIpHtmlProps); virtual; abstract; procedure IterateParents(AProc: TIpHtmlNodeIterator); public property Props : TIpHtmlProps read GetProps; end; TIpHtmlBaseLayouterClass = class of TIpHtmlBaseLayouter; { TIpHtmlBaseTableLayouter } // Abstract base class for layout methods of a HTML table TIpHtmlBaseTableLayouter = class(TIpHtmlBaseLayouter) protected FMin, FMax : Integer; FTableWidth: Integer; FCellSpacing: Integer; FCellPadding: Integer; FRowSp: TIntArr; // dynamic flag used for row spanning public constructor Create(AOwner: TIpHtmlNodeCore); override; destructor Destroy; override; // Used by TIpHtmlNodeTABLE procedure ResetSize; procedure CalcMinMaxColTableWidth(RenderProps: TIpHtmlProps; var Min, Max: Integer); virtual; abstract; procedure CalcSize(ParentWidth: Integer; RenderProps: TIpHtmlProps); virtual; abstract; function GetColCount: Integer; virtual; abstract; public property Min: Integer read FMin; property Max: Integer read FMax; property TableWidth: Integer read FTableWidth; property CellSpacing: Integer read FCellSpacing write FCellSpacing; property CellPadding: Integer read FCellPadding write FCellPadding; property RowSp: TIntArr read FRowSp; end; TIpHtmlBaseTableLayouterClass = class of TIpHtmlBaseTableLayouter; TIpHtmlElement = record ElementType : TElementType; AnsiWord: string; IsBlank : Integer; SizeProp: TIpHtmlPropA; Size: TSize; WordRect2 : TRect; Props : TIpHtmlProps; Owner : TIpHtmlNode; LFHeight : Integer; // Height of LineFeed elements IsSelected: boolean; end; PIpHtmlElement = ^TIpHtmlElement; TRectMethod = procedure(const R : TRect) of object; TIpHtmlNodeEnumProc = procedure(Node: TIpHtmlNode; const UserData: Pointer) of object; TIpHtmlNodeClass = class of TIpHtmlNode; {abstract base node} TIpHtmlNode = class(TPersistent) protected FOwner : TIpHtml; FParentNode : TIpHtmlNode; procedure ScreenLine(StartPoint, EndPoint: TPoint; const Width: Integer; const Color: TColor); procedure ScreenRect(R : TRect; const Color : TColor); procedure ScreenFrame(R : TRect; Raised: boolean); procedure ScreenPolygon(Points : array of TPoint; const Color : TColor); function PagePtToScreen(const Pt: TPoint): TPoint; procedure Invalidate; virtual; procedure InvalidateSize; virtual; procedure SubmitRequest; virtual; procedure ResetRequest; virtual; function GetHint: string; virtual; procedure CreateControl(Parent : TWinControl); virtual; procedure MakeVisible; virtual; procedure UnmarkControl; virtual; procedure HideUnmarkedControl; virtual; procedure EnumChildren(EnumProc: TIpHtmlNodeEnumProc; UserData: Pointer); virtual; procedure AppendSelection(var S : string; var Completed: Boolean); virtual; function GetMargin(AMargin: TIpHtmlElemMargin; ADefault: Integer): Integer; virtual; public constructor Create(ParentNode : TIpHtmlNode); destructor Destroy; override; procedure Enqueue; virtual; procedure EnqueueElement(const Entry: PIpHtmlElement); virtual; function ElementQueueIsEmpty: Boolean; virtual; function ExpParentWidth: Integer; virtual; procedure ImageChange(NewPicture : TPicture); virtual; function PageRectToScreen(const Rect : TRect; var ScreenRect: TRect): Boolean; procedure ReportDrawRects(M : TRectMethod); virtual; procedure ReportCurDrawRects(Owner: TIpHtmlNode; M : TRectMethod); virtual; procedure ReportMapRects(M : TRectMethod); virtual; procedure GetAttributes(Target: TStrings; IncludeValues, IncludeBlanks: Boolean); procedure SetAttributeValue(const AttrName, NewValue: string); procedure SetProps(const RenderProps: TIpHtmlProps); virtual; public property Owner : TIpHtml read FOwner; property ParentNode : TIpHtmlNode read FParentNode; end; TIpHtmlNodeNv = class(TIpHtmlNode) protected procedure Invalidate; override; procedure InvalidateSize; override; public procedure Enqueue; override; procedure EnqueueElement(const Entry: PIpHtmlElement); override; function ElementQueueIsEmpty: Boolean; override; procedure ReportDrawRects(M : TRectMethod); override; procedure SetProps(const RenderProps: TIpHtmlProps); override; end; TIpHtmlNodeMulti = class(TIpHtmlNode) private FProps: TIpHtmlProps; FChildren : TFPList; function GetChildNode(Index: Integer): TIpHtmlNode; function GetChildCount: Integer; protected procedure AppendSelection(var S : string; var Completed: Boolean); override; procedure EnumChildren(EnumProc: TIpHtmlNodeEnumProc; UserData: Pointer); override; function GetMargin(AMargin: TIpHtmlElemMargin; ADefault: Integer): Integer; override; public constructor Create(ParentNode : TIpHtmlNode); destructor Destroy; override; procedure Enqueue; override; procedure ReportDrawRects(M : TRectMethod); override; procedure ReportMapRects(M : TRectMethod); override; procedure SetProps(const RenderProps: TIpHtmlProps); override; public property ChildCount : Integer read GetChildCount; property ChildNode[Index : Integer] : TIpHtmlNode read GetChildNode; property Props : TIpHtmlProps read FProps; end; { TIpHtmlNodeCore } TIpHtmlNodeCore = class(TIpHtmlNodeMulti) private FDir: TIpHtmlDirection; FHoverPropsLookupDone: Boolean; FElementName: String; FStyle: string; FClassId: string; FTitle: string; FId: string; protected FAreaList: TFPList; FCombinedCSSProps: TCSSProps; // props from all matching CSS selectors plus inline CSS combined FHoverPropsRef: TCSSProps; // props for :hover (this is only a cached reference, we don't own it) FInlineCSSProps: TCSSProps; // props from the style attribute procedure AddArea(const R: TRect); procedure BuildAreaList; virtual; procedure ClearAreaList; virtual; function SelectCSSFont(const aFont: string): string; procedure ApplyCSSProps(const ACSSProps: TCSSProps; const props: TIpHtmlProps); function GetAlign: TIpHtmlAlign; virtual; function GetFontSizeFromCSS(CurrentFontSize:Integer; aFontSize: string):Integer; procedure SetAlign(const Value: TIpHtmlAlign); virtual; procedure SetId(const Value: string); virtual; property ElementName: String read FElementName write FElementName; public constructor Create(ParentNode : TIpHtmlNode); destructor Destroy; override; procedure LoadAndApplyCSSProps; virtual; procedure MakeVisible; override; procedure ParseBaseProps(aOwner : TIpHtml); property InlineCSS: TCSSProps read FInlineCSSProps write FInlineCSSProps; property Align: TIpHtmlAlign read GetAlign write SetAlign; property ClassId : string read FClassId write FClassId; property Dir : TIpHtmlDirection read FDir write FDir; property Id : string read FId write SetId; property Style : string read FStyle write FStyle; property Title : string read FTitle write FTitle; end; TIpHtmlNodeInline = class(TIpHtmlNodeCore) protected procedure Invalidate; override; public procedure EnqueueElement(const Entry: PIpHtmlElement); override; function ElementQueueIsEmpty: Boolean; override; end; TIpHtmlNodeAlignInline = class(TIpHtmlNodeInline) private FAlignment: TIpHtmlImageAlign; protected Element : PIpHtmlElement; procedure SetRect(TargetRect: TRect); virtual; procedure SetAlignment(const Value: TIpHtmlImageAlign); public constructor Create(ParentNode : TIpHtmlNode); destructor Destroy; override; procedure Draw(Block: TIpHtmlNodeBlock); virtual; abstract; procedure Enqueue; override; procedure CalcMinMaxWidth(var Min, Max: Integer); virtual; abstract; function GetDim(ParentWidth: Integer): TSize; virtual; abstract; {$IFDEF HTML_RTTI} published {$ENDIF} property Align : TIpHtmlImageAlign read FAlignment write SetAlignment; end; TIpHtmlNodeControl = class(TIpHtmlNodeAlignInline) protected FControl : TWinControl; Shown : Boolean; FAlt: string; FDisabled: Boolean; procedure HideUnmarkedControl; override; procedure UnmarkControl; override; function AdjustFromCss: boolean; procedure SetDisabled(const AValue: Boolean); virtual; property Disabled: Boolean read FDisabled write SetDisabled default false; public constructor Create(ParentNode : TIpHtmlNode); destructor Destroy; override; procedure AddValues(NameList, ValueList : TStringList); virtual; abstract; procedure Draw(Block: TIpHtmlNodeBlock); override; function GetDim(ParentWidth: Integer): TSize; override; procedure SetProps(const RenderProps: TIpHtmlProps); override; procedure CalcMinMaxWidth(var Min, Max: Integer); override; procedure Reset; virtual; abstract; function Successful: Boolean; virtual; abstract; public property Control: TWinControl read FControl; property Alt : string read FAlt write FAlt; end; // Used by TIpHtmlNodeBlock TWordInfo = record BaseX : Integer; BOff : Integer; CurAsc : Integer; Sz : TSize; VA : TIpHtmlVAlign3; Hs : Integer; end; PWordInfo = ^TWordInfo; TWordList = array[0..Pred(MAXWORDS)] of TWordInfo; PWordList = ^TWordList; { TIpHtmlNodeBlock } TIpHtmlNodeBlock = class(TIpHtmlNodeCore) private function GetPageRect: TRect; protected FLayouter : TIpHtmlBaseLayouter; FLastW, FLastH : Integer; FBackground : string; FBgColor : TColor; FTextColor : TColor; procedure CalcMinMaxPropWidth(RenderProps: TIpHtmlProps; var aMin, aMax: Integer); virtual; procedure Invalidate; override; function GetHeight(const RenderProps: TIpHtmlProps; const Width: Integer): Integer; procedure AppendSelection(var S : string; var Completed: Boolean); override; procedure SetBackground(const AValue: string); procedure SetBgColor(const AValue: TColor); procedure SetTextColor(const AValue: TColor); public constructor Create(ParentNode : TIpHtmlNode; LayouterClass: TIpHtmlBaseLayouterClass); overload; constructor Create(ParentNode : TIpHtmlNode); overload; destructor Destroy; override; procedure EnqueueElement(const Entry: PIpHtmlElement); override; function ElementQueueIsEmpty: Boolean; override; procedure InvalidateSize; override; procedure Layout(RenderProps: TIpHtmlProps; const TargetRect : TRect); virtual; procedure Render(RenderProps: TIpHtmlProps); virtual; function Level0: Boolean; procedure LoadAndApplyCSSProps; override; procedure ReportCurDrawRects(aOwner: TIpHtmlNode; M : TRectMethod); override; public property Layouter : TIpHtmlBaseLayouter read FLayouter; property PageRect : TRect read GetPageRect; property Background : string read FBackground write SetBackground; property BgColor : TColor read FBgColor write SetBgColor; property TextColor : TColor read FTextColor write SetTextColor; end; TIpHtmlNodeHEAD = class(TIpHtmlNodeMulti) private FProfile: string; FLang: string; public {$IFDEF HTML_RTTI} published {$ENDIF} property Lang : string read FLang write FLang; property Profile : string read FProfile write FProfile; end; TIpHtmlNodeSTYLE = class(TIpHtmlNodeMulti) private FMedia: string; FTitle: string; FType: string; public procedure EnqueueElement(const Entry: PIpHtmlElement); override; function ElementQueueIsEmpty: Boolean; override; {$IFDEF HTML_RTTI} published {$ENDIF} property Media : string read FMedia write FMedia; property Title : string read FTitle write FTitle; property Type_ : string read FType write FType; end; TIpHtmlNodeHeader = class(TIpHtmlNodeInline) private FAlign : TIpHtmlAlign; FSize : TIpHtmlHeaderSize; protected function GetAlign: TIpHtmlAlign; override; procedure SetAlign(const Value: TIpHtmlAlign); override; public constructor Create(ParentNode : TIpHtmlNode); destructor Destroy; override; procedure Enqueue; override; procedure LoadAndApplyCSSProps; override; procedure SetProps(const RenderProps: TIpHtmlProps); override; property ElementName; {$IFDEF HTML_RTTI} published {$ENDIF} // property Align : TIpHtmlAlign read FAlign write FAlign; property Size : TIpHtmlHeaderSize read FSize write FSize; end; { TIpHtmlNodeP } TIpHtmlNodeP = class(TIpHtmlNodeInline) private FAlign : TIpHtmlAlign; protected function GetAlign: TIpHtmlAlign; override; procedure SetAlign(const Value: TIpHtmlAlign); override; public constructor Create(ParentNode : TIpHtmlNode); destructor Destroy; override; procedure Enqueue; override; procedure LoadAndApplyCSSProps; override; procedure SetProps(const RenderProps: TIpHtmlProps); override; (* {$IFDEF HTML_RTTI} published {$ENDIF} property Align : TIpHtmlAlign read GetAlign write SetAlign; *) end; TIpHtmlNodeHtml = class(TIpHtmlNodeMulti) private FLang: string; FVersion: string; FDir: TIpHtmlDirection; protected procedure CalcMinMaxHtmlWidth(const RenderProps: TIpHtmlProps; var Min, Max: Integer); function GetHeight(const RenderProps: TIpHtmlProps; const Width: Integer): Integer; public function HasBodyNode: Boolean; procedure Layout(const RenderProps: TIpHtmlProps; const TargetRect : TRect); procedure Render(RenderProps: TIpHtmlProps); {$IFDEF HTML_RTTI} published {$ENDIF} property Dir : TIpHtmlDirection read FDir write FDir; property Lang : string read FLang write FLang; property Version : string read FVersion write FVersion; end; { cannot be moved to IpHtmlNodes, used by TIpHtml directly } TIpHtmlNodeTITLE = class(TIpHtmlNodeNv) private FTitle: string; public {$IFDEF HTML_RTTI} published {$ENDIF} property Title : string read FTitle write FTitle; end; { TIpHtmlNodeBODY } TIpHtmlNodeBODY = class(TIpHtmlNodeBlock) private FLink : TColor; FVLink : TColor; FALink : TColor; procedure SetAlink(const Value: TColor); procedure SetLink(const Value: TColor); procedure SetVlink(const Value: TColor); protected FBGPicture: TPicture; public constructor Create(ParentNode : TIpHtmlNode); destructor Destroy; override; procedure ImageChange(NewPicture : TPicture); override; procedure LoadAndApplyCSSProps; override; procedure Render(RenderProps: TIpHtmlProps); override; property BgPicture: TPicture read FBgPicture; {$IFDEF HTML_RTTI} published {$ENDIF} property ALink : TColor read Falink write SetAlink; property Background; property BgColor; property Link : TColor read FLink write SetLink; property VLink : TColor read FVLink write SetVlink; end; TIpHtmlNodeFRAMESET = class(TIpHtmlNodeCore) private FCols: TIpHtmlMultiLengthList; FRows: TIpHtmlMultiLengthList; public destructor Destroy; override; {$IFDEF HTML_RTTI} published {$ENDIF} property Cols : TIpHtmlMultiLengthList read FCols write FCols; property Rows : TIpHtmlMultiLengthList read FRows write FRows; property ClassID; property ID; property Title; end; TIpHtmlFrame = class; TIpHtmlNodeIFRAME = class(TIpHtmlNodeControl) private FAlign: TIpHtmlAlign; FFrameBorder: Integer; FHeight: TIpHtmlLength; FLongDesc: string; FMarginHeight: Integer; FMarginWidth: Integer; FName: string; FScrolling: TIpHtmlFrameScrolling; FSrc: string; FWidth: TIpHtmlLength; FFrame : TIpHtmlFrame; procedure SetFrameBorder(const Value: Integer); procedure SetMarginHeight(const Value: Integer); procedure SetMarginWidth(const Value: Integer); procedure SetScrolling(const Value: TIpHtmlFrameScrolling); protected procedure SetAlign(const Value: TIpHtmlAlign); override; procedure CreateControl(Parent : TWinControl); override; public destructor Destroy; override; procedure AddValues(NameList, ValueList : TStringList); override; procedure Reset; override; function Successful: Boolean; override; procedure WidthChanged(Sender: TObject); {$IFDEF HTML_RTTI} published {$ENDIF} property Align : TIpHtmlAlign read FAlign write SetAlign; property Frame: TIpHtmlFrame read FFrame; property FrameBorder : Integer read FFrameBorder write SetFrameBorder; property Height : TIpHtmlLength read FHeight write FHeight; property LongDesc : string read FLongDesc write FLongDesc; property MarginHeight : Integer read FMarginHeight write SetMarginHeight; property MarginWidth : Integer read FMarginWidth write SetMarginWidth; property Name : string read FName write FName; property Scrolling : TIpHtmlFrameScrolling read FScrolling write SetScrolling; property Src : string read FSrc write FSrc; property Width : TIpHtmlLength read FWidth write FWidth; end; TInvalidateEvent = procedure(Sender : TIpHtml; const Rect : TRect) of object; TIpHtmlBasicParser = class public function Execute: Boolean; virtual; abstract; function FindAttribute(const AttrNameSet: TIpHtmlAttributesSet): string; virtual; abstract; end; TWriteCharProvider = procedure(C : AnsiChar) of object; TIpHtmlDataGetImageEvent = procedure(Sender: TIpHtmlNode; const URL: string; var Picture: TPicture) of object; TIpHtmlScrollEvent = procedure(Sender: TIpHtml; const R: TRect; ShowAtTop: Boolean) of object; TGetEvent = procedure(Sender: TIpHtml; const URL: string) of object; TPostEvent = procedure(Sender: TIpHtml; const URL: string; FormData: TIpFormDataEntity) of object; TIFrameCreateEvent = procedure(Sender: TIpHtml; Parent: TWinControl; Frame: TIpHtmlNodeIFRAME; var Control: TWinControl) of object; TURLCheckEvent = procedure(Sender: TIpHtml; const URL: string; var Visited: Boolean) of object; TReportURLEvent = procedure(Sender: TIpHtml; const URL: string) of object; TIpHtmlRectListEntry = record Rect : TRect; Element : PIpHtmlElement; Block : TIpHtmlNodeBlock; end; PIpHtmlRectListEntry = ^TIpHtmlRectListEntry; TControlEvent = procedure(Sender: TIpHtml; Node: TIpHtmlNodeControl) of object; TControlEvent2 = procedure(Sender: TIpHtml; Node: TIpHtmlNodeControl; var cancel: boolean) of object; TIpHtml = class private FHotNode : TIpHtmlNode; FCurElement : PIpHtmlElement; FHotPoint : TPoint; FMouseLastPoint : TPoint; FOnInvalidateRect : TInvalidateEvent; FTarget : TCanvas; FVLinkColor: TColor; FLinkColor: TColor; FALinkColor: TColor; FTextColor: TColor; FBgColor: TColor; FFontQuality: TFontQuality; FFactBAParag: Real; FHasFrames : Boolean; FLinksUnderlined: Boolean; FOnGetImageX : TIpHtmlDataGetImageEvent; FOnScroll : TIpHtmlScrollEvent; FOnInvalidateSize : TNotifyEvent; FOnGet: TGetEvent; FOnPost: TPostEvent; FOnIFrameCreate : TIFrameCreateEvent; FOnURLCheck: TURLCheckEvent; FOnReportURL: TReportURLEvent; FControlClick : TControlEvent; FControlClick2 : TControlEvent2; FControlOnEditingDone : TControlEvent; FControlOnChange : TControlEvent; FControlCreate : TControlEvent; FCurFrameSet : TIpHtmlNodeFRAMESET; FCanPaint : Boolean; FMarginHeight: Integer; FMarginWidth: Integer; FRenderDev: TIpHtmlRenderDevice; FCSS: TCSSGlobalProps; FDocCharset: string; FTabList: TIpHtmlTabList; FNeedResize: Boolean; FParser: TIpHtmlBasicParser; protected CharStream : TStream; FHtml : TIpHtmlNodeHtml; FFlagErrors : Boolean; FPageRect : TRect; FClientRect : TRect; {the coordinates of the paint rectangle} FPageViewRect : TRect; {the current section of the page} FPageViewBottom : Integer; {the lower end of the page, may be different from PageViewRect.Bottom } FPageViewTop: Integer; { the upper end of the page } DefaultProps : TIpHtmlProps; FBody : TIpHtmlNodeBODY; FTitleNode : TIpHtmlNodeTITLE; FDataProvider: TIpAbstractHtmlDataProvider; IdList: TStringList; GifQueue : TFPList; PaintBufferBitmap : TBitmap; PaintBuffer : TCanvas; Destroying : Boolean; FAllSelected : Boolean; RectList : TFPList; FStartSel, FEndSel : TPoint; ElementPool : TIpHtmlPoolManager; FCurURL : string; RenderCanvas : TCanvas; FPageHeight : Integer; FFixedTypeface: string; FDefaultTypeFace: string; FDefaultFontSize: integer; procedure ResetCanvasData; procedure ResetWordLists; procedure ResetBlocks(Node: TIpHtmlNode); procedure ResetImages(Node: TIpHtmlNode); procedure ResetElementMetrics(P: Pointer); function CheckKnownURL(URL: string): boolean; procedure ReportReference(URL: string); procedure PaintSelection; function FindAttribute(const AttrNameSet: TIpHtmlAttributesSet): string; procedure Parse; procedure SetDefaultProps; procedure MakeVisible(const R: TRect; ShowAtTop: Boolean = True); procedure InvalidateSize; procedure ClearGifQueue; procedure StartGifPaint(Target: TCanvas); procedure ClearAreaLists; procedure BuildAreaList; procedure ClearRectList; procedure CreateIFrame(Parent: TWinControl; Frame: TIpHtmlNodeIFRAME; var Control: TWinControl); procedure FinalizeRecs(P: Pointer); procedure AddWordEntry(const Value: string; Props: TIpHtmlProps; Owner: TIpHtmlNode); function FindElement(const Name: string): TIpHtmlNode; function FindElementId(const Id: String): TIpHtmlNode; procedure Clear; {clear any contents} procedure Home; function GetPageRect(TargetCanvas: TCanvas; Width, Height : Integer): TRect; // computes the layout for this Canvas procedure MouseMove(Pt : TPoint); procedure DeselectAllItems(Item: Pointer); procedure SetSelection(StartPoint, EndPoint: TPoint); function HaveSelection: Boolean; procedure CopyToClipboard; procedure ReportReferences(Node: TIpHtmlNode); procedure RequestImageNodes(Node: TIpHtmlNode); procedure SelectAll; procedure DeselectAll; property HotNode: TIpHtmlNode read FHotNode; property CurElement: PIpHtmlElement read FCurElement write FCurElement; property HotPoint: TPoint read FHotPoint; property OnInvalidateRect: TInvalidateEvent read FOnInvalidateRect write FOnInvalidateRect; property TextColor: TColor read FTextColor write FTextColor; property LinkColor: TColor read FLinkColor write FLinkColor; property VLinkColor: TColor read FVLinkColor write FVLinkColor; property ALinkColor: TColor read FALinkColor write FALinkColor; property BgColor: TColor read FBgColor write FBgColor; property HasFrames: Boolean read FHasFrames; property OnGetImageX: TIpHtmlDataGetImageEvent read FOnGetImageX write FOnGetImageX; property OnScroll: TIpHtmlScrollEvent read FOnScroll write FOnScroll; property OnInvalidateSize: TNotifyEvent read FOnInvalidateSize write FOnInvalidateSize; property OnGet: TGetEvent read FOnGet write FOnGet; property OnPost: TPostEvent read FOnPost write FOnPost; property OnIFrameCreate: TIFrameCreateEvent read FOnIFrameCreate write FOnIFrameCreate; property OnURLCheck: TURLCheckEvent read FOnURLCheck write FOnURLCheck; property OnReportURL: TReportURLEvent read FOnReportURL write FOnReportURL; property OnControlClick: TControlEvent read FControlClick write FControlClick; property OnControlClick2: TControlEvent2 read FControlClick2 write FControlClick2; property OnControlEditingDone: TControlEvent read FControlOnEditingDone write FControlOnEditingDone; property OnControlChange: TControlEvent read FControlOnChange write FControlOnChange; property OnControlCreate: TControlEvent read FControlCreate write FControlCreate; property CanPaint: Boolean read FCanPaint; property MarginWidth: Integer read FMarginWidth write FMarginWidth default 20; property MarginHeight: Integer read FMarginHeight write FMarginHeight default 20; function GetSelectionBlocks(out StartSelIndex,EndSelIndex: Integer): boolean; function getControlCount:integer; function getControl(i:integer):TIpHtmlNode; public ControlParent: TWinControl; DoneLoading : Boolean; SoftLF, HardLF, SoftHyphen, HardLFClearLeft, HardLFClearRight, HardLFClearBoth : PIpHtmlElement; LIndent, LOutdent : PIpHtmlElement; AnchorList : TFPList; AreaList : TFPList; ControlList : TFPList; MapList : TFPList; NameList : TStringList; PropACache : TIpHtmlPropsAList; PropBCache : TIpHtmlPropsBList; MapImgList : TFPList; DefaultImage : TPicture; {$IFDEF UseGifImageUnit} GifImages : TFPList; {$ELSE} AnimationFrames : TFPList; {$ENDIF} public constructor Create; destructor Destroy; override; procedure AddGifQueue(Graphic: TGraphic; const R: TRect); procedure AddRect(const R: TRect; AElement: PIpHtmlElement; ABlock: TIpHtmlNodeBlock); procedure AddWord(Value: string; Props: TIpHtmlProps; Owner: TIpHtmlNode); function BuildStandardEntry(EType: TElementType): PIpHtmlElement; function BuildLinefeedEntry(EType: TElementType; AHeight: Integer): PIpHtmlElement; function BuildPath(const Ext: string): string; procedure ClearAreaList; procedure ControlCreate(Sender: TIpHtmlNodeControl); procedure ControlClick(Sender: TIpHtmlNodeControl); procedure ControlClick2(Sender: TIpHtmlNodeControl; var cancel: boolean); procedure ControlOnChange(Sender: TIpHtmlNodeControl); procedure ControlOnEditingDone(Sender: TIpHtmlNodeControl); procedure DoGetImage(Sender: TIpHtmlNode; const URL: string; var Picture: TPicture); procedure FixMissingBodyTag; procedure Get(const URL: string); procedure InvalidateRect(R : TRect); function LinkVisited(const URL: string): Boolean; property LinksUnderlined: Boolean read FLinksUnderlined write FLinksUnderlined; procedure LoadFromStream(S : TStream); function NewElement(EType : TElementType; Own: TIpHtmlNode) : PIpHtmlElement; function PagePtToScreen(const Pt: TPoint): TPoint; function PageRectToScreen(const Rect: TRect; var ScreenRect: TRect): Boolean; procedure Post(const URL: string; FormData: TIpFormDataEntity); procedure Render(TargetCanvas: TCanvas; TargetPageRect : TRect; UsePaintBuffer: Boolean; const TopLeft: TPoint); overload; procedure Render(TargetCanvas: TCanvas; TargetPageRect: TRect; APageTop, APageBottom: Integer; UsePaintBuffer: Boolean; const TopLeft: TPoint); overload; {$IFOPT C+} procedure CheckImage(Picture: TPicture); {$ENDIF} {$IFDEF IP_LAZARUS_DBG} procedure DebugChild(Node: TIpHtmlNode; const UserData: Pointer); procedure DebugAll; {$ENDIF} property AllSelected : Boolean read FAllSelected; property Body: TIpHtmlNodeBODY read FBody; property CSS: TCSSGlobalProps read FCSS write FCSS; property DataProvider: TIpAbstractHtmlDataProvider read FDataProvider; property FlagErrors : Boolean read FFlagErrors write FFlagErrors; property FixedTypeface: string read FFixedTypeface write FFixedTypeface; property DefaultTypeFace: string read FDefaultTypeFace write FDefaultTypeFace; property DefaultFontSize: integer read FDefaultFontSize write FDefaultFontSize; property FontQuality: TFontQuality read FFontQuality write FFontQuality; property HtmlNode : TIpHtmlNodeHtml read FHtml; property CurUrl: string read FCurUrl; property TabList: TIpHtmlTabList read FTabList; property DocCharset: String read FDocCharset; // Encoding of html text property Target: TCanvas read FTarget; property TitleNode : TIpHtmlNodeTITLE read FTitleNode; property PageHeight : Integer read FPageHeight; property PageViewRect : TRect read FPageViewRect; property PageViewBottom: Integer read FPageViewBottom; property PageViewTop: Integer read FPageViewTop; property ClientRect : TRect read FClientRect; property ControlsCount: integer read getControlCount; property Controls[i:integer]: TIpHtmlNode read getControl; property FrameSet : TIpHtmlNodeFRAMESET read FCurFrameSet; property FactBAParag: Real read FFactBAParag write FFactBAParag; property MouseLastPoint : TPoint read FMouseLastPoint; property RenderDevice: TIpHtmlRenderDevice read FRenderDev; property NeedResize: Boolean read FNeedResize write FNeedResize; end; TIpHtmlInternalPanel = class; TIpHtmlScrollBar = class private FKind: TScrollBarKind; FIncrement: TScrollBarInc; FPosition: Integer; FRange: Integer; FTracking: Boolean; FVisible: Boolean; procedure SetPosition(Value: Integer); procedure SetVisible(Value: Boolean); protected FControl: TIpHtmlInternalPanel; FPageIncrement: TScrollbarInc; FCalcRange: Integer; FUpdateNeeded: Boolean; procedure CalcAutoRange; function ControlSize(ControlSB, AssumeSB: Boolean): Integer; procedure DoSetRange(Value: Integer); function NeedsScrollBarVisible: Boolean; procedure ScrollMessage(var Msg: TLMScroll); procedure Update(ControlSB, AssumeSB: Boolean); public constructor Create(AControl: TIpHtmlInternalPanel; AKind: TScrollBarKind); property Kind: TScrollBarKind read FKind; property Increment: TScrollBarInc read FIncrement write FIncrement stored False default 8; property Position: Integer read FPosition write SetPosition default 0; property Range: Integer read FRange {write SetRange stored IsRangeStored default 0}; property Tracking: Boolean read FTracking write FTracking default False; property Visible: Boolean read FVisible write SetVisible default True; end; TIpHtmlCustomPanel = class; { TIpHtmlInternalPanel } TIpHtmlInternalPanel = class(TCustomControl) private FHyper : TIpHtml; FPageRect : TRect; FPageRectValid: boolean; FAutoScroll: Boolean; FOnHotChange : TNotifyEvent; FOnCurElementChange : TNotifyEvent; FOnHotClick : TNotifyEvent; FOnClick : TNotifyEvent; function GetPageRect: TRect; procedure SetHtml(const Value: TIpHtml); procedure SetPageRect(const Value: TRect); protected FUpdatingScrollbars : Boolean; {$IFDEF Html_Print} InPrint: Integer; {$ENDIF} SettingPageRect : Boolean; FPaintingLock: Integer; MouseDownX, MouseDownY : Integer; HaveSelection, MouseIsDown, NewSelection : Boolean; SelStart, SelEnd : TPoint; HintWindow : THintWindow; CurHint : string; HintX, HintY : Integer; HintShownHere : Boolean; Printed: Boolean; procedure UpdateScrollBars; procedure ClearSelection; procedure SetSelection; procedure ScrollPtInView(P: TPoint); procedure ShowHintNow(const NewHint: string); procedure CreateParams(var Params: TCreateParams); override; procedure Paint; override; procedure WMHScroll(var Message: TLMHScroll); message LM_HSCROLL; procedure WMVScroll(var Message: TLMVScroll); message LM_VSCROLL; procedure AsyncHotInvoke(data: ptrint); procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseLeave; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override; procedure DoHotChange; procedure DoCurElementChange; procedure DoHotInvoke; procedure DoClick; procedure DoOnResize; override; procedure ScrollInView(R : TRect); procedure ScrollInViewRaw(R : TRect); function PagePtToScreen(const Pt : TPoint): TPoint; procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND; procedure HideHint; function HtmlPanel: TIpHtmlCustomPanel; {$IFDEF Html_Print} procedure BeginPrint; procedure ResetPrint; procedure EndPrint; {$ENDIF} public ViewTop, ViewLeft : Integer; HScroll, VScroll : TIpHtmlScrollBar; {$IFDEF Html_Print} PrintPageRect : TRect; PrintWidth, PrintHeight: Integer; PrintTopLeft: TPoint; PageCount: Integer; function PreviewAntiAliasingMode: TAntiAliasingMode; {$ENDIF} procedure InvalidateSize; property Hyper : TIpHtml read FHyper write SetHtml; property PageRect : TRect read GetPageRect write SetPageRect; constructor Create(AOwner: TComponent); override; property AutoScroll: Boolean read FAutoScroll write FAutoScroll; property OnHotChange : TNotifyEvent read FOnHotChange write FOnHotChange; property OnCurElementChange: TNotifyEvent read FOnCurElementChange write FOnCurElementChange; property OnHotClick : TNotifyEvent read FOnHotClick write FOnHotClick; property OnClick : TNotifyEvent read FOnClick write FOnClick; destructor Destroy; override; procedure ScrollRequest(Sender: TIpHtml; const R: TRect; ShowAtTop: Boolean = True); {$IFDEF Html_Print} function GetPrintPageCount: Integer; procedure PrintPages(FromPage, ToPage: Integer); procedure PrintPreview; function SelectPrinterDlg: boolean; {$ENDIF} procedure EraseBackground(DC: HDC); override; end; { TIpAbstractHtmlDataProvider } TIpAbstractHtmlDataProvider = class(TIpBaseComponent) protected function DoGetHtmlStream(const URL: string; PostData: TIpFormDataEntity) : TStream; virtual; abstract; function DoCheckURL(const URL: string; var ContentType: string): Boolean; virtual; abstract; procedure DoLeave(Html: TIpHtml); virtual; abstract; procedure DoReference(const URL: string); virtual; abstract; procedure DoGetImage(Sender: TIpHtmlNode; const URL: string; var Picture: TPicture); virtual; abstract; function CanHandle(const URL: string): Boolean; virtual; abstract; public // The following methods were protected in the original code // but had to be made public to cooperate with the TIpHtmlParser. function BuildURL(const OldURL, NewURL: string): string; virtual; abstract; { provider assumes ownership of returned TStream and will free it when done using it. } function DoGetStream(const URL: string): TStream; virtual; abstract; end; TIpHtmlEnumerator = procedure(Document: TIpHtml) of object; TIpHtmlFrame = class protected FCURURL : string; FCurAnchor : string; FViewer: TIpHtmlCustomPanel; FNoScroll: Boolean; FFramePanel : TPanel; Pnl : array[0..Pred(IPMAXFRAMES)] of TPanel; FMarginWidth, FMarginHeight : Integer; FFlagErrors : Boolean; PostData : TIpFormDataEntity; FHtml : TIpHtml; HyperPanel : TIpHtmlInternalPanel; FFrameCount : Integer; FFrames : array[0..Pred(IPMAXFRAMES)] of TIpHtmlFrame; FDataProvider : TIpAbstractHtmlDataProvider; FParent : TCustomPanel; FName : string; InOpen: Boolean; procedure InvalidateRect(Sender: TIpHtml; const R : TRect); procedure FramePanelResize(Sender: TObject); procedure AlignPanels; procedure InvalidateSize(Sender: TObject); procedure Get(Sender: TIpHtml; const URL: string); procedure Post(Sender: TIpHtml; const URL: string; FormData: TIpFormDataEntity); procedure IFrameCreate(Sender: TIpHtml; Parent: TWinControl; Frame: TIpHtmlNodeIFRAME; var Control: TWinControl); procedure InitHtml; procedure EnumDocuments(Enumerator: TIpHtmlEnumerator); procedure ControlClick(Sender: TIpHtml; Node: TIpHtmlNodeControl); procedure ControlClick2(Sender: TIpHtml; Node: TIpHtmlNodeControl; var cancel: boolean); procedure ControlOnChange(Sender: TIpHtml; Node: TIpHtmlNodeControl); procedure ControlOnEditingDone(Sender: TIpHtml; Node: TIpHtmlNodeControl); procedure ControlCreate(Sender: TIpHtml; Node: TIpHtmlNodeControl); procedure OpenRelativeURL(const URL: string); procedure SelectAll; procedure DeselectAll; procedure CopyToClipboard; function HaveSelection: Boolean; function FindFrame(const FrameName: string): TIpHtmlFrame; procedure MakeAnchorVisible(const URL: string); function Scroll(Action: TIpScrollAction; ADistance: Integer = 100): Boolean; procedure Home; function IsExternal(const URL: string): Boolean; procedure SetHtml(NewHtml : TIpHtml); procedure Stop; function getFrame(i: integer): TIpHtmlFrame; procedure InternalFreeFrames; procedure InternalCreateFrames; procedure RemoveDataProvider; public constructor Create(Viewer: TIpHtmlCustomPanel; Parent: TCustomPanel; DataProvider : TIpAbstractHtmlDataProvider; FlagErrors, NoScroll: Boolean; MarginWidth, MarginHeight: Integer); destructor Destroy; override; procedure OpenURL(const URL: string; Delayed: Boolean); property CurUrl: string read FCurUrl; property CurAnchor : string read FCurAnchor; property Html: TIpHtml read FHtml; property FramePanel : TPanel read FFramePanel; property Name: string read FName; property FrameCount: integer read FFrameCount; property Frames[i:integer] : TIpHtmlFrame read getFrame; property Viewer: TIpHtmlCustomPanel read FViewer; end; TIpHtmlCustomScanner = class; TIpHtmlNVFrame = class protected FCURURL : string; FCurAnchor : string; FScanner: TIpHtmlCustomScanner; FFlagErrors : Boolean; PostData : TIpFormDataEntity; FHtml : TIpHtml; FFrameCount : Integer; FFrames : array[0..Pred(IPMAXFRAMES)] of TIpHtmlNVFrame; FDataProvider : TIpAbstractHtmlDataProvider; FName : string; procedure InitHtml; procedure EnumDocuments(Enumerator: TIpHtmlEnumerator); procedure OpenRelativeURL(const URL: string); procedure SelectAll; procedure CopyToClipboard; function HaveSelection: Boolean; function FindFrame(const FrameName: string): TIpHtmlNvFrame; procedure MakeAnchorVisible(const URL: string); procedure Home; procedure Stop; function getFrame(i: integer): TIpHtmlNVFrame; public constructor Create(Scanner: TIpHtmlCustomScanner; DataProvider : TIpAbstractHtmlDataProvider; FlagErrors: Boolean); destructor Destroy; override; procedure OpenURL(const URL: string); property CurUrl: string read FCurUrl; property CurAnchor : string read FCurAnchor; property Html: TIpHtml read FHtml; property Name: string read FName; property FrameCount: integer read FFrameCount; property Frames[i:integer] : TIpHtmlNVFrame read getFrame; property Scanner: TIpHtmlCustomScanner read FScanner; end; TIpHtmlControlEvent = procedure(Sender: TIpHtmlCustomPanel; Frame: TIpHtmlFrame; Html: TIpHtml; Node: TIpHtmlNodeControl) of object; TIpHtmlControlEvent2 = procedure(Sender: TIpHtmlCustomPanel; Frame: TIpHtmlFrame; Html: TIpHtml; Node: TIpHtmlNodeControl; var cancel: boolean) of object; { TIpHtmlCustomPanel } TIpHtmlHotURLEvent = procedure (Sender: TObject; const URL: String) of object; TIpHtmlCustomPanel = class(TCustomPanel) private FHotChange : TNotifyEvent; FHotClick : TNotifyEvent; FHotURLEvent: TIpHtmlHotURLEvent; FControlClick : TIpHtmlControlEvent; FControlClick2 : TIpHtmlControlEvent2; FControlOnEditingDone : TIpHtmlControlEvent; FControlOnChange : TIpHtmlControlEvent; FControlCreate : TIpHtmlControlEvent; FCurElementChange: TNotifyEvent; FDocumentOpen: TNotifyEvent; FAllowTextSelect: Boolean; FCurElement : PIpHtmlElement; FPrintSettings: TIpHtmlPrintSettings; FFactBAParag: Real; FFontQuality: TFontQuality; FWantTabs: Boolean; FScrollDist: Integer; FUsePaintBuffer: Boolean; procedure SetDataProvider(const AValue: TIpAbstractHtmlDataProvider); procedure SetFactBAParag(const Value: Real); function FactBAParagNotIs1: Boolean; function GetVScrollPos: Integer; procedure SetVScrollPos(const Value: Integer); procedure SetFontQuality(const AValue: TFontQuality); protected FFlagErrors: Boolean; FFixedTypeface: string; FDefaultTypeFace: string; FDefaultFontSize: integer; FHotURL: string; FDataProvider: TIpAbstractHtmlDataProvider; URLStack : TStringList; TargetStack : TStringList; Stp : Integer; VisitedList : TStringMap; FVLinkColor: TColor; FLinkColor: TColor; FALinkColor: TColor; FTextColor: TColor; FBgColor: TColor; FLinksUnderlined: Boolean; FShowHints: Boolean; FMarginHeight: Integer; FMarginWidth: Integer; FMasterFrame : TIpHtmlFrame; FHotNode : TIpHtmlNode; GetURL : string; PostURL : string; PostData : TIpFormDataEntity; procedure Push(const Target, URL: string); function GetTitle: string; procedure InternalOpenURL(const Target, HRef: string); procedure URLCheck(Sender: TIpHtml; const URL: string; var Visited: Boolean); procedure ReportURL(Sender: TIpHtml; const URL: string); procedure Paint; override; procedure HotChange(Sender: TObject); procedure CurElementChange(Sender: TObject); procedure HotClick(Sender: TObject); procedure ClientClick(Sender: TObject); procedure DoHotChange; procedure DoHotClick; procedure DoOnMouseWheel(Shift: TShiftState; Delta, XPos, YPos: SmallInt); procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure WMGetDlgCode(var Msg : TMessage); message WM_GETDLGCODE; procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND; procedure CMIpHttpGetRequest(var Message: TMessage); message CM_IpHttpGetRequest; procedure ControlClick(pFrame: TIpHtmlFrame; pHtml: TIpHtml; pNode: TIpHtmlNodeControl); procedure ControlClick2(pFrame: TIpHtmlFrame; pHtml: TIpHtml; pNode: TIpHtmlNodeControl; var pCancel: boolean); procedure ControlOnChange(pFrame: TIpHtmlFrame; pHtml: TIpHtml; pNode: TIpHtmlNodeControl); procedure ControlOnEditingdone(pFrame: TIpHtmlFrame; pHtml: TIpHtml; pNode: TIpHtmlNodeControl); procedure ControlCreate(pFrame: TIpHtmlFrame; pHtml: TIpHtml; pNode: TIpHtmlNodeControl); function GetVersion : string; function GetCurUrl: string; procedure SetVersion(const Value : string); procedure SetDefaultTypeFace(const Value: string); procedure SetDefaultFontSize(const Value: integer); procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean); override; property UsePaintBuffer: Boolean read FUsePaintBuffer write FUsePaintBuffer default true; public {$IFDEF Html_Print} function GetPrintPageCount: Integer; {$ENDIF} constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure EraseBackground(DC: HDC); override; procedure CopyToClipboard; procedure EnumDocuments(Enumerator: TIpHtmlEnumerator); procedure GoBack; function canGoBack : boolean; procedure GoForward; function canGoForward : boolean; function HaveSelection: Boolean; property MasterFrame : TIpHtmlFrame read FMasterFrame; property HotNode : TIpHtmlNode read FHotNode; function IsURLHtml(const URL: string): Boolean; procedure MakeAnchorVisible(const Name: string); procedure OpenURL(const URL: string); function Scroll(Action: TIpScrollAction; ADistance: Integer = 100): Boolean; procedure SelectAll; procedure DeselectAll; procedure SetHtml(NewHtml : TIpHtml); procedure SetHtmlFromFile(const AFileName: String); procedure SetHtmlFromStr(NewHtml : string); procedure SetHtmlFromStream(NewHtml : TStream); procedure Stop; {$IFDEF Html_Print} procedure Print(FromPg, ToPg: LongInt); procedure PrintPreview; {$ENDIF} function GetContentSize: TSize; property VScrollPos: Integer read GetVScrollPos write SetVScrollPos; property BgColor: TColor read FBgColor write FBgColor default clWhite; property ALinkColor: TColor read FALinkColor write FALinkColor default clRed; property AllowTextSelect: Boolean read FAllowTextSelect write FAllowTextSelect default True; property CurElement: PIpHtmlElement read FCurElement; property DataProvider: TIpAbstractHtmlDataProvider read FDataProvider write SetDataProvider; property FactBAParag: Real read FFactBAParag write SetFactBAParag stored FactBAParagNotIs1; property FlagErrors: Boolean read FFlagErrors write FFlagErrors; property FixedTypeface: string read FFixedTypeface write FFixedTypeface; property DefaultTypeFace: string read FDefaultTypeFace write SetDefaultTypeFace; property DefaultFontSize: integer read FDefaultFontSize write SetDefaultFontSize; property FontQuality: TFontQuality read FFontQuality write SetFontQuality default fqDefault; property HotURL: string read FHotURL; property LinkColor: TColor read FLinkColor write FLinkColor default clBlue; property LinksUnderlined: Boolean read FLinksUnderlined write FLinksUnderlined default DEFAULT_LINKS_UNDERLINED; property MarginHeight: Integer read FMarginHeight write FMarginHeight default 10; property MarginWidth: Integer read FMarginWidth write FMarginWidth default 10; property PrintSettings: TIpHtmlPrintSettings read FPrintSettings write FPrintSettings; property ScrollDist: Integer read FScrollDist write FScrollDist default 100; property ShowHints: Boolean read FShowHints write FShowHints default True; property TextColor: TColor read FTextColor write FTextColor default clBlack; property Title: string read GetTitle; property VLinkColor: TColor read FVLinkColor write FVLinkColor default clMaroon; property OnControlClick: TIpHtmlControlEvent read FControlClick write FControlClick; property OnControlClick2: TIpHtmlControlEvent2 read FControlClick2 write FControlClick2; property OnControlEditingDone: TIpHtmlControlEvent read FControlOnEditingDone write FControlOnEditingDone; property OnControlChange: TIpHtmlControlEvent read FControlOnChange write FControlOnChange; property OnControlCreate: TIpHtmlControlEvent read FControlCreate write FControlCreate; property OnCurElementChange: TNotifyEvent read FCurElementChange write FCurElementChange; property OnDocumentOpen: TNotifyEvent read FDocumentOpen write FDocumentOpen; property OnHotChange: TNotifyEvent read FHotChange write FHotChange; property OnHotClick: TNotifyEvent read FHotClick write FHotClick; property OnHotURL: TIpHtmlHotURLEvent read FHotURLEvent write FHotURLEvent; property CurURL: string read GetCurUrl; property WantTabs: Boolean read FWantTabs write FWantTabs default True; published property Version: string read GetVersion write SetVersion stored False; end; TIpHtmlPanel = class(TIpHtmlCustomPanel) published property Align; property ALinkColor; property AllowTextSelect; property Anchors; property BgColor; property BorderSpacing; property BorderWidth; property BorderStyle; property Constraints; property DataProvider; property Enabled; property FixedTypeface; property FontQuality; property DefaultTypeFace; property DefaultFontSize; property FactBAParag; property FlagErrors; property LinkColor; property LinksUnderlined; property MarginHeight; property MarginWidth; property PopupMenu; property PrintSettings; property ScrollDist; property ShowHints; property TabOrder; property TabStop; property TextColor; property UsePaintBuffer; property Visible; property VLinkColor; property WantTabs; property OnClick; property OnConstrainedResize; property OnContextPopup; property OnControlClick; property OnControlClick2; property OnControlChange; property OnControlEditingDone; property OnControlCreate; property OnCurElementChange; property OnDocumentOpen; property OnEnter; property OnExit; property OnHotChange; property OnHotClick; property OnHotURL; end; TIpHtmlCustomScanner = class(TComponent) private FDataProvider: TIpAbstractHtmlDataProvider; FFlagErrors: Boolean; function GetTitle: string; function GetVersion : string; procedure SetVersion(const Value : string); protected URLStack : TStringList; TargetStack : TStringList; Stp : Integer; FCurURL : string; FMasterFrame : TIpHtmlNVFrame; procedure Push(const Target, URL: string); procedure InternalOpenURL(const Target, HRef: string); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure EnumDocuments(Enumerator: TIpHtmlEnumerator); function IsURLHtml(const URL: string): Boolean; procedure OpenURL(const URL: string); procedure Stop; property MasterFrame : TIpHtmlNVFrame read FMasterFrame; property DataProvider: TIpAbstractHtmlDataProvider read FDataProvider write FDataProvider; property FlagErrors : Boolean read FFlagErrors write FFlagErrors; property Title : string read GetTitle; property CurUrl: string read FCurUrl; published property Version : string read GetVersion write SetVersion stored False; end; TIpHtmlScanner = class(TIpHtmlCustomScanner) published property DataProvider; property FlagErrors; end; TIdFindNodeCriteria = function(ACurrNode: TIpHtmlNodeCore; const AParamStr: string): Boolean; var // LayouterClass is initialized by the layout unit. BlockLayouterClass: TIpHtmlBaseLayouterClass; TableElemLayouterClass: TIpHtmlBaseLayouterClass; TableLayouterClass: TIpHtmlBaseTableLayouterClass; function SizeRec(cx, cy: Integer): TSize; function StdIndent: Integer; procedure SetWordRect(Element: PIpHtmlElement; const Value: TRect); function CalcMultiLength(const List: TIpHtmlMultiLengthList; Avail: Integer; var Sections: Integer): TIntArr; //function GetAlignmentForStr(str: string; pDefault: TIpHtmlAlign = haDefault): TIpHtmlAlign; procedure TrimFormatting(const S: string; Target: PAnsiChar; PreFormatted: Boolean = False); function dbgs(et: TElementType): string; overload; function GetNextSiblingNode(ANode: TIpHtmlNode): TIpHtmlNode; function GetPrevSiblingNode(ANode: TIpHtmlNode): TIpHtmlNode; function GetParentNodeOfClass(ANode: TIpHtmlNode; AClass: TIpHtmlNodeClass): TIpHtmlNode; function FindNode(ANode: TIpHtmlNode; ACriteria: TIdFindNodeCriteria; const AParamStr: string): TIpHtmlNodeCore; function FindNodeByElemId(ANode: TIpHtmlNode; const AElemId: string): TIpHtmlNodeCore; function FindNodeByElemClass(ANode: TIpHtmlNode; const AElemClass: string): TIpHtmlNodeCore; procedure Register; implementation uses // ipHtmlBlockLayout and ipHtmlTableLayout should not be needed here but // the initialization section is not called otherwise. {$IFDEF Html_Print} Printers, PrintersDlgs, IpHtmlPv, {$ENDIF} ipHtmlNodes, ipHtmlParser, ipHtmlBlockLayout, ipHtmlTableLayout; {$R *.res} var FlatSB_GetScrollInfo: function(hWnd: HWND; BarFlag: Integer; var ScrollInfo: TScrollInfo): BOOL; stdcall; FlatSB_GetScrollPos: function(hWnd: HWND; nBar: Integer): Integer; stdcall; FlatSB_SetScrollPos: function(hWnd: HWND; nBar, nPos: Integer; bRedraw: BOOL): Integer; stdcall; FlatSB_SetScrollProp: function(p1: HWND; index: Integer; newValue: Integer; p4: Bool): Bool; stdcall; FlatSB_SetScrollInfo: function(hWnd: HWND; BarFlag: Integer; const ScrollInfo: TScrollInfo; Redraw: BOOL): Integer; stdcall; const MaxElements = 1024*1024; // ShyChar = #1; {character used to represent soft-hyphen in strings} // NbspChar = #2; {character used to represent no-break space in strings} // NbspUtf8 = #194#160; {utf8 code of no-break space character} WheelDelta = 8; const WSB_PROP_CYVSCROLL = $00000001; WSB_PROP_CXHSCROLL = $00000002; WSB_PROP_CYHSCROLL = $00000004; WSB_PROP_CXVSCROLL = $00000008; WSB_PROP_CXHTHUMB = $00000010; WSB_PROP_CYVTHUMB = $00000020; WSB_PROP_VBKGCOLOR = $00000040; WSB_PROP_HBKGCOLOR = $00000080; WSB_PROP_VSTYLE = $00000100; WSB_PROP_HSTYLE = $00000200; WSB_PROP_WINSTYLE = $00000400; WSB_PROP_PALETTE = $00000800; WSB_PROP_MASK = $00000FFF; FSB_FLAT_MODE = 2; FSB_ENCARTA_MODE = 1; FSB_REGULAR_MODE = 0; {$IFDEF IP_LAZARUS_DBG} procedure DumpTIpHtmlProps(aProps: TIpHtmlProps); var propA : TIpHtmlPropAFieldsRec; propB : TIpHtmlPropBFieldsRec; begin if aProps = nil then begin writeln('TIpHtmlProps is nil'); exit; end; writeln('>>> ', aProps.FOwner.ClassName, ': ', dbgs(@aProps)); if aProps.PropA <> nil then begin propA := aProps.PropA.FPropRec; writeln('PropA >>>:'); writeln('BaseFontSize :', propA.BaseFontSize); writeln('FontSize :', propA.FontSize); //writeln('FontStyle :', propA.FontStyle); writeln('FontName :', propA.FontName); end; if aProps.PropB <> nil then begin propB := aProps.PropB.FPropRec; writeln('PropB >>>:'); writeln('FontBaseline :', propB.FontBaseline); writeln('Alignment :', Ord(propB.Alignment)); writeln('FontColor :', propB.FontColor); writeln('VAlignment :', Ord(propB.VAlignment)); writeln('LinkColor :', propB.LinkColor); writeln('VLinkColor :', propB.VLinkColor); writeln('ALinkColor :', propB.ALinkColor); writeln('BgColor :', propB.BgColor); writeln('NoBreak :', propB.NoBreak); end; end; procedure DebugBox(Canvas: TCanvas; R: TRect; cl:TColor; dbg:boolean=false); var OldPenColor: TColor; begin OldPenColor := Canvas.Pen.Color; Canvas.Pen.Color := cl; Canvas.Moveto(r.left+(r.right-r.left) div 2, r.top); Canvas.Lineto(r.left+(r.right-r.left) div 2, r.bottom); Canvas.MoveTo(r.Left, r.top+(r.bottom-r.top) div 2); Canvas.LineTo(r.right, r.top+(r.bottom-r.top) div 2); if Dbg then DebugLn('DebugBox:R=',dbgs(R)); Canvas.Pen.Color := OldPenColor; end; {$ENDIF} function dbgs(et: TElementType): string; begin writestr(Result,et); end; function GetNextSiblingNode(ANode: TIpHtmlNode): TIpHtmlNode; var node: TIpHtmlNode; parent: TIpHtmlNodeMulti; i: Integer; begin Result := nil; if ANode = nil then exit; if (ANode.FParentNode = nil) or not (ANode.ParentNode is TIpHtmlNodeMulti) then exit; parent := TIpHtmlNodeMulti(ANode.FParentNode); if parent.ChildCount = 1 then exit; Result := parent.ChildNode[parent.ChildCount-1]; for i := parent.ChildCount-2 downto 0 do begin node := parent.ChildNode[i]; if node = ANode then exit; Result := node; end; Result := nil; end; function GetPrevSiblingNode(ANode: TIpHtmlNode): TIpHtmlNode; var node: TIpHtmlNode; parent: TIpHtmlNodeMulti; i: Integer; begin Result := nil; if ANode = nil then exit; if (ANode.FParentNode = nil) or not (ANode.ParentNode is TIpHtmlNodeMulti) then exit; parent := TIpHtmlNodeMulti(ANode.FParentNode); if parent.ChildCount = 1 then exit; Result := parent.ChildNode[0]; for i:=1 to parent.ChildCount-1 do begin node := parent.ChildNode[i]; if node = ANode then exit; Result := node; end; Result := nil; end; function GetParentNodeOfClass(ANode: TIpHtmlNode; AClass: TIpHtmlNodeClass): TIpHtmlNode; begin Result := ANode; while Assigned(Result) and not (Result is AClass) do Result := Result.FParentNode; end; function FindNode(ANode: TIpHtmlNode; ACriteria: TIdFindNodeCriteria; const AParamStr: string): TIpHtmlNodeCore; var I: Integer; VNode: TIpHtmlNodeMulti; VPrevNode, VNextNode: TIpHtmlNode; begin if not Assigned(ANode) or not (ANode is TIpHtmlNodeMulti) then Exit(nil); VNode := ANode as TIpHtmlNodeMulti; if VNode.ChildCount < 1 then Exit(nil); for I := 0 to Pred(VNode.ChildCount) do begin VPrevNode := VNode.ChildNode[I]; VNextNode := FindNode(VPrevNode, ACriteria, AParamStr); if not Assigned(VNextNode) then VNextNode := VPrevNode; if VNextNode is TIpHtmlNodeCore then begin Result := VNextNode as TIpHtmlNodeCore; if ACriteria(Result, AParamStr) then Exit; end; end; Result := nil; end; function Criteria_FindNodeByElemId(ACurrNode: TIpHtmlNodeCore; const AParamStr: string): Boolean; begin if ACurrNode.Id = AParamStr then Exit(True); Result := False; end; function FindNodeByElemId(ANode: TIpHtmlNode; const AElemId: string): TIpHtmlNodeCore; begin Result := FindNode(ANode, Criteria_FindNodeByElemId, AElemId); end; function Criteria_FindNodeByElemClass(ACurrNode: TIpHtmlNodeCore; const AParamStr: string): Boolean; begin if ACurrNode.ClassId = AParamStr then Exit(True); Result := False; end; function FindNodeByElemClass(ANode: TIpHtmlNode; const AElemClass: string): TIpHtmlNodeCore; begin Result := FindNode(ANode, Criteria_FindNodeByElemClass, AElemClass); end; (* procedure TurnSiblingsOff; var I: Integer; Sibling: TControl; begin if Parent <> nil then with Parent do for I := 0 to ControlCount - 1 do begin Sibling := Controls[I]; if (Sibling <> Self) and (Sibling is THtmlRadioButton) and (Sibling.Tag = Self.Tag) then with THtmlRadioButton(Sibling) do SetChecked(False); end; end; begin if FChecked <> Value then begin FChecked := Value; TabStop := Value; if HandleAllocated then SendMessage(Handle, BM_SETCHECK, Integer(FChecked), 0); if Value then begin TurnSiblingsOff; inherited Changed; if not ClicksDisabled then Click; end; end; end; *) {$IFDEF Html_Print} procedure GetRelativeAspect(PrinterDC : hDC); var ScreenDC : hDC; begin ScreenDC := GetDC(0); try Aspect := Printer.XDPI / GetDeviceCaps(ScreenDC, LOGPIXELSX); finally ReleaseDC(0, ScreenDC); end; end; {$ENDIF} constructor TIpHtmlPoolManager.Create(TheItemSize, MaxItems : DWord); begin inherited Create(TheItemSize); ClearOnCreate:=true; end; function TIpHtmlPoolManager.NewItm : Pointer; begin Result:=NewItem; end; (* constructor TIpHtmlPoolManager.Create(ItemSize, MaxItems : DWord); begin InitializeCriticalSection(Critical); EnterCriticalSection(Critical); try InternalSize := ItemSize; while 4096 mod InternalSize <> 0 do Inc(InternalSize); Root := VirtualAlloc(nil, InternalSize * MaxItems, MEM_RESERVE, PAGE_NOACCESS); NextPage := Root; Next := Root; finally LeaveCriticalSection(Critical); end; {Top := Pointer(DWord(Root) + InternalSize * MaxItems);} end; destructor TIpHtmlPoolManager.Destroy; begin EnterCriticalSection(Critical); try if Root <> nil then VirtualFree(Root, 0, MEM_RELEASE); inherited Destroy; finally LeaveCriticalSection(Critical); end; DeleteCriticalSection(Critical); end; function TIpHtmlPoolManager.NewItm : Pointer; begin EnterCriticalSection(Critical); if Next = NextPage then Grow; Result := Next; Inc(DWord(Next), InternalSize); LeaveCriticalSection(Critical); end; procedure TIpHtmlPoolManager.Grow; var P: Pointer; begin P := VirtualAlloc(NextPage, 4096, MEM_COMMIT, PAGE_READWRITE); if P = nil then raise Exception.Create('Out of memory'); Inc(DWord(NextPage),4096); end; procedure TIpHtmlPoolManager.EnumerateItems(Method: TIpEnumItemsMethod); var P : Pointer; begin P := Root; while DWord(P) < DWord(Next) do begin Method(P); Inc(DWord(P), InternalSize); end; end; *) procedure SetWordRect(Element: PIpHtmlElement; const Value: TRect); begin Element.WordRect2 := Value; if Element.ElementType = etObject then begin if (Value.Left < Value.Right) and (Value.Bottom > Value.Top) and (Value.Left >= 0) and (Value.Top >= 0) then TIpHtmlNodeAlignInline(Element.Owner).SetRect(Value); end; end; function StdIndent: Integer; begin if ScaleBitmaps and (Aspect > 0) then Result := round(16 * Aspect) else Result := 16; end; function SizeRec(cx, cy: Integer): TSize; begin Result.cx := cx; Result.cy := cy; end; { TIpHtmlBaseLayouter } constructor TIpHtmlBaseLayouter.Create(AOwner: TIpHtmlNodeCore); begin inherited Create; FOwner := AOwner; FBlockMin := -1; FBlockMax := -1; end; destructor TIpHtmlBaseLayouter.Destroy; begin inherited Destroy; end; procedure TIpHtmlBaseLayouter.ClearWordList; begin if FElementQueue <> nil then FElementQueue.Clear; end; function TIpHtmlBaseLayouter.GetProps: TIpHtmlProps; begin Result := FOwner.Props; end; procedure TIpHtmlBaseLayouter.IterateParents(AProc: TIpHtmlNodeIterator); var p: TIpHtmlNode; done: Boolean; begin p := FOwner; //.FParentNode; done := false; while Assigned(p) do begin AProc(p, Props, done); if done then break else p := p.FParentNode; end; end; procedure TIpHtmlBaseLayouter.ProcessDuplicateLFs; var i: Integer; elem: PIpHtmlElement; prevelem: PIpHtmlElement; begin i := pred(FElementQueue.Count); while i > 0 do begin elem := PIpHtmlElement(FElementQueue[i]); prevelem := PIpHtmlElement(FElementQueue[i-1]); case PIpHtmlElement(FElementQueue[i])^.ElementType of etSoftLF: if (prevelem.ElementType in [etHardLF, etSoftLF]) then begin prevelem.LFHeight := MaxI2(prevelem.LFHeight, elem.LFHeight); FElementQueue.Delete(i); end; etHardLF: if (prevelem.ElementType = etSoftLF) then begin prevelem.LFHeight := MaxI2(prevelem.LFHeight, elem.LFHeight); FElementQueue.Delete(i-1); end; // nothing to do for etHardLF end; dec(i); end; end; procedure TIpHtmlBaseLayouter.RemoveLeadingLFs; begin while (FElementQueue.Count>0) and (PIpHtmlElement(FElementQueue[0])^.ElementType in [etSoftLF, etHardLF]) do FElementQueue.Delete(0); end; { TIpHtmlBaseTableLayouter } constructor TIpHtmlBaseTableLayouter.Create(AOwner: TIpHtmlNodeCore); begin inherited Create(AOwner); ResetSize; FRowSp := TIntArr.Create; end; destructor TIpHtmlBaseTableLayouter.Destroy; begin FRowSp.Free; inherited Destroy; end; procedure TIpHtmlBaseTableLayouter.ResetSize; begin FMin := -1; FMax := -1; end; { TIpHtmlNode } function TIpHtmlNode.GetHint: string; begin Result := ''; end; constructor TIpHtmlNode.Create(ParentNode : TIpHtmlNode); begin inherited Create; if assigned(ParentNode) then if ParentNode is TIpHtmlNodeMulti then TIpHtmlNodeMulti(ParentNode).FChildren.Add(Self) else raise EIpHtmlException.Create(SHtmlNotContainer); FParentNode := ParentNode; if ParentNode <> nil then FOwner := ParentNode.Owner; end; destructor TIpHtmlNode.Destroy; begin if ((Owner = nil) or not Owner.Destroying) and (FParentNode <> nil) then TIpHtmlNodeMulti(FParentNode).FChildren.Remove(Self); end; function TIpHtmlNode.PageRectToScreen(const Rect: TRect; var ScreenRect: TRect): Boolean; { -convert coordinates of rect passed in to screen coordinates and return false if entire rect is clipped} var Tmp : TRect; begin if (Rect.Left = 0) and (Rect.Right = 0) and (Rect.Top = 0) and (Rect.Bottom = 0) then begin Result := False; Exit; end; if not IntersectRect(Tmp, Rect, Owner.FPageViewRect) then begin Result := False; Exit; end; ScreenRect := Rect; with Owner.FPageViewRect do OffsetRect(ScreenRect, -Left, -Top); with Owner.FClientRect do OffsetRect(ScreenRect, Left, Top); if not IntersectRect(Tmp, ScreenRect, Owner.FClientRect) then begin Result := False; Exit; end; Result := True; end; procedure TIpHtmlNode.ScreenLine(StartPoint, EndPoint : TPoint;const Width : Integer; const Color : TColor); var SaveWidth : Integer; aPen: TPen; aCanvas: TCanvas; begin StartPoint := PagePtToScreen(StartPoint); EndPoint := PagePtToScreen(EndPoint); aCanvas := Owner.Target; aPen:= aCanvas.Pen; SaveWidth := aPen.Width; aPen.Width := Width; aPen.Color := Color; aCanvas.MoveTo(StartPoint.x, StartPoint.y); aCanvas.LineTo(EndPoint.x, EndPoint.y); aPen.Width := SaveWidth; end; procedure TIpHtmlNode.ScreenRect(R : TRect; const Color : TColor); begin if PageRectToScreen(R, R) then begin with Owner.Target do begin Brush.Style := bsSolid; Brush.Color := Color; FrameRect(R); end; end; end; procedure TIpHtmlNode.ScreenFrame(R : TRect; Raised: boolean); var SaveWidth: Integer; procedure DoLine(X1,Y1,X2,Y2: Integer; Clr: TColor); begin with Owner.Target do begin Pen.Color := Clr; Line(X1,Y1,X2,Y2); end; end; begin if PageRectToScreen(R, R) then with Owner.Target do begin Brush.Style := bsSolid; SaveWidth := Pen.Width; Pen.Width := 1; if Raised then begin DoLine(R.Left, R.Top, R.Right-1, R.Top, RGB(220,220,220)); // above DoLine(R.Right-1, R.Bottom-1, R.Left, R.Bottom-1, RGB(64,64,64)); // below DoLine(R.Left, R.Top, r.Left, R.Bottom-1, RGB(192,192,192)); // Left DoLine(R.Right-1, R.Bottom-1, R.Right-1, R.Top, RGB(128,128,128)); // Right end else begin DoLine(R.Left, R.Top, R.Right-1, R.Top, RGB(64,64,64)); // above DoLine(R.Right-1, R.Bottom-1, R.Left, R.Bottom-1,RGB(220,220,220) ); // below DoLine(R.Left, R.Top, r.Left, R.Bottom-1, RGB(128,128,128)); // Left DoLine(R.Right-1, R.Bottom-1, R.Right-1, R.Top, RGB(192,192,192)); // Right end; Pen.Width := SaveWidth; end; end; procedure TIpHtmlNode.ScreenPolygon(Points : array of TPoint; const Color : TColor); var Pt : TPoint; i : Integer; SaveColor : TColor; begin for i := 0 to High(Points) do begin Pt := PagePtToScreen(Points[i]); Points[i] := Pt; end; with Owner.Target do begin Pen.Color := Color; SaveColor := Brush.Color; Brush.Color := Color; Polygon(Points); Brush.Color := SaveColor; end; end; function TIpHtmlNode.PagePtToScreen(const Pt : TPoint): TPoint; {-convert coordinates of point passed in to screen coordinates} begin Result := Pt; with Owner.FPageViewRect do begin Dec(Result.x, Left); Dec(Result.y, Top); end; with Owner.FClientRect do begin Inc(Result.x, Left); Inc(Result.y, Top); end; end; procedure TIpHtmlNode.ReportDrawRects(M: TRectMethod); begin end; procedure TIpHtmlNode.ReportMapRects(M: TRectMethod); begin end; procedure TIpHtmlNode.InvalidateSize; begin if FParentNode = nil then Owner.InvalidateSize else FParentNode.InvalidateSize; end; procedure TIpHtmlNode.EnumChildren(EnumProc: TIpHtmlNodeEnumProc; UserData: Pointer); begin EnumProc(Self, UserData); end; procedure TIpHtmlNode.SubmitRequest; begin if FParentNode <> nil then FParentNode.SubmitRequest; end; procedure TIpHtmlNode.ResetRequest; begin if FParentNode <> nil then FParentNode.ResetRequest; end; procedure TIpHtmlNode.ReportCurDrawRects(Owner: TIpHtmlNode; M : TRectMethod); begin if FParentNode <> nil then FParentNode.ReportCurDrawRects(Owner, M); end; procedure TIpHtmlNode.AppendSelection(var S: string; var Completed: Boolean); begin end; procedure TIpHtmlNode.CreateControl(Parent: TWinControl); begin end; procedure TIpHtmlNode.Enqueue; begin end; procedure TIpHtmlNode.EnqueueElement(const Entry: PIpHtmlElement); begin end; function TIpHtmlNode.ElementQueueIsEmpty: Boolean; begin Result := True; end; procedure TIpHtmlNode.HideUnmarkedControl; begin end; procedure TIpHtmlNode.ImageChange(NewPicture: TPicture); begin end; procedure TIpHtmlNode.Invalidate; begin end; procedure TIpHtmlNode.MakeVisible; begin end; procedure TIpHtmlNode.SetProps(const RenderProps: TIpHtmlProps); begin end; procedure TIpHtmlNode.UnmarkControl; begin end; function TIpHtmlNode.GetMargin(AMargin: TIpHtmlElemMargin; ADefault: Integer): Integer; begin Result := ADefault; end; {Attribute support code} function GetPropertyValue(PI: PPropInfo; const AObject: TObject): string; function GetPropType : PTypeInfo; begin Result := PI.PropType; end; function GetIntegerProperty : string; begin Result := IntToStr(GetOrdProp(AObject, PI)); end; function GetCharProperty : string; begin Result := Char(GetOrdProp(AObject, PI)); end; function GetEnumProperty : string; begin Result := GetEnumName(GetPropType, GetOrdProp(AObject, PI)); end; function GetFloatProperty : string; const Precisions : array[TFloatType] of Integer = (7, 15, 18, 18, 19); begin Result := FloatToStrF(GetFloatProp(AObject, PI), ffGeneral, Precisions[GetTypeData(GetPropType)^.FloatType], 0); end; function GetLStringProperty : string; begin Result := GetStrProp(AObject, PI); end; function GetWCharProperty : string; begin Result := Char(GetOrdProp(AObject, PI)); end; function GetVariantProperty : string; begin Result := VarToStr(GetVariantProp(AObject, PI)); end; function GetStringProperty : string; begin Result := GetStrProp(AObject, PI); end; type TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1; function GetSetProperty : string; var TypeInfo : PTypeInfo; W : Cardinal; I : Integer; begin Result := '['; W := GetOrdProp(AObject, PI); TypeInfo := GetTypeData(GetPropType)^.CompType; for I := 0 to Pred(sizeof(Cardinal) * 8) do if I in TCardinalSet(W) then begin if Length(Result) <> 1 then Result := Result + ','; Result := Result + GetEnumName(TypeInfo, I); end; Result := Result + ']'; end; begin Result := '??'; case PI.PropType^.Kind of tkInteger : Result := GetIntegerProperty; tkChar : Result := GetCharProperty; tkEnumeration : Result := GetEnumProperty; tkFloat : Result := GetFloatProperty; tkLString : Result := GetLStringProperty; tkWChar : Result := GetWCharProperty; tkVariant : Result := GetVariantProperty; tkAString, tkString : Result := GetStringProperty; tkSet : Result := GetSetProperty; else Result := 'unsupported'; end; end; procedure SetPropertyValueLow(PI: PPropInfo; const AObject: TObject; const NewValue: string); function GetPropType : PTypeInfo; begin Result := PI.PropType; end; procedure SetIntegerProperty; begin SetOrdProp(AObject, PI, StrToInt(NewValue)); end; procedure SetCharProperty; begin SetOrdProp(AObject, PI, ord(NewValue[1])); end; procedure SetEnumProperty; begin SetEnumProp(AObject, PI, NewValue); end; procedure SetFloatProperty; begin SetFloatProp(AObject, PI, StrToFloat(NewValue)); end; procedure SetStringProperty; begin SetStrProp(AObject, PI, NewValue); end; type TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1; procedure SetSetProperty; begin SetSetProp(AObject, PI, NewValue); end; begin if not Assigned(PI.SetProc) then raise Exception.Create('Property is read-only'); case PI.PropType^.Kind of tkInteger : SetIntegerProperty; tkChar : SetCharProperty; tkEnumeration : SetEnumProperty; tkFloat : SetFloatProperty; tkString, tkAString, tkLString : SetStringProperty; tkSet : SetSetProperty; else raise Exception.Create('Unsupported attribute type'); end; end; function GetPropertyList(C: TObject; IncludeValues, IncludeBlanks: Boolean): TStringList; var LCount: Integer; LSize: Integer; PList : PPropList; I, J: Integer; S: string; SubList: TStringList; O: TObject; begin Result := TStringList.Create; try if (C <> nil) and (C.ClassInfo <> nil) then begin LCount := GetPropList(C.ClassInfo, tkProperties, nil); LSize := LCount * SizeOf(Pointer); if LSize > 0 then begin GetMem(PList, LSize); try GetPropList(C.ClassInfo, tkProperties, PList); for I := 0 to LCount-1 do begin if PList^[I].PropType^.Kind = tkClass then begin SubList := nil; try O := TObject(GetOrdProp(C, PList^[I])); SubList := GetPropertyList(O, IncludeValues, IncludeBlanks); for j := 0 to Pred(SubList.Count) do Result.Add(PList^[I]^.Name + '.' + SubList[j]); finally SubList.Free; end; end else begin if IncludeValues then begin S := GetPropertyValue(PList^[I], C); if IncludeBlanks or (S <> '') then Result.Add(PList^[I]^.Name + '=' + S); end else Result.Add(PList^[I]^.Name); end; end; finally FreeMem(PList, LSize); end; end; end; except Result.Free; raise; end; end; procedure SetPropertyValue(C: TObject; PropPath: string; const NewValue: string); var LCount: Integer; LSize: Integer; PList : PPropList; I, J: Integer; SubPropPath: string; O: TObject; begin I := pos('=', PropPath); if I <> 0 then SetLength(PropPath, I - 1); PropPath := trim(PropPath); if PropPath = '' then Exit; if C.ClassInfo <> nil then begin LCount := GetPropList(C.ClassInfo, tkProperties, nil); LSize := LCount * SizeOf(Pointer); if LSize > 0 then begin GetMem(PList, LSize); try GetPropList(C.ClassInfo, tkProperties, PList); for I := 0 to LCount-1 do begin if PList^[I].PropType^.Kind = tkClass then begin J := pos('.', PropPath); if J <> 0 then begin SubPropPath := copy(PropPath, 1, J - 1); if CompareText(SubPropPath, PList^[I]^.Name) = 0 then begin O := TObject(GetOrdProp(C, PList^[I])); SetPropertyValue(O, copy(PropPath, J + 1, MAXINT), NewValue); Exit; end; end; end else begin if CompareText(PropPath, PList^[I]^.Name) = 0 then begin SetPropertyValueLow(PList^[I], C, NewValue); Exit; end; end; end; finally FreeMem(PList, LSize); end; end; end; raise Exception.Create('Unknown property:' + PropPath); end; procedure TIpHtmlNode.GetAttributes(Target: TStrings; IncludeValues, IncludeBlanks: Boolean); var List : TStringList; begin List := GetPropertyList(Self, IncludeValues, IncludeBlanks); try Target.Assign(List); finally List.Free; end; end; procedure TIpHtmlNode.SetAttributeValue(const AttrName, NewValue: string); begin SetPropertyValue(Self, AttrName, NewValue); end; function TIpHtmlNode.ExpParentWidth: Integer; begin if assigned(FParentNode) then Result := FParentNode.ExpParentWidth else Result := MAXINT; end; { TIpHtmlNodeMulti } constructor TIpHtmlNodeMulti.Create(ParentNode : TIpHtmlNode); begin inherited Create(ParentNode); FChildren := TFPList.Create; //Maybe this will create some unespected behavior (Owner=nil) if Owner <> nil then FProps := TIpHtmlProps.Create(FOwner.PropACache, FOwner.PropBCache); end; destructor TIpHtmlNodeMulti.Destroy; var i : Integer; begin if Owner.Destroying then begin for i := 0 to Pred(FChildren.Count) do TIpHtmlNode(FChildren[I]).Free; end else while FChildren.Count > 0 do begin TIpHtmlNode(FChildren[FChildren.Count - 1]).Free; end; FChildren.Free; if Assigned(FProps) then FreeAndNil(FProps); inherited Destroy; end; function TIpHtmlNodeMulti.GetChildNode(Index: Integer): TIpHtmlNode; begin Result := TIpHtmlNode(FChildren[Index]); end; function TIpHtmlNodeMulti.GetChildCount: Integer; begin Result := FChildren.Count; end; procedure TIpHtmlNodeMulti.Enqueue; var i : Integer; begin for i := 0 to Pred(FChildren.Count) do TIpHtmlNode(FChildren[i]).Enqueue; end; procedure TIpHtmlNodeMulti.SetProps(const RenderProps: TIpHtmlProps); var i : Integer; savedColor, savedBgColor : TColor; IsMouseOver: boolean; begin //DebugLn(ClassName, ':', FParentNode.className, ':', IntToStr(RenderProps.BgColor)); Props.Assign(RenderProps); if Self.InheritsFrom(TIpHtmlNodeCore)then TIpHtmlNodeCore(Self).LoadAndApplyCSSProps; //DebugLn(ClassName, ':', FParentNode.className, ':', IntToStr(RenderProps.BgColor)); IsMouseOver := Self = Owner.FHotNode; if IsMouseOver then begin //DebugLn('MouseOver: ', classname); Props.DelayCache:=True; if Props.HoverColor <> clNone then begin savedColor := Props.FontColor; Props.FontColor := Props.HoverColor; end; if Props.HoverBgColor <> clNone then begin savedBgColor := Props.BgColor; Props.BgColor := Props.HoverBgColor; end; Props.DelayCache:=False; end; for i := 0 to Pred(FChildren.Count) do begin TIpHtmlNode(FChildren[i]).SetProps(Props); { DebugLn(debugDashs , TIpHtmlNode(FChildren[i]).ClassName, ':', TIpHtmlNode(FChildren[i]).FParentNode.ClassName, ':', IntToStr(RenderProps.BgColor)); } end; if IsMouseOver then begin Props.DelayCache:=True; if Props.HoverColor <> clNone then Props.FontColor := savedColor; if Props.HoverBgColor <> clNone then Props.BgColor := savedBgColor; Props.DelayCache:=False; end; end; procedure TIpHtmlNodeMulti.ReportDrawRects(M: TRectMethod); var i : Integer; begin for i := 0 to Pred(FChildren.Count) do TIpHtmlNode(FChildren[i]).ReportDrawRects(M); end; procedure TIpHtmlNodeMulti.ReportMapRects(M: TRectMethod); var i : Integer; begin for i := 0 to Pred(FChildren.Count) do TIpHtmlNode(FChildren[i]).ReportMapRects(M); end; procedure TIpHtmlNodeMulti.EnumChildren(EnumProc: TIpHtmlNodeEnumProc; UserData: Pointer); var i : Integer; begin inherited; for i := 0 to Pred(FChildren.Count) do TIpHtmlNode(FChildren[i]).EnumChildren(EnumProc, UserData); end; procedure TIpHtmlNodeMulti.AppendSelection(var S: string; var Completed: Boolean); var i : Integer; begin if Completed then exit; for i := 0 to Pred(FChildren.Count) do begin TIpHtmlNode(FChildren[i]).AppendSelection(S, Completed); if Completed then exit; end; end; function TIpHtmlNodeMulti.GetMargin(AMargin: TIpHtmlElemMargin; ADefault: Integer): Integer; begin if AMargin.Style = hemsPx then Result := round(AMargin.Size) else Result := ADefault; end; { TIpHtmlNodeBODY } constructor TIpHtmlNodeBODY.Create(ParentNode : TIpHtmlNode); begin inherited Create(ParentNode); FElementName := 'body'; FLink := clNone; FVLink := clNone; FALink := clNone; Owner.FBody := Self; end; procedure TIpHtmlNodeBODY.Render(RenderProps: TIpHtmlProps); var MaxX, MaxY: Integer; X, Y : Integer; P : TPoint; begin if ScaleBitmaps then begin Owner.Target.Brush.Color := Owner.BgColor; Owner.Target.FillRect(Owner.ClientRect); end else begin // Fill page with background color if BGColor <> clNone then begin Owner.Target.Brush.Color := BGColor; Owner.Target.FillRect(Owner.ClientRect); end else begin Owner.Target.Brush.Color := Owner.BGColor; Owner.Target.FillRect(Owner.ClientRect); end; // Draw background image if Background <> '' then begin if BgPicture = nil then Owner.DoGetImage(Self, Owner.BuildPath(Background), FBgPicture); if (BgPicture <> nil) and (BgPicture.Height>0) and (BgPicture.Width>0) then begin MaxX := MaxI2(PageRect.Right, Owner.ClientRect.Right); MaxY := MaxI2(PageRect.Bottom, Owner.ClientRect.Bottom); Y := 0; while (Y <= MaxY{PageRect.Bottom}) do begin if (Y < Owner.PageViewRect.Top - BgPicture.Height) or (Y > Owner.PageViewRect.Bottom) then else begin X := 0; while (X <= MaxX{PageRect.Right}) do begin P := PagePtToScreen(Point(X, Y)); Owner.Target.Draw(P.X, P.Y, BgPicture.Graphic); Inc(X, BgPicture.Width); end; end; Inc(Y, BgPicture.Height); end; end; end; end; inherited Render(RenderProps); // Restore style Owner.Target.Brush.Style:=bsSolid; end; procedure TIpHtmlNodeBODY.LoadAndApplyCSSProps; var LinkProps: TCSSProps; begin Props.DelayCache := True; inherited LoadAndApplyCSSProps; LinkProps := Owner.CSS.GetPropsObject('a:link', ''); if (LinkProps <> nil) and (LinkProps.Color <> clNone) then Link := LinkProps.Color; LinkProps := Owner.CSS.GetPropsObject('a:visited', ''); if (LinkProps <> nil) and (LinkProps.Color <> clNone) then VLink := LinkProps.Color; LinkProps := Owner.CSS.GetPropsObject('a:active', ''); if (LinkProps <> nil) and (LinkProps.Color <> clNone) then ALink := LinkProps.Color; Props.DelayCache := True; end; destructor TIpHtmlNodeBODY.Destroy; begin inherited; BgPicture.Free; end; procedure TIpHtmlNodeBODY.ImageChange(NewPicture: TPicture); begin {$IFOPT C+} Owner.CheckImage(NewPicture); {$ENDIF} FBgPicture.Free; FBgPicture := NewPicture; Invalidate; end; procedure TIpHtmlNodeBODY.SetAlink(const Value: TColor); begin if Value <> FAlink then begin Falink := Value; InvalidateSize; end; end; procedure TIpHtmlNodeBODY.SetLink(const Value: TColor); begin if Value <> FLink then begin FLink := Value; InvalidateSize; end; end; procedure TIpHtmlNodeBODY.SetVlink(const Value: TColor); begin if Value <> FVLink then begin FVLink := Value; InvalidateSize; end; end; { TIpHtml } procedure TIpHtml.AddWordEntry(const Value: string; Props: TIpHtmlProps; Owner: TIpHtmlNode); var Entry : PIpHtmlElement; L : Integer; begin Entry := NewElement(etWord, Owner); Entry.Props := Props; Entry.AnsiWord := Value; Entry.IsBlank := 0; L := length(Entry.AnsiWord); while Entry.IsBlank < L do if Entry.AnsiWord[Entry.IsBlank + 1] = ' ' then Inc(Entry.IsBlank) else break; if Entry.IsBlank < L then Entry.IsBlank := 0; Owner.EnqueueElement(Entry); end; procedure TIpHtml.AddWord(Value: string; Props: TIpHtmlProps; Owner: TIpHtmlNode); var P : Integer; begin if FDocCharset<>'' then Value := ConvertEncoding(Value, FDocCharset, 'UTF-8'); Value:= EscapeToAnsi(Value); P := CharPos(ShyChar, Value); if P = 0 then AddWordEntry(Value, Props, Owner) else begin while Value <> '' do begin AddWordEntry(copy(Value, 1, P - 1), Props, Owner); Delete(Value, 1, P); if Value <> '' then Owner.EnqueueElement(SoftHyphen); P := CharPos(ShyChar, Value); if P = 0 then P := length(Value) + 1; end; end; end; procedure TIpHtml.InvalidateRect(R: TRect); begin if Assigned(FOnInvalidateRect) then FOnInvalidateRect(Self, R); end; procedure TIpHtml.Clear; {- clear any contents} var i : Integer; begin {$IFDEF UseGifImageUnit} for i := 0 to Pred(GifImages.Count) do if TIpHtmlNodeIMG(GifImages[i]).FPicture <> nil then TGifImage(TIpHtmlNodeIMG(GifImages[i]).FPicture.Graphic).PaintStop; {$ELSE} for i := 0 to Pred(AnimationFrames.Count) do if TIpHtmlNodeIMG(AnimationFrames[i]).Picture <> nil then TIpAnimatedGraphic(TIpHtmlNodeIMG(AnimationFrames[i]).Picture.Graphic). AggressiveDrawing := False; {$ENDIF} ClearGifQueue; FHotNode := nil; FHtml.Free; FHtml := TIpHtmlNodeHtml.Create(nil); FHtml.FOwner := Self; end; procedure TIpHtml.ReportReferences(Node : TIpHtmlNode); var i : Integer; S : string; begin if Node is TIpHtmlNodeA then S := Trim(TIpHtmlNodeA(Node).HRef) else if Node is TIpHtmlNodeAREA then S := Trim(TIpHtmlNodeAREA(Node).HRef); if (S <> '') then ReportReference(S); if Node is TIpHtmlNodeMulti then for i := 0 to Pred(TIpHtmlNodeMulti(Node).ChildCount) do ReportReferences(TIpHtmlNodeMulti(Node).ChildNode[i]); end; procedure TIpHtml.LoadFromStream(S: TStream); begin DoneLoading := False; try FHasFrames := False; Clear; CharStream := S; Parse; ReportReferences(HtmlNode); finally DoneLoading := True; FCanPaint := True; end; end; procedure TrimFormatting(const S: string; Target: PAnsiChar; PreFormatted: Boolean = False); var R, W : Integer; procedure CopyChar(ch: AnsiChar); begin Target[w] := ch; Inc(w); end; begin r := 1; w := 0; while r <= length(S) do begin case S[r] of #0..#8, #11..#12, #14..#31 : ; #9 : if PreFormatted then CopyChar(' '); #13 : if PreFormatted then CopyChar(LF); #10 : if PreFormatted then begin if (w = 0) or (Target[w-1] <> LF) then CopyChar(LF); end else begin if w > 1 then CopyChar(' '); end; ' ' : if PreFormatted or (w = 0) or (Target[w-1] <> ' ') then CopyChar(' '); else CopyChar(S[r]); end; Inc(r); end; Target[w] := #0; end; function TIpHtml.FindAttribute(const AttrNameSet : TIpHtmlAttributesSet) : string; begin if FParser <> nil then Result := FParser.FindAttribute(AttrNameSet) else Result := ''; end; function CalcMultiLength(const List: TIpHtmlMultiLengthList; Avail: Integer; var Sections: Integer): TIntArr; var OrgAvail, i, S : Integer; begin Result := TIntArr.Create; if List.Entries = 0 then begin Sections := 1; Result[0] := Avail; Exit; end; OrgAvail := Avail; Sections := List.Entries; for i := 0 to Pred(List.Entries) do begin if List.Values[i].LengthType = hmlAbsolute then begin if Avail >= List.Values[i].LengthValue then begin Result[i] := List.Values[i].LengthValue; Dec(Avail, Result[i]); end else begin Result[i] := Avail; Avail := 0; end; end else Result[i] := 0; end; if Avail > 0 then begin for i := 0 to Pred(List.Entries) do if List.Values[i].LengthType = hmlPercent then Result[i] := round(List.Values[i].LengthValue * Avail / 100); for i := 0 to Pred(List.Entries) do if List.Values[i].LengthType = hmlPercent then Dec(Avail, Result[i]); if Avail > 0 then begin S := 0; for i := 0 to Pred(List.Entries) do if (List.Values[i].LengthType = hmlRelative) then Inc(S, List.Values[i].LengthValue); if S > 0 then for i := 0 to Pred(List.Entries) do if (List.Values[i].LengthType = hmlRelative) then begin Result[i] := round(List.Values[i].LengthValue * Avail / S); Dec(Avail, Result[i]); end; if Avail > 0 then for i := 0 to Pred(List.Entries) do if (List.Values[i].LengthType = hmlRelative) and (List.Values[i].LengthValue = 0) then begin Result[i] := Avail; break; end; end; end; repeat S := 0; for i := 0 to Pred(List.Entries) do Inc(S, Result[i]); S := OrgAvail - S; if S > 0 then for i := 0 to Pred(List.Entries) do begin Result[i] := Result[i] + 1; Dec(S); if S = 0 then break; end; if S < 0 then for i := 0 to Pred(List.Entries) do begin Result[i] := Result[i] - 1; Inc(S); if S = 0 then break; end; until S = 0; end; procedure TIpHtml.FixMissingBodyTag; var i: Integer; node: TIpHtmlNode; begin { Does the HTML include a body node? } if not FHtml.HasBodyNode then { No --> Create a body node under FHtml. } with FHtml do begin with TIpHtmlNodeBODY.Create(FHtml) do LoadAndApplyCSSProps; { Make each of FHtml's current children the children of the Body node. } for i := Pred(ChildCount) downto 0 do begin node := ChildNode[i]; if node <> Body then begin FChildren.Remove(node); node.FParentNode := Body; Body.FChildren.Insert(0, node); end; end; end; end; procedure TIpHtml.Parse; begin FParser := TIpHtmlParser.Create(Self, CharStream); try if FParser.Execute then begin FTitleNode := TIpHtmlParser(FParser).TitleNode; FCurFrameSet := TIpHtmlParser(FParser).FrameSet; FDocCharSet := TIpHtmlParser(FParser).DocCharSet; FHasFrames := TIpHtmlParser(FParser).HasFrames; end; finally FreeAndNil(FParser); end; end; constructor TIpHtml.Create; var TmpBitmap: TGraphic; begin inherited Create; PropACache := TIpHtmlPropsAList.Create; PropBCache := TIpHtmlPropsBList.Create; ElementPool := TIpHtmlPoolManager.Create(sizeof(TIpHtmlElement), MaxElements); SoftLF := BuildStandardEntry(etSoftLF); HardLF := BuildStandardEntry(etHardLF); HardLFClearLeft := BuildStandardEntry(etClearLeft); HardLFClearRight := BuildStandardEntry(etClearRight); HardLFClearBoth := BuildStandardEntry(etClearBoth); LIndent := BuildStandardEntry(etIndent); LOutdent := BuildStandardEntry(etOutdent); SoftHyphen := BuildStandardEntry(etSoftHyphen); DefaultProps := TIpHtmlProps.Create(PropACache, PropBCache); FHtml := TIpHtmlNodeHtml.Create(nil); FHtml.FOwner := Self; AnchorList := TFPList.Create; MapList := TFPList.Create; AreaList := TFPList.Create; MapImgList := TFPList.Create; RectList := TFPList.Create; ControlList := TFPList.Create; LinkColor := clBlue; VLinkColor := clPurple; ALinkColor := clRed; FLinksUnderlined := DEFAULT_LINKS_UNDERLINED; FCSS := TCSSGlobalProps.Create; FTabList := TIpHtmlTabList.Create; {$IFDEF UseGifImageUnit} GifImages := TFPList.Create; {$ELSE} AnimationFrames := TFPList.Create; {$ENDIF} NameList := TStringListUTF8Fast.Create; IdList := TStringListUTF8Fast.Create; DefaultImage := TPicture.Create; TmpBitmap := nil; try if LazarusResources.Find('DEFAULTIMAGE')<>nil then TmpBitmap := CreateBitmapFromLazarusResource('DEFAULTIMAGE') else TmpBitmap := CreateBitmapFromResourceName(HInstance, 'DEFAULTIMAGE'); DefaultImage.Graphic := TmpBitmap; finally TmpBitmap.Free; end; GifQueue := TFPList.Create; FStartSel.x := -1; FEndSel.x := -1; //FixedTypeface := 'Courier New'; FBgColor := clNone; FFactBAParag := 1; NeedResize := True; end; function TIpHtml.LinkVisited(const URL : string): Boolean; begin if (length(URL) > 0) and (URL[1] = '#') then Result := True else Result := CheckKnownURL(URL); end; {$IFOPT C+} procedure TIpHtml.CheckImage(Picture: TPicture); begin if Picture <> nil then begin if not (Picture is TPicture) then raise EIpHtmlException.Create(SHTMLInvPicture); if Picture.Graphic = nil then raise EIpHtmlException.Create(SHTMLNoGraphic); if not (Picture.Graphic is TGraphic) then raise EIpHtmlException.Create(SHTMLInvGraphic); end; end; {$ENDIF} procedure TIpHtml.DoGetImage(Sender: TIpHtmlNode; const URL: string; var Picture: TPicture); begin if assigned(FOnGetImageX) then OnGetImageX(Sender, URL, Picture) else raise EIpHtmlException.Create(SHTMLNoGetImage); {$IFOPT C+} CheckImage(Picture); {$ENDIF} end; procedure TIpHtml.FinalizeRecs(P: Pointer); begin with PIpHtmlElement(P)^ do begin //ElementType : TElementType; AnsiWord:=''; //IsBlank : Integer; //SizeProp: TIpHtmlPropA; //Size: TSize; //WordRect2 : TRect; //Props : TIpHtmlProps; //Owner : TIpHtmlNode; end; end; destructor TIpHtml.Destroy; var i : Integer; begin FCSS.Free; {$IFDEF UseGifImageUnit} for i := 0 to Pred(GifImages.Count) do if TIpHtmlNodeIMG(GifImages[i]).Picture <> nil then TGifImage(TIpHtmlNodeIMG(GifImages[i]).Picture.Graphic).PaintStop; {$ELSE} for i := 0 to Pred(AnimationFrames.Count) do if TIpHtmlNodeIMG(AnimationFrames[i]).Picture <> nil then TIpAnimatedGraphic(TIpHtmlNodeIMG(AnimationFrames[i]).Picture.Graphic). AggressiveDrawing := False; {$ENDIF} Destroying := True; PaintBufferBitmap.Free; ClearGifQueue; Clear; GifQueue.Free; DefaultImage.Free; NameList.Free; IdList.Free; FHtml.Free; AnchorList.Free; MapList.Free; AreaList.Free; ClearRectList; RectList.Free; MapImgList.Free; ControlList.Free; DefaultProps.Free; FTabList.Free; {$IFDEF UseGifImageUnit} GifImages.Free; {$ELSE} AnimationFrames.Free; {$ENDIF} ElementPool.EnumerateItems(FinalizeRecs); ElementPool.Free; PropACache.Free; PropBCache.Free; inherited; end; procedure TIpHtml.SetDefaultProps; begin if (FDefaultTypeFace='') or SameText(FDefaultTypeFace, 'default') then begin {$IFDEF MSWindows} Defaultprops.FontName := 'Times New Roman'; {$ELSE} Defaultprops.FontName := Graphics.DefFontData.Name {$ENDIF} end else Defaultprops.FontName := FDefaultTypeface; Defaultprops.FontSize := FDefaultFontSize; DefaultProps.BaseFontSize := 3; Defaultprops.FontBaseline := 0; DefaultProps.VAlignment := hva3Baseline; Defaultprops.FontStyle := []; Defaultprops.Alignment := haLeft; DefaultProps.FontColor := TextColor; DefaultProps.LinkColor := LinkColor; DefaultProps.VLinkColor := VLinkColor; DefaultProps.ALinkColor := ALinkColor; DefaultProps.BgColor := BgColor; DefaultProps.Preformatted := False; DefaultProps.NoBreak := False; if Body <> nil then begin if Body.TextColor <> clNone then DefaultProps.FontColor := Body.TextColor; if Body.Link <> clNone then DefaultProps.LinkColor := Body.Link; if Body.VLink <> clNone then DefaultProps.VLinkColor := Body.VLink; if Body.ALink <> clNone then DefaultProps.ALinkColor := Body.ALink; if Body.BgColor <> clNone then DefaultProps.BgColor := Body.BgColor; end; end; function TIpHtml.PagePtToScreen(const Pt : TPoint): TPoint; {-convert coordinates of point passed in to screen coordinates} begin Result := Pt; with FPageViewRect do begin Dec(Result.x, Left); Dec(Result.y, Top); end; with FClientRect do begin Inc(Result.x, Left); Inc(Result.y, Top); end; end; function TIpHtml.PageRectToScreen(const Rect: TRect; var ScreenRect: TRect): Boolean; {-convert coordinates of rect passed in to screen coordinates and return false if entire rect is clipped} var Tmp : TRect; begin if (Rect.Left = 0) and (Rect.Right = 0) and (Rect.Top = 0) and (Rect.Bottom = 0) then begin Result := False; Exit; end; if not IntersectRect(Tmp, Rect, FPageViewRect) then begin Result := False; Exit; end; ScreenRect := Rect; with FPageViewRect do OffsetRect(ScreenRect, -Left, -Top); with FClientRect do OffsetRect(ScreenRect, Left, Top); if not IntersectRect(Tmp, ScreenRect, FClientRect) then begin Result := False; Exit; end; Result := True; end; function TIpHtml.GetSelectionBlocks(out StartSelIndex,EndSelIndex: Integer): boolean; var R : TRect; //CurBlock: TIpHtmlNodeBlock; begin Result := false; if not FAllSelected and ((FStartSel.x < 0) or (FEndSel.x < 0)) then Exit; if not FAllSelected then begin //CurBlock := nil; // search blocks that intersect the selection // 1.- find first block that intersects upleft point of sel. (start from 0) StartSelIndex := 0; while StartSelIndex < RectList.Count do begin //CurBlock := PIpHtmlRectListEntry(RectList[StartSelIndex]).Block; {if FAllSelected and (CurBlock <> nil) then break;} // if PtInRect(CurBlock.PageRect, FStartSel) then begin R := PIpHtmlRectListEntry(RectList[StartSelIndex]).Rect; if R.Bottom = 0 then else if (R.Top > FStartSel.y) and (R.Bottom < FEndSel.y) then // block within selection (vertically) break else if PtInRect(R, FStartSel) or PtInRect(R, FEndSel) then // selection start or ends in this block break else if (R.Bottom < FStartSel.y) then else if (R.Top > FEndSel.Y) then else if (R.Left >= FStartSel.x) and (R.Right <= FEndSel.x) then break; // end; Inc(StartSelIndex); end; if StartSelIndex >= RectList.Count then Exit; // 2.- find first block that intersects downright point of sel. (start from count-1) EndSelIndex := Pred(RectList.Count); while EndSelIndex >= StartSelIndex do begin // if PIpHtmlRectListEntry(RectList[EndSelIndex]).Block = CurBlock then begin {if FAllSelected then break;} R := PIpHtmlRectListEntry(RectList[EndSelIndex]).Rect; if R.Bottom = 0 then else if (R.Top > FStartSel.y) and (R.Bottom < FEndSel.y) then break else if PtInRect(R, FStartSel) or PtInRect(R, FEndSel) then break else if (R.Bottom < FStartSel.y) then else if (R.Top > FEndSel.Y) then else if (R.Left >= FStartSel.x) and (R.Right <= FEndSel.x) then break; // end; Dec(EndSelIndex); end; end else begin StartSelIndex := 0; EndSelIndex := RectList.Count - 1; end; Result := True; end; function TIpHtml.getControlCount:integer; begin result := ControlList.Count; end; function TIpHtml.getControl(i:integer):TIpHtmlNode; begin result := ControlList[i]; end; procedure TIpHtml.PaintSelection; var StartSelIndex, EndSelIndex, i : Integer; R : TRect; CurBlock: TIpHtmlNodeBlock; begin if not FAllSelected and ((FStartSel.x < 0) or (FEndSel.x < 0)) then Exit; if not FAllSelected then begin CurBlock := nil; StartSelIndex := 0; while StartSelIndex < RectList.Count do begin CurBlock := PIpHtmlRectListEntry(RectList[StartSelIndex]).Block; {if FAllSelected and (CurBlock <> nil) then break;} if PtInRect(CurBlock.PageRect, FStartSel) then begin R := PIpHtmlRectListEntry(RectList[StartSelIndex]).Rect; if R.Bottom = 0 then else if (R.Top > FStartSel.y) and (R.Bottom < FEndSel.y) then break else if PtInRect(R, FStartSel) or PtInRect(R, FEndSel) then break else if (R.Bottom < FStartSel.y) then else if (R.Top > FEndSel.Y) then else if (R.Left >= FStartSel.x) and (R.Right <= FEndSel.x) then break; end; Inc(StartSelIndex); end; if StartSelIndex >= RectList.Count then Exit; EndSelIndex := Pred(RectList.Count); while EndSelIndex >= StartSelIndex do begin if PIpHtmlRectListEntry(RectList[EndSelIndex]).Block = CurBlock then begin {if FAllSelected then break;} R := PIpHtmlRectListEntry(RectList[EndSelIndex]).Rect; if R.Bottom = 0 then else if (R.Top > FStartSel.y) and (R.Bottom < FEndSel.y) then break else if PtInRect(R, FStartSel) or PtInRect(R, FEndSel) then break else if (R.Bottom < FStartSel.y) then else if (R.Top > FEndSel.Y) then else if (R.Left >= FStartSel.x) and (R.Right <= FEndSel.x) then break; end; Dec(EndSelIndex); end; end else begin StartSelIndex := 0; EndSelIndex := RectList.Count - 1; end; for i := StartSelIndex to EndSelIndex do begin R := PIpHtmlRectListEntry(RectList[i]).Rect; if PageRectToScreen(R, R) then begin DebugLn('TIpHtml.PaintSelection PatBlt not implemented'); (* PatBlt(PaintBuffer.Handle, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, DSTINVERT); *) end; end; end; procedure TIpHtml.RequestImageNodes(Node : TIpHtmlNode); var i : Integer; begin if Node is TIpHtmlNodeIMG then begin if TIpHtmlNodeIMG(Node).Picture = nil then TIpHtmlNodeIMG(Node).LoadImage; end; if Node is TIpHtmlNodeMulti then for i := 0 to Pred(TIpHtmlNodeMulti(Node).ChildCount) do begin RequestImageNodes(TIpHtmlNodeMulti(Node).ChildNode[i]); end; end; {$IFDEF IP_LAZARUS_DBG} var CCC: Integer; procedure TIpHtml.DebugChild(Node: TIpHtmlNode; const UserData: Pointer); var i: Integer; begin if Node=UserData then Write('Parent: '); for i:=0 to CCC do Write(' '); Write('Node: ', Node.ClassName); if Node is TIpHtmlNodeText then Write(' ', TIpHtmlNodeText(NodE).ANSIText); WriteLn; if Node=UserData then Exit; Inc(CCC); Node.EnumChildren(DebugChild, Node); Dec(CCC); end; procedure TIpHtml.DebugAll; //var //i: Integer; //item: PIpHtmlRectListEntry; //Node: TIpHtmlNode; begin CCC := 0; Fhtml.EnumChildren(DebugChild, FHtml); { for i:=0 to RectList.Count-1 do begin WriteLn('RectList[',i,']:'); Item := PIpHtmlRectListEntry(Rectlist[i]); if Item<>nil then begin WriteLn(' Node=', dbgs(Item.Node)); WriteLn(' Owner=', dbgs(Item.Node^.Owner)); WriteLn(' Text=', Item.Node^.AnsiWord); Node := Item.Node^.Owner; if Node<>nil then begin WriteLn(' ClassName:', Node.ClassName); if Node is TIpHtmlNodeText then WriteLn(' Text=', TIpHtmlNodeText(Node).ANSIText); end; WriteLn(' Block=', dbgs(Item.Block)); WriteLn(' Rect=', dbgs(Item.Rect)); end; end; } end; {$ENDIF} procedure TIpHtml.Render(TargetCanvas: TCanvas; TargetPageRect: TRect; UsePaintBuffer: Boolean; const TopLeft: TPoint); begin Render(TargetCanvas, TargetPageRect, TargetPageRect.Top, TargetPageRect.Bottom, UsePaintBuffer, TopLeft); end; procedure TIpHtml.Render(TargetCanvas: TCanvas; TargetPageRect: TRect; APageTop, APageBottom: Integer; UsePaintBuffer: Boolean; const TopLeft: TPoint); var i : Integer; AScale: Double; R: TRect; begin FClientRect.TopLeft := TopLeft; {Point(0, 0);} FClientRect.Right := TargetPageRect.Right - TargetPageRect.Left; FClientRect.Bottom := TargetPageRect.Bottom - TargetPageRect.Top; if not DoneLoading then begin TargetCanvas.FillRect(FClientRect); Exit; end; {$IFDEF UseGifImageUnit} for i := 0 to Pred(GifImages.Count) do if TIpHtmlNodeIMG(GifImages[i]).Picture <> nil then with TGifImage(TIpHtmlNodeIMG(GifImages[i]).Picture.Graphic) do if Painters <> nil then PaintStop; {$ELSE} for i := 0 to Pred(AnimationFrames.Count) do if TIpHtmlNodeIMG(AnimationFrames[i]).Picture <> nil then with TIpAnimatedGraphic(TIpHtmlNodeIMG(AnimationFrames[i]).Picture.Graphic) do AggressiveDrawing := False; {$ENDIF} for i := 0 to Pred(ControlList.Count) do TIpHtmlNode(ControlList[i]).UnmarkControl; if NeedResize then SetDefaultProps; FPageViewRect := TargetPageRect; { Note: In Preview mode the page is tiled of "mini-pages" sized PageViewRect. The lower end of the "real" page is given by PageViewBottom. We set here its default. The value needed for the preview will be set there. } FPageViewBottom := APageBottom; FPageViewTop := APageTop; if UsePaintBuffer then begin AScale := 1; if (PaintBuffer = nil) or (PaintBufferBitmap.Width <> FClientRect.Right) or (PaintBufferBitmap.Height <> FClientRect.Bottom) then begin PaintBufferBitmap.Free; PaintBufferBitmap := TBitmap.Create; if Assigned(Application) and Assigned(Application.MainForm) then AScale := Application.MainForm.GetCanvasScaleFactor; PaintBufferBitmap.Width := Round(FClientRect.Right * AScale); PaintBufferBitmap.Height := Round(FClientRect.Bottom * AScale); LCLIntf.SetCanvasScaleFactor(PaintBufferBitmap.Canvas.Handle, AScale); PaintBuffer := PaintBufferBitmap.Canvas; end; FTarget := PaintBuffer; end else begin PaintBuffer := TargetCanvas; FTarget := TargetCanvas; end; ClearRectList; if FHtml <> nil then FHtml.Render(DefaultProps); for i := 0 to Pred(ControlList.Count) do TIpHtmlNode(ControlList[i]).HideUnmarkedControl; if UsePaintBuffer then begin R := FClientRect; R.Right := Round(R.Right * AScale); R.Bottom := Round(R.Bottom * AScale); TargetCanvas.CopyRect(R, PaintBuffer, R); FClientRect := R; end else if PaintBufferBitmap <> nil then PaintBuffer := PaintBufferBitmap.Canvas else PaintBuffer := nil; StartGifPaint(TargetCanvas); {Request all non-visible images} RequestImageNodes(HtmlNode); end; procedure TIpHtml.ResetElementMetrics(P: Pointer); begin with PIpHtmlElement(P)^ do begin Size.cx := 0; Size.cy := 0; WordRect2 := Rect(0, 0, 0, 0); SizeProp := nil; end; end; procedure TIpHtml.ResetWordLists; begin ElementPool.EnumerateItems(ResetElementMetrics); end; procedure TIpHtml.ResetBlocks(Node: TIpHtmlNode); var i : Integer; begin if Node = nil then Exit; if Node is TIpHtmlNodeBlock then TIpHtmlNodeBlock(Node).InvalidateSize else if Node is TIpHtmlNodeTable then TIpHtmlNodeTable(Node).FLayouter.ResetSize; if Node is TIpHtmlNodeMulti then for i := 0 to Pred(TIpHtmlNodeMulti(Node).ChildCount) do ResetBlocks(TIpHtmlNodeMulti(Node).ChildNode[i]); end; procedure TIpHtml.ResetImages(Node: TIpHtmlNode); var i : Integer; begin if Node = nil then Exit; if Node is TIpHtmlNodeIMG then with TIpHtmlNodeIMG(Node) do begin {UnloadImage;} InvalidateSize; end else if Node is TIpHtmlNodeMulti then for i := 0 to Pred(TIpHtmlNodeMulti(Node).ChildCount) do ResetImages(TIpHtmlNodeMulti(Node).ChildNode[i]); end; procedure TIpHtml.ResetCanvasData; begin PropACache.ResetCache; ResetWordLists; ResetBlocks(FHtml); ResetImages(FHtml); end; function TIpHtml.GetPageRect(TargetCanvas: TCanvas; Width, Height : Integer): TRect; var DefPageRect : TRect; Min, Max, W, H : Integer; begin //debugln(['TIpHtml.GetPageRect START DoneLoading=',DoneLoading,' FHtml=',FHtml<>nil]); if not DoneLoading then begin // always set Result SetRectEmpty(Result); Exit; end; DoneLoading := False; SetRectEmpty(FPageRect); if FHtml <> nil then begin if (TargetCanvas <> RenderCanvas) or (FPageHeight <> Height) then ResetCanvasData; FPageHeight := Height; SetDefaultProps; {PanelWidth := Width;} FTarget := TargetCanvas; FHtml.CalcMinMaxHtmlWidth(DefaultProps, Min, Max); //debugln(['TIpHtml.GetPageRect Min=',Min,' Max=',Max]); W := MaxI2(Min + 2 * MarginWidth, Width); H := FHtml.GetHeight(DefaultProps, W - 2 * MarginWidth) + 2 * MarginHeight; DefPageRect := Rect( MarginWidth, MarginHeight, W - MarginWidth, H - MarginHeight); ClearAreaLists; ClearAreaList; FHtml.Layout(DefaultProps, DefPageRect); FPageRect := DefPageRect; FPagerect.Bottom := FPageRect.Bottom + MarginHeight; FPageRect.Right := FPageRect.Right + MarginWidth; RenderCanvas := TargetCanvas; end; Result := FPageRect; DoneLoading := True; end; procedure TIpHtml.InvalidateSize; begin if assigned(FOnInvalidateSize) then FOnInvalidateSize(Self); end; procedure TIpHtml.ClearAreaList; var i : Integer; begin for i := 0 to Pred(AreaList.Count) do TIpHtmlNodeArea(AreaList[i]).Reset; AreaList.Clear; end; function RectFromString(const S: string): TRect; var i, j, x, err : Integer; procedure Next; begin j := i; while (j <= length(S)) and (S[j] <> ',') do Inc(j); val(copy(S, i, j - i), x, err); end; begin SetRectEmpty(Result); i := 1; Next; if err <> 0 then Exit; Result.Left := x; i := j + 1; Next; if err <> 0 then Exit; Result.Top := x; i := j + 1; Next; if err <> 0 then Exit; Result.Right := x; i := j + 1; Next; if err <> 0 then Exit; Result.Bottom := x; end; function CircularRegion(const Coords: string; const Rect: TRect): HRgn; var i, j, err, cx, cy, R : Integer; begin Result := 0; i := 1; j := i; while (j <= length(Coords)) and (Coords[j] <> ',') do Inc(j); val(copy(Coords, i, j - i), cx, err); if err <> 0 then Exit; i := j + 1; j := i; while (j <= length(Coords)) and (Coords[j] <> ',') do Inc(j); val(copy(Coords, i, j - i), cy, err); if err <> 0 then Exit; i := j + 1; j := i; while (j <= length(Coords)) and (Coords[j] <> ',') and (Coords[j] <> '%') do Inc(j); val(copy(Coords, i, j - i), R, err); if err <> 0 then Exit; if (j <= length(Coords)) and (Coords[j] = '%') then R := round(R * MinI2(Rect.Right - Rect.Left, Rect.Bottom - Rect.Top) / 100); if R < 1 then Exit; Result := CreateEllipticRgn( Rect.Left + cx - R, Rect.Top + cy - R, Rect.Left + cx + R, Rect.Top + cy + R); end; function PolygonRegion(const Coords: string; const Rect: TRect): HRgn; const MAXPOINTS = 4096; var Points : array [0.. Pred(MAXPOINTS)] of TPoint; Count, i, j, x, y, err : Integer; begin Result := 0; Count := 0; i := 1; while i < length(Coords) do begin j := i; while (j <= length(Coords)) and (Coords[j] <> ',') do Inc(j); val(copy(Coords, i, j - i), x, err); if err <> 0 then Exit; i := j + 1; j := i; while (j <= length(Coords)) and (Coords[j] <> ',') do Inc(j); val(copy(Coords, i, j - i), y, err); if err <> 0 then Exit; Points[Count].x := x + Rect.Left; Points[Count].y := y + Rect.Top; Inc(Count); i := j + 1; end; if Count < 3 then Exit; if (Points[0].x <> Points[Count - 1].x) or (Points[0].y <> Points[Count - 1].y) then begin Points[Count] := Points[0]; Inc(Count); end; Result := CreatePolygonRgn( PPoint(@Points[0]), Count, ALTERNATE); {fill mode is irrelevant here} end; procedure TIpHtml.BuildAreaList; var i, j, k : Integer; R, R2 : TRect; begin ClearAreaList; for i := 0 to Pred(MapImgList.Count) do with TIpHtmlNodeIMG(MapImgList[i]) do begin R := GrossDrawRect; for j := 0 to Pred(MapList.Count) do with TIpHtmlNodeMap(MapList[j]) do begin for k := 0 to Pred(FChildren.Count) do if TIpHtmlNode(FChildren[k]) is TIpHtmlNodeArea then begin with TIpHtmlNodeArea(FChildren[k]) do begin if HRef <> '' then begin case Shape of hmsDefault : Rect := R; hmsRect : begin R2 := RectFromString(Coords); OffsetRect(R2, R.Left, R.Top); Rect := R2; end; hmsCircle : Rgn := CircularRegion(Coords, R); hmsPoly : Rgn := PolygonRegion(Coords, R); end; end; end; AreaList.Add(TIpHtmlNodeArea(FChildren[k])); end; end; end; end; procedure TIpHtml.MouseMove(Pt: TPoint); var i : Integer; begin FMouseLastPoint := Pt; FHotPoint := Point(-1, -1); if (MapList.Count > 0) and (AreaList.Count = 0) then BuildAreaList; for i := 0 to Pred(AnchorList.Count) do if TIpHtmlNodeA(AnchorList[i]).PtInRects(Pt) then begin if FHotNode <> TIpHtmlNodeA(AnchorList[i]) then begin if FHotNode <> nil then if FHotNode is TIpHtmlNodeA then TIpHtmlNodeA(FHotNode).Hot := False; FHotNode := TIpHtmlNode(AnchorList[i]); if FHotNode is TIpHtmlNodeA then TIpHtmlNodeA(FHotNode).Hot := True; end; if (FHotNode <> nil) then if FHotNode is TIpHtmlNodeA then FHotPoint := TIpHtmlNodeA(FHotNode).RelMapPoint(Pt); Exit; end; for i := 0 to Pred(AreaList.Count) do if TIpHtmlNodeAREA(AreaList[i]).PtInRects(Pt) then begin if FHotNode <> AreaList[i] then begin if FHotNode <> nil then if FHotNode is TIpHtmlNodeA then TIpHtmlNodeA(FHotNode).Hot := False; FHotNode := TIpHtmlNode(AreaList[i]); end; Exit; end; if FHotNode <> nil then if FHotNode is TIpHtmlNodeA then TIpHtmlNodeA(FHotNode).Hot := False; FHotNode := nil; FCurElement := nil; for i := 0 to Pred(RectList.Count) do if PtInRect(PIpHtmlRectListEntry(RectList[i]).Rect, Pt) then begin FCurElement := PIpHtmlRectListEntry(RectList[i]).Element; break; end; end; function TIpHtml.BuildPath(const Ext: string): string; begin if FDataProvider <> nil then Result := FDataProvider.BuildURL(FCurURL,Ext) else Result := BuildURL(FCurURL, Ext); end; function TIpHtml.NewElement(EType : TElementType; Own: TIpHtmlNode) : PIpHtmlElement; begin Result := ElementPool.NewItm; Result.ElementType := EType; Result.Owner := Own; Result.IsSelected := False; end; function TIpHtml.BuildStandardEntry(EType: TElementType): PIpHtmlElement; begin Result := NewElement(EType, nil); Result.Props := nil; SetWordRect(Result, Rect(0, 0, 0, 0)); end; function TIpHtml.BuildLineFeedEntry(EType: TElementType; AHeight: Integer): PIpHtmlElement; begin if not (EType in [etHardLF, etSoftLF]) then raise Exception.Create('BuildLinefeedEntry can only be called with parameter etSoftLF or dtHardLF'); Result := BuildStandardEntry(EType); Result.LFHeight := AHeight; end; procedure TIpHtml.MakeVisible(const R: TRect; ShowAtTop: Boolean = True); begin if Assigned(FOnScroll) then FOnScroll(Self, R, ShowAtTop); end; function TIpHtml.FindElement(const Name: string): TIpHtmlNode; var i : Integer; begin NameList.Sorted := True; i := NameList.IndexOf(Name); if i <> -1 then Result := TIpHtmlNode(NameList.Objects[i]) else Result := nil; end; function TIpHtml.FindElementID(const Id: String): TIpHtmlNode; var i: Integer; begin IdList.Sorted := true; i := IdList.IndexOf(Id); if i <> -1 then Result := TIpHtmlNode(IdList.Objects[i]) else Result := nil; end; type TIpHtmlGifQueueEntry = class protected FGraphic : TGraphic; FR : TRect; public constructor Create(AGraphic: TGraphic; ARect: TRect); property Graphic : TGraphic read FGraphic; property R : TRect read FR; end; procedure TIpHtml.ClearAreaLists; var i : Integer; begin for i := 0 to Pred(AnchorList.Count) do TIpHtmlNodeA(AnchorList[i]).ClearAreaList; end; procedure TIpHtml.Home; begin MakeVisible(Rect(0, 0, 1, 1)); end; procedure TIpHtml.Get(const URL: string); begin if assigned(FOnGet) then FOnGet(Self, URL); end; procedure TIpHtml.Post(const URL: string; FormData: TIpFormDataEntity); begin if assigned(FOnPost) then FOnPost(Self, URL, FormData); end; procedure TIpHtml.AddRect(const R: TRect; AElement: PIpHtmlElement; ABlock: TIpHtmlNodeBlock); var NewEntry : PIpHtmlRectListEntry; begin New(NewEntry); NewEntry.Rect := R; NewEntry.Element := AElement; NewEntry.Block := ABlock; RectList.Add(NewEntry); end; procedure TIpHtml.ClearRectList; var i : Integer; p: PIpHtmlRectListEntry; begin for i := Pred(RectList.Count) downto 0 do begin p:=PIpHtmlRectListEntry(RectList[i]); Freemem(p); end; RectList.Clear; end; procedure TIpHtml.DeselectAllItems(Item: Pointer); begin PIpHtmlElement(item)^.IsSelected := False; end; procedure TIpHtml.SetSelection(StartPoint, EndPoint: TPoint); var StartSelIndex,EndSelindex: Integer; i: Integer; r: TRect; Selected: boolean; DeselectAll: boolean; item: PIpHtmlRectListEntry; begin if FAllSelected then InvalidateRect(Body.PageRect); FAllSelected := False; if EndPoint.y > StartPoint.y then begin FStartSel := StartPoint; FEndSel := EndPoint; end else if EndPoint.y = StartPoint.y then if EndPoint.x > StartPoint.x then begin FStartSel := StartPoint; FEndSel := EndPoint; end else begin FStartSel := EndPoint; FEndSel := StartPoint; end else begin FStartSel := EndPoint; FEndSel := StartPoint; end; if Body <> nil then begin // Invalidate only those blocks that need it DeselectAll := (EndPoint.x<0)and(EndPoint.y<0); GetSelectionBlocks(StartSelIndex,EndSelIndex); for i:= 0 to RectList.Count-1 do begin item := PIpHtmlRectListEntry(RectList[i]); // (de)select only text elements if Item.Element.ElementType<>etWord then Continue; if DeselectAll then Selected := false else Selected := (StartSelIndex<=i)and(i<=EndSelIndex); // Invalidate only changed elements if Item.Element.IsSelected<>Selected then begin Item.Element.IsSelected := Selected; if Body.PageRectToScreen(Item^.Rect, R) then InvalidateRect(R); end; end; // also deselect remaining elements if DeselectAll then ElementPool.EnumerateItems(DeselectAllItems); end; end; procedure TIpHtml.SelectAll; begin FAllSelected := True; end; procedure TIpHtml.DeselectAll; begin FAllSelected := False; FStartSel.x := -1; FEndSel.x := -1; end; procedure TIpHtml.CopyToClipboard; var S : string; completed: Boolean; begin if HaveSelection then begin S := ''; if FHtml <> nil then begin completed := false; // terminate recursion if selection-end-point is found FHtml.AppendSelection(S, completed); end; if S <> '' then begin Clipboard.Open; try Clipboard.Clear; Clipboard.AsText := S; finally Clipboard.Close; end; end; end; end; function TIpHtml.HaveSelection: Boolean; begin Result := FAllSelected or ((FEndSel.x > 0) or (FEndSel.y > 0)); end; procedure TIpHtml.CreateIFrame(Parent: TWinControl; Frame: TIpHtmlNodeIFRAME; var Control: TWinControl); begin if assigned(FOnIFrameCreate) then FOnIFrameCreate(Self, Parent, Frame, Control); end; function TIpHtml.CheckKnownURL(URL: string): boolean; var P : Integer; begin if assigned(FOnURLCheck) then begin P := CharPos('#', URL); if P <> 0 then SetLength(URL, P - 1); Result:=true; FOnURLCheck(Self, URL, Result); end; end; procedure TIpHtml.ReportReference(URL: string); var P : Integer; begin if assigned(FOnReportURL) then begin P := CharPos('#', URL); if P <> 0 then if P = 1 then Exit else SetLength(URL, P - 1); FOnReportURL(Self, URL); end; end; procedure TIpHtml.ControlClick(Sender: TIpHtmlNodeControl); begin if assigned(FControlClick) then FControlClick(Self, Sender); end; procedure TIpHtml.ControlClick2(Sender: TIpHtmlNodeControl; var cancel: boolean); begin if assigned(FControlClick2) then FControlClick2(Self, Sender, cancel); end; procedure TIpHtml.ControlOnEditingDone(Sender: TIpHtmlNodeControl); begin if assigned(FControlOnEditingDone) then FControlOnEditingDone(Self, Sender); end; procedure TIpHtml.ControlOnChange(Sender: TIpHtmlNodeControl); begin if assigned(FControlOnChange) then FControlOnChange(Self, Sender); end; procedure TIpHtml.ControlCreate(Sender: TIpHtmlNodeControl); begin if assigned(FControlCreate) then FControlCreate(Self, Sender); end; { TIpHtmlGifQueueEntry } constructor TIpHtmlGifQueueEntry.Create(AGraphic: TGraphic; ARect: TRect); begin inherited Create; {$IFDEF IP_LAZARUS_DBG} DebugLn('TIpHtmlGifQueueEntry.Create ToDo NOT IMPLEMENTED YET'); {$ELSE} FGraphic := AGraphic; {$ENDIF} FR := ARect; end; procedure TIpHtml.AddGifQueue(Graphic: TGraphic; const R: TRect); begin GifQueue.Add(TIpHtmlGifQueueEntry.Create(Graphic, R)); end; procedure TIpHtml.StartGifPaint(Target: TCanvas); var i : Integer; begin for i := 0 to Pred(GifQueue.Count) do with TIpHtmlGifQueueEntry(GifQueue[i]) do Target.StretchDraw(R, Graphic); ClearGifQueue; end; procedure TIpHtml.ClearGifQueue; var i : Integer; begin if Assigned(GifQueue) then for i := Pred(GifQueue.Count) downto 0 do begin TIpHtmlGifQueueEntry(GifQueue[i]).Free; GifQueue.Delete(i); end; end; { TIpHtmlNodeBlock } constructor TIpHtmlNodeBlock.Create(ParentNode: TIpHtmlNode; LayouterClass: TIpHtmlBaseLayouterClass); begin inherited Create(ParentNode); FBgColor := clNone; FTextColor := clNone; FBackground := ''; FLayouter := LayouterClass.Create(Self); end; constructor TIpHtmlNodeBlock.Create(ParentNode : TIpHtmlNode); begin Create(ParentNode, BlockLayouterClass); // The constructor above end; destructor TIpHtmlNodeBlock.Destroy; begin FreeAndNil(FLayouter); inherited; end; procedure TIpHtmlNodeBlock.SetBackground(const AValue: string); begin if AValue <> FBackground then begin FBackground := AValue; InvalidateSize; end; end; procedure TIpHtmlNodeBlock.SetBgColor(const AValue: TColor); begin if AValue <> FBgColor then begin FBgColor := AValue; InvalidateSize; end; end; procedure TIpHtmlNodeBlock.SetTextColor(const AValue: TColor); begin if AValue <> FTextColor then begin FTextColor := AValue; InvalidateSize; end; end; procedure TIpHtmlNodeBlock.Render(RenderProps: TIpHtmlProps); begin FLayouter.Render(RenderProps); end; procedure TIpHtmlNodeBlock.Layout(RenderProps: TIpHtmlProps; const TargetRect: TRect); begin FLayouter.Layout(RenderProps, TargetRect); end; procedure TIpHtmlNodeBlock.CalcMinMaxPropWidth(RenderProps: TIpHtmlProps; var aMin, aMax: Integer); begin FLayouter.CalcMinMaxPropWidth(RenderProps, aMin, aMax); end; procedure TIpHtmlNodeBlock.LoadAndApplyCSSProps; begin inherited LoadAndApplyCSSProps; if FCombinedCSSProps <> nil then begin if FCombinedCSSProps.Color <> clNone then TextColor := FCombinedCSSProps.Color; if FCombinedCSSProps.BgColor <> clNone then BgColor := FCombinedCSSProps.BGColor; end; end; procedure TIpHtmlNodeBlock.EnqueueElement(const Entry: PIpHtmlElement); begin FLayouter.FElementQueue.Add(Entry); end; procedure TIpHtmlNodeBlock.Invalidate; var R : TRect; begin if PageRectToScreen(PageRect, R) then Owner.InvalidateRect(R); end; function TIpHtmlNodeBlock.GetHeight(const RenderProps: TIpHtmlProps; const Width: Integer): Integer; begin if FLastW = Width then begin Result := FLastH; Exit; end; Layout(RenderProps, Rect(0, 0, Width, MaxInt)); Result := PageRect.Bottom; FLastH := Result; FLastW := Width; end; procedure TIpHtmlNodeBlock.InvalidateSize; begin FLayouter.FBlockMin := -1; FLayouter.FBlockMax := -1; FLastW := 0; FLastH := 0; inherited; end; function TIpHtmlNodeBlock.Level0: Boolean; var P : TIpHtmlNode; begin Result := True; P := FParentNode; while P <> nil do begin if P is TIpHtmlNodeBlock then begin Result := False; break; end; P := P.FParentNode; end; end; procedure TIpHtmlNodeBlock.ReportCurDrawRects(aOwner: TIpHtmlNode; M : TRectMethod); var i : Integer; CurElem : PIpHtmlElement; begin for i := 0 to Pred(FLayouter.FElementQueue.Count) do begin CurElem := PIpHtmlElement(FLayouter.FElementQueue[i]); if CurElem.Owner = aOwner then M(CurElem.WordRect2); end; end; function TIpHtmlNodeBlock.GetPageRect: TRect; begin Result := FLayouter.FPageRect; end; procedure TIpHtmlNodeBlock.AppendSelection(var S: string; var Completed: Boolean); // Avoid adding too many linefeeds - at most one blank line! procedure AddLF(var S: String); const DBL_LF = LineEnding + LineEnding; var endPart: String; begin if S <> '' then begin endpart := Copy(S, Length(S) - Length(DBL_LF) + 1, Length(DBL_LF)); if endpart <> DBL_LF then S := S + LineEnding; end; end; var LastY, StartSelIndex, EndSelIndex, i, istart, iend : Integer; LastNode: TIpHtmlNode; CurElem : PIpHtmlElement; R : TRect; LFDone : Boolean; EndPt: TPoint; begin if Completed then exit; StartSelIndex := 0; EndSelIndex := pred(FLayouter.FElementQueue.Count); EndPt := Point(-1, -1); if not Owner.FAllSelected then begin // Find elements which contain the start-/end-selection-points // Note: they may not be in correct order because the y coords of the start/end // clicks may be reversed if in the same line of an etObject element! istart := -1; iend := -1; for i:=0 to pred(FLayouter.FElementQueue.Count) do begin CurElem := PIpHtmlElement(FLayouter.FElementQueue[i]); if PtInRect(CurElem^.WordRect2, Owner.FStartSel) then istart := i; if PtInRect(CurElem^.WordRect2, Owner.FEndSel) then iend := i; if (istart <> -1) and (iend <> -1) then break; end; // Start click could have been before first char of a line if (istart = -1) then for i:=0 to pred(FLayouter.FElementQueue.Count) do begin CurElem := PIpHtmlElement(FLayouter.FElementQueue[i]); R := CurElem^.WordRect2; if (Owner.FEndSel.Y >= R.Top) and (Owner.FEndSel.Y <= R.Bottom) and (Owner.FEndSel.X < R.Left) then begin istart := i; break; end; end; // End click could have been beyond line end if (iend = -1) then for i:=pred(FLayouter.FElementQueue.Count) downto 0 do begin CurElem := PIpHtmlElement(FLayouter.FElementQueue[i]); R := CurElem^.WordRect2; if (Owner.FEndSel.Y >= R.Top) and (Owner.FEndSel.Y <= R.Bottom) and (Owner.FEndSel.X > R.Right) then begin iend := i; EndPt := Point((R.Left + R.Right) div 2, (R.Top + R.Bottom) div 2); break; end; end; if (istart <> -1) and (iend <> -1) then begin if istart < iend then begin StartSelIndex := istart; EndSelIndex := iend; if (EndPt.X = -1) and (EndPt.Y = -1) then EndPt := Owner.FEndSel; end else begin StartSelIndex := iend; EndSelIndex := istart; if (EndPt.X = -1) and (EndPt.Y = -1) then EndPt := Owner.FStartSel; end; end else if (istart <> -1) and (iend = -1) then StartSelIndex := istart else if (istart = -1) and (iend <> -1) then begin EndSelIndex := iend; if (EndPt.X = -1) and (EndPt.Y = -1) then EndPt := Owner.FEndSel; end; end; LastNode := nil; LastY := -1; LFDone := True; for i := StartSelIndex to EndSelIndex do begin CurElem := PIpHtmlElement(FLayouter.FElementQueue[i]); R := CurElem.WordRect2; // Take care of inserting blank lines after headers etc., but don't insert // line breaks in long text elements. if not LFDone and (R.Top <> LastY) and (LastNode <> CurElem.Owner) then AddLF(S); case CurElem.ElementType of etWord : if CurElem.AnsiWord <> NAnchorChar then begin S := S + NoBreakToSpace(CurElem.AnsiWord); LFDone := False; end; etObject : begin TIpHtmlNodeAlignInline(CurElem.Owner).AppendSelection(S, Completed); LFDone := False; end; etSoftLF..etClearBoth : if not LFDone then begin AddLF(S); LFDone := True; end; end; LastY := R.Top; LastNode := CurElem.Owner; // Prevent running over selection end if there is an etObject element at // current level of recursion. if not Owner.FAllSelected then if PtInRect(R, EndPt) then begin Completed := true; exit; end; end; end; function TIpHtmlNodeBlock.ElementQueueIsEmpty: Boolean; begin Result := FLayouter.FElementQueue.Count = 0; end; { TIpHtmlNodeP } constructor TIpHtmlNodeP.Create(ParentNode: TIpHtmlNode); begin inherited; FElementName := 'p'; end; destructor TIpHtmlNodeP.Destroy; begin inherited; end; procedure TIpHtmlNodeP.SetProps(const RenderProps: TIpHtmlProps); var bgCol: TColor; begin bgCol := Props.BgColor; Props.Assign(RenderProps); Props.Alignment := Align; if FParentNode = FOwner.Body then Props.BgColor := bgCol; inherited SetProps(Props); end; procedure TIpHtmlNodeP.Enqueue; var elem: PIpHtmlElement; hf, h: Integer; begin hf := Props.FontSize; if FChildren.Count > 0 then begin if not (FParentNode is TIpHtmlNodeLI) then begin if FParentNode is TIpHtmlNodeTD then h := 0 else h := hf; // div 2; // FIXME: above line is a workaround for LHelp to display the code tables // correctly h := GetMargin(Props.ElemMarginTop, h); elem := Owner.BuildLinefeedEntry(etSoftLF, h); EnqueueElement(elem); end; end; inherited Enqueue; if FChildren.Count > 0 then begin if not (FParentNode is TIpHtmlNodeLI) then begin if FParentNode is TIpHtmlNodeTD then h := 0 else h := hf; // div 2; // FIXME: above line is a workaround for LHelp to display the code tables // correctly h := GetMargin(Props.ElemMarginBottom, h); elem := Owner.BuildLinefeedEntry(etSoftLF, h); EnqueueElement(elem); end; end; end; function TIpHtmlNodeP.GetAlign: TIpHtmlAlign; begin Result := FAlign; end; procedure TIpHtmlNodeP.LoadAndApplyCSSProps; begin inherited; if not (FCombinedCSSProps.Alignment in [haDefault, haUnknown]) then Align := FCombinedCSSProps.Alignment; end; procedure TIpHtmlNodeP.SetAlign(const Value: TIpHtmlAlign); begin if Value <> FAlign then begin FAlign := Value; InvalidateSize; end; end; { TIpHtmlNodeHeader } constructor TIpHtmlNodeHeader.Create(ParentNode: TIpHtmlNode); begin inherited; end; destructor TIpHtmlNodeHeader.Destroy; begin inherited; end; function TIpHtmlNodeHeader.GetAlign: TIpHtmlAlign; begin Result := FAlign; end; procedure TIpHtmlNodeHeader.LoadAndApplyCSSProps; begin inherited; if not (FCombinedCSSProps.Alignment in [haDefault, haUnknown]) then Align := FCombinedCSSProps.Alignment; end; procedure TIpHtmlNodeHeader.SetAlign(const Value: TIpHtmlAlign); begin FAlign := Value; end; procedure TIpHtmlNodeHeader.SetProps(const RenderProps: TIpHtmlProps); begin Props.Assign(RenderProps); Props.DelayCache:=True; Props.FontSize := FONTSIZESVALUESARRAY[abs(Size-6)]; Props.FontStyle := [fsBold]; Props.Alignment := Align; Props.DelayCache := False; inherited SetProps(Props); end; procedure TIpHtmlNodeHeader.Enqueue; var elem: PIpHtmlElement; hf: Integer; h: Integer; begin hf := Props.FontSize; // mimic layout/line spacing used in Chrome and Firefox if FChildren.Count > 0 then begin h := GetMargin(Props.ElemMarginTop, 3 * (Owner.DefaultFontSize div 2)); elem := Owner.BuildLinefeedEntry(etSoftLF, h); EnqueueElement(elem); end; inherited Enqueue; // mimic layout/line spacing used in Chrome and Firefox if FChildren.Count > 0 then begin h := GetMargin(Props.ElemMarginBottom, hf div 2); elem := Owner.BuildLinefeedEntry(etSoftLF, h); EnqueueElement(elem); end; end; type TFriendPanel = class(TCustomPanel) end; { TIpHtmlNodeHtml } procedure TIpHtmlNodeHtml.CalcMinMaxHtmlWidth(const RenderProps: TIpHtmlProps; var Min, Max: Integer); var i : Integer; begin for i := 0 to FChildren.Count - 1 do if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then TIpHtmlNodeBody(FChildren[i]).CalcMinMaxPropWidth(RenderProps, Min, Max); end; function TIpHtmlNodeHtml.GetHeight(const RenderProps: TIpHtmlProps; const Width: Integer): Integer; var i : Integer; begin Result := 0; for i := 0 to FChildren.Count - 1 do if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then Result := TIpHtmlNodeBody(FChildren[i]).GetHeight(RenderProps, Width); end; function TIpHtmlNodeHtml.HasBodyNode : Boolean; var i : Integer; begin Result := False; for i := 0 to FChildren.Count - 1 do begin Result := (TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody); if Result then Break; end; end; procedure TIpHtmlNodeHtml.Layout(const RenderProps: TIpHtmlProps; const TargetRect: TRect); var i : Integer; begin for i := 0 to FChildren.Count - 1 do if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then TIpHtmlNodeBody(FChildren[i]).Layout(RenderProps, TargetRect); end; procedure TIpHtmlNodeHtml.Render(RenderProps: TIpHtmlProps); var i : Integer; begin for i := 0 to FChildren.Count - 1 do if TIpHtmlNode(FChildren[i]) is TIpHtmlNodeBody then TIpHtmlNodeBody(FChildren[i]).Render(RenderProps); end; { TIpHtmlNodeCore } procedure TIpHtmlNodeCore.AddArea(const R: TRect); var RCopy : PRect; n : Integer; begin n := FAreaList.Count; if n > 0 then begin RCopy := PRect(FAreaList[n-1]); if (R.Left = RCopy.Right) and (R.Top = RCopy.Top) and (R.Bottom = RCopy.Bottom) then begin RCopy.Right := R.Right; Exit; end; end; New(RCopy); RCopy^ := R; FAreaList.Add(RCopy); end; procedure TIpHtmlNodeCore.BuildAreaList; var i : Integer; begin for i := 0 to Pred(FChildren.Count) do TIpHtmlNode(FChildren[i]).ReportDrawRects(AddArea); end; procedure TIpHtmlNodeCore.ClearAreaList; var a: Pointer; begin while FAreaList.Count > 0 do begin a := FAreaList[0]; FreeMem(a); FAreaList.Delete(0); end; end; procedure TIpHtmlNodeCore.ParseBaseProps(aOwner : TIpHtml); var Commands: TStringList; s: String; begin Id := aOwner.FindAttribute(htmlAttrID); ClassId := aOwner.FindAttribute(htmlAttrCLASS); Title := aOwner.FindAttribute(htmlAttrTITLE); Style := aOwner.FindAttribute(htmlAttrSTYLE); s := Uppercase(aOwner.FindAttribute(htmlAttrDIR)); if (s = '') then begin if (ParentNode is TIpHtmlNodeCore) then Dir := TIpHtmlNodeCore(ParentNode).Dir else if (ParentNode is TIpHtmlNodeHtml) then Dir := TIpHtmlNodeHtml(ParentNode).Dir; end else if s = 'RTL' then Dir := hdRTL else if s = 'LTR' then Dir := hdLTR; if Style <> '' then begin if InlineCSS = nil then InlineCSS := TCSSProps.Create; Commands := SeparateCommands(Style); InlineCSS.ReadCommands(Commands); Commands.Free; end; end; (* look up the props for all CSS selectors that directly match this node, merge them all into one object (FCombinedCSSProps) and then apply them to Props. When FCombinedCSSProps already exists then the expensive lookup is skipped and the existing object is used. *) procedure TIpHtmlNodeCore.LoadAndApplyCSSProps; var TmpProps: TCSSProps; begin if Owner.CSS = nil then exit; if FCombinedCSSProps = nil then begin FCombinedCSSProps := TCSSProps.Create; // first look for tag name only TmpProps := Owner.CSS.GetPropsObject(ElementName); if TmpProps <> nil then FCombinedCSSProps.MergeAdditionalProps(TmpProps); // look for .class if there is one if ClassID <> '' then begin TmpProps := Owner.CSS.GetPropsObject('', ClassId); if TmpProps <> nil then FCombinedCSSProps.MergeAdditionalProps(TmpProps); // then look for a tag.class selector if there is one TmpProps := Owner.CSS.GetPropsObject(ElementName, ClassId); if TmpProps <> nil then FCombinedCSSProps.MergeAdditionalProps(TmpProps); end; // lookup props for an id selector TmpProps := Owner.CSS.GetPropsObject(Id); if TmpProps <> nil then FCombinedCSSProps.MergeAdditionalProps(TmpProps); // inline css, not from the stylesheet if InlineCSS <> nil then FCombinedCSSProps.MergeAdditionalProps(InlineCSS); end; // look for :hover styles... if not FHoverPropsLookupDone then begin FHoverPropsRef := Owner.CSS.GetPropsObject(ElementName + ':hover'); FHoverPropsLookupDone := True; end; // ...apply them if there are any. if FHoverPropsRef <> nil then begin Props.DelayCache:=True; if FHoverPropsRef.Color <> clNone then Props.HoverColor := FHoverPropsRef.Color; if FHoverPropsRef.BgColor <> clNone then Props.HoverBgColor := FHoverPropsRef.BgColor; Props.DelayCache:=False; end; Props.DelayCache:=True; ApplyCSSProps(FCombinedCSSProps, Props); Props.DelayCache:=False; end; procedure TIpHtmlNodeCore.MakeVisible; var i : Integer; R : TRect; begin if FAreaList.Count = 0 then BuildAreaList; R := PRect(FAreaList[0])^; for i := 1 to Pred(FAreaList.Count) do UnionRect(R, R, PRect(FAreaList[i])^); Owner.MakeVisible(R, true); //Owner.MakeVisible(R, False); // original end; function TIpHtmlNodeCore.SelectCSSFont(const aFont: string): string; begin result := FindFontName(aFont); end; procedure TIpHtmlNodeCore.SetAlign(const Value: TIpHtmlAlign); begin Props.Alignment := Value; end; procedure TIpHtmlNodeCore.SetId(const Value: String); var idx: Integer; begin if FId <> '' then with Owner.IdList do begin idx := IndexOf(Id); if idx > -1 then Delete(idx); end; FId:= Value; if FId <> '' then Owner.IdList.AddObject(FId, Self); end; function CssMarginToProps(CssMargin: TCSSMargin; out ElemMargin: TIpHtmlElemMargin): boolean; begin ElemMargin.Style:=hemsAuto; ElemMargin.Size:=0; if CssMargin.Style=cmsNone then exit(false); if CssMargin.Style=cmsAuto then exit(true); if CssMargin.Style=cmsPx then begin ElemMargin.Style:=hemsPx; ElemMargin.Size:=CssMargin.Size; exit(true); end; if CssMargin.Style=cmsEm then begin ElemMargin.Style:=hemsPx; ElemMargin.Size:=10*CssMargin.Size; // 1em = 1 current font size exit(true); end; Result:=false; debugln(['TIpHtmlNodeCore.ApplyCSSProps.CssMarginToProps note: margin style not supported ',ord(CssMargin.Style)]); end; procedure TIpHtmlNodeCore.ApplyCSSProps(const ACSSProps: TCSSProps; const props: TIpHtmlProps); var ElemMargin: TIpHtmlElemMargin; begin if (ACSSProps<>nil) and (props<>nil) then begin props.DelayCache:=True; {$WARNING Setting these font colors and name messes up the alignment for some reason} if ACSSProps.Color <> clNone then begin Props.FontColor := ACSSProps.Color; end; if ACSSProps.BGColor <> clNone then begin Props.BgColor := ACSSProps.BGColor; end; if ACSSProps.Alignment <> haUnknown then begin Props.Alignment := ACSSProps.Alignment; end; if ACSSProps.Font.Name <> '' then begin // put the code here, later refactore it Props.FontName := SelectCSSFont(ACSSProps.Font.Name); end; {$WARNING TODO Set Font size from CSS Value} // see http://xhtml.com/en/CSS/reference/font-size/ if ACSSProps.Font.Size <> '' then begin // Props.FontSize := ACSSProps.Font.Size; props.FontSize:=GetFontSizeFromCSS(Props.FontSize, ACSSProps.Font.Size); end; if ACSSProps.Font.Style <> cfsNormal then begin case ACSSProps.Font.Style of cfsItalic,cfsOblique: Props.FontStyle := Props.FontStyle + [fsItalic]; cfsInherit: ; // what to do?: search through parent nodes looking for a computed value end; end; if ACSSProps.Font.Weight <> cfwNormal then begin case ACSSProps.Font.Weight of cfwBold : Props.FontStyle := Props.FontStyle + [fsBold]; cfwBolder : Props.FontStyle := Props.FontStyle + [fsBold]; cfwLighter : Props.FontStyle := Props.FontStyle - [fsBold]; cfw100 : ; cfw200 : ; cfw300 : ; cfw400 : ; cfw500 : ; cfw600 : ; cfw700 : ; cfw800 : ; cfw900 : ; end; end; if CssMarginToProps(ACSSProps.MarginTop,ElemMargin) then props.ElemMarginTop:=ElemMargin; if CssMarginToProps(ACSSProps.MarginRight,ElemMargin) then props.ElemMarginRight:=ElemMargin; if CssMarginToProps(ACSSProps.MarginBottom,ElemMargin) then props.ElemMarginBottom:=ElemMargin; if CssMarginToProps(ACSSProps.MarginLeft,ElemMargin) then props.ElemMarginLeft:=ElemMargin; props.DelayCache:=False; end; end; function TIpHtmlNodeCore.GetAlign: TIpHtmlAlign; begin Result := Props.Alignment; end; var // Remember previous in/out values for function GetFPxSize. PrevFontSize: string; PrevPxResult: Integer; // Calculate points based on screen resolution :( // at 96dpi CSS21 recommneds 1px=0.26 mm // TODO: use screen resolution, check printing! function GetFPxSize(aFontSize: string): Integer; var i: Integer; dd: double; begin // Optimize consecutive identical values. Return a saved value. if aFontSize=PrevFontSize then exit(PrevPxResult); // Calculate i := pos('px', aFontSize); if i>0 then begin dd := StrToFloatDef(copy(aFontSize,1,i-1), -1.0); Result := Round(dd * 0.7370241); PrevFontSize := aFontSize; PrevPxResult := Result; end else result := -1; end; function TIpHtmlNodeCore.GetFontSizeFromCSS(CurrentFontSize: Integer; aFontSize: string): Integer; function GetFSize(aUnits: string): double; var i: Integer; begin i := pos(aUnits, aFontSize); if i>0 then result := StrToFloatDef(copy(aFontSize,1,i-1), -1.0) else result := -1.0; end; function GetParentFontSize: integer; begin if (FParentNode is TIpHtmlNodeBlock) then result :=TIpHtmlNodeBlock(FParentNode).Props.FontSize else if (FParentNode is TIpHtmlNodeGenInline) then result := TIpHtmlNodeGenInline(FparentNode).Props.FontSize else if (FParentNode is TIpHtmlNodeHtml) or (FParentNode = nil) then Result := 14 else result := CurrentFontSize; end; var P: double; i: Integer; begin result := CurrentFontSize; // check px (most common) i:=GetFPxSize(aFontSize); if i>0 then exit(i); // check pt P:=GetFSize('pt'); if P>0 then exit(round(P)); //todo: em, ex are supposed to be based on the computed pixel size of // parent node, tpipro has no provision for this.... // check % P:=GetFSize('%'); if P>0 then exit(round(GetParentFontSize * P/100)); // check em P:=GetFSize('em'); if P>0 then result := round(GetParentFontSize * P); end; constructor TIpHtmlNodeCore.Create(ParentNode: TIpHtmlNode); begin inherited; FAreaList := TFPList.Create; end; destructor TIpHtmlNodeCore.Destroy; begin if Assigned(FInlineCSSProps) then FInlineCSSProps.Free; if Assigned(FCombinedCSSProps) then FCombinedCSSProps.Free; ClearAreaList; FAreaList.Free; inherited Destroy; end; { TIpHtmlNodeSTYLE } function TIpHtmlNodeSTYLE.ElementQueueIsEmpty: Boolean; begin Result := True; end; procedure TIpHtmlNodeSTYLE.EnqueueElement(const Entry: PIpHtmlElement); begin end; { TIpHtmlNodeIFRAME } procedure TIpHtmlNodeIFRAME.CreateControl(Parent: TWinControl); begin Owner.ControlCreate(Self); Owner.CreateIFrame(Parent, Self, FControl); end; procedure TIpHtmlNodeIFRAME.AddValues(NameList, ValueList: TStringList); begin end; procedure TIpHtmlNodeIFRAME.Reset; begin end; function TIpHtmlNodeIFRAME.Successful: Boolean; begin Result := False; end; destructor TIpHtmlNodeIFRAME.Destroy; begin inherited; FHeight.Free; FWidth.Free; end; procedure TIpHtmlNodeIFRAME.WidthChanged(Sender: TObject); begin InvalidateSize; end; procedure TIpHtmlNodeIFRAME.SetAlign(const Value: TIpHtmlAlign); begin if Value <> FAlign then begin FAlign := Value; InvalidateSize; end; end; procedure TIpHtmlNodeIFRAME.SetFrameBorder(const Value: Integer); begin if Value <> FFrameBorder then begin FFrameBorder := Value; InvalidateSize; end; end; procedure TIpHtmlNodeIFRAME.SetMarginHeight(const Value: Integer); begin if Value <> FMarginHeight then begin FMarginHeight := Value; InvalidateSize; end; end; procedure TIpHtmlNodeIFRAME.SetMarginWidth(const Value: Integer); begin if Value <> FMarginWidth then begin FMarginWidth := Value; InvalidateSize; end; end; procedure TIpHtmlNodeIFRAME.SetScrolling( const Value: TIpHtmlFrameScrolling); begin if Value <> FScrolling then begin FScrolling := Value; InvalidateSize; end; end; { TIpHtmlNodeInline } procedure TIpHtmlNodeInline.Invalidate; begin FParentNode.Invalidate; end; procedure TIpHtmlNodeInline.EnqueueElement(const Entry: PIpHtmlElement); begin FParentNode.EnqueueElement(Entry); end; function TIpHtmlNodeInline.ElementQueueIsEmpty: Boolean; begin Result := FParentNode.ElementQueueIsEmpty; end; { TIpHtmlNodeAlignInline } constructor TIpHtmlNodeAlignInline.Create(ParentNode: TIpHtmlNode); begin inherited; Element := Owner.NewElement(etObject, Self); Element.Props := Props; end; destructor TIpHtmlNodeAlignInline.Destroy; begin inherited; end; procedure TIpHtmlNodeAlignInline.Enqueue; begin EnqueueElement(Element); end; procedure TIpHtmlNodeAlignInline.SetAlignment( const Value: TIpHtmlImageAlign); begin FAlignment := Value; Invalidate; end; procedure TIpHtmlNodeAlignInline.SetRect(TargetRect: TRect); begin end; { TIpHtmlNodeControl } procedure TIpHtmlNodeControl.CalcMinMaxWidth(var Min, Max: Integer); begin if FControl <> nil then Min := FControl.Width else Min := 0; Max := Min; end; constructor TIpHtmlNodeControl.Create(ParentNode: TIpHtmlNode); begin inherited Create(ParentNode); Owner.ControlList.Add(Self); Align := hiaBottom; end; destructor TIpHtmlNodeControl.Destroy; begin Owner.ControlList.Remove(Self); inherited; end; procedure TIpHtmlNodeControl.Draw; var R : TRect; TopLeft : TPoint; Dim : TSize; begin if FControl <> nil then begin TopLeft := Element.WordRect2.TopLeft; R.TopLeft := TopLeft; Dim := GetDim(0); R.Right := TopLeft.x + Dim.cx; R.Bottom := TopLeft.y + Dim.cy; if PageRectToScreen(R, R) then begin FControl.Left := R.Left; FCOntrol.Top := R.Top; FControl.Visible := True; Shown := not ScaleBitmaps{True}; {Keep controls hidden during printing} end else FControl.Visible := False; end; end; function TIpHtmlNodeControl.adjustFromCss: boolean; begin result := false; LoadAndApplyCSSProps; if (props.FontSize <> -1) then FControl.Font.Size:= Props.FontSize; if Props.FontColor <> clNone then FControl.Font.Color:= Props.FontColor; if Props.BGColor <> clNone then FControl.Brush.Color:= Props.BGColor; result := True; end; procedure TIpHtmlNodeControl.SetDisabled(const AValue: Boolean); begin if FDisabled = AValue then exit; FDisabled := AValue; FControl.Enabled := not FDisabled; end; procedure TIpHtmlNodeControl.SetProps(const RenderProps: TIpHtmlProps); begin Props.Assign(RenderProps); LoadAndApplyCSSProps; end; function TIpHtmlNodeControl.GetDim(ParentWidth: Integer): TSize; begin if FControl <> nil then Result := SizeRec(FControl.Width, FControl.Height) else Result := SizeRec(0, 0); end; procedure TIpHtmlNodeControl.HideUnmarkedControl; begin if not Shown and (FControl <> nil) then FControl.Visible := False; end; procedure TIpHtmlNodeControl.UnmarkControl; begin Shown := False; end; { TIpHtmlNodeNv } procedure TIpHtmlNodeNv.Invalidate; begin end; procedure TIpHtmlNodeNv.InvalidateSize; begin end; procedure TIpHtmlNodeNv.EnqueueElement(const Entry: PIpHtmlElement); begin end; procedure TIpHtmlNodeNv.ReportDrawRects(M: TRectMethod); begin end; procedure TIpHtmlNodeNv.SetProps(const RenderProps: TIpHtmlProps); begin end; procedure TIpHtmlNodeNv.Enqueue; begin end; function TIpHtmlNodeNv.ElementQueueIsEmpty: Boolean; begin Result := True; end; { TIpHtmlNodeFRAMESET } destructor TIpHtmlNodeFRAMESET.Destroy; begin inherited; FCols.Free; FRows.Free; end; { TIpHtmlInternalPanel } constructor TIpHtmlInternalPanel.Create(AOwner: TComponent); begin inherited; ControlStyle := ControlStyle + [csCaptureMouse]; DragMode := dmManual; HScroll := TIpHtmlScrollBar.Create(Self, sbHorizontal); HScroll.Tracking := True; VScroll := TIpHtmlScrollBar.Create(Self, sbVertical); VScroll.Tracking := True; HintWindow := THintWindow.Create(Self); HintWindow.Color := Application.HintColor; end; destructor TIpHtmlInternalPanel.Destroy; begin HScroll.Free; VScroll.Free; HintWindow.Free; inherited; end; procedure TIpHtmlInternalPanel.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); with Params do Style := Style or WS_HSCROLL or WS_VSCROLL; end; procedure TIpHtmlInternalPanel.DoHotChange; begin if assigned(FOnHotChange) then FOnHotChange(Self); end; procedure TIpHtmlInternalPanel.DoCurElementChange; begin if assigned(FOnCurElementChange) then FOnCurElementChange(Self); end; procedure TIpHtmlInternalPanel.DoHotInvoke; begin if assigned(FOnHotClick) then FOnHotClick(Hyper); end; procedure TIpHtmlInternalPanel.DoClick; begin if assigned(FOnClick) then FOnClick(Hyper); end; procedure TIpHtmlInternalPanel.ShowHintNow(const NewHint: string); var Tw,Th : Integer; Sc : TPoint; begin if HtmlPanel.ShowHints then begin if (NewHint<>'') then begin Tw := HintWindow.Canvas.TextWidth(NewHint); Th := HintWindow.Canvas.TextHeight(NewHint); Sc := ClientToScreen(Point(HintX,HintY)); HintWindow.ActivateWithBounds(Rect(Sc.X + 6, Sc.Y + 16 - 6, Sc.X + Tw + 18, Sc.Y + Th + 16 + 6), NewHint); if Assigned(HtmlPanel.OnHotURL) then HtmlPanel.OnHotURL(HtmlPanel, NewHint); end else HideHint; CurHint := NewHint; HintShownHere := True; end; end; procedure TIpHtmlInternalPanel.MouseMove(Shift: TShiftState; X, Y: Integer); var OldHot : TIpHtmlNode; OldCurElement : PIpHtmlElement; TmpOwnerNode: TIpHtmlNode; begin if MouseIsDown and HaveSelection then begin SelEnd := Point(X + ViewLeft, Y + ViewTop); SetSelection; ScrollPtInView(Point(X + ViewLeft, Y + ViewTop)); end; if Hyper <> nil then begin OldHot := Hyper.HotNode; OldCurElement := Hyper.CurElement; Hyper.MouseMove(Point(X + ViewLeft, Y + ViewTop)); if (Hyper.HotNode <> OldHot) or (Hyper.HotPoint.x >= 0) then DoHotChange; if Hyper.HotNode <> nil then begin if Hyper.CurElement <> nil then begin Hyper.CurElement := nil; if OldCurElement <> Hyper.CurElement then DoCurElementChange; end; end else begin if HtmlPanel.AllowTextSelect then begin if Hyper.CurElement <> nil then begin if Hyper.CurElement.ElementType = etWord then Cursor := crIBeam else Cursor := crDefault; end else Cursor := crDefault; end; if OldCurElement <> Hyper.CurElement then DoCurElementChange; end; end; if (Hyper <> nil) and (Hyper.HotNode <> nil) then Hint := Hyper.HotNode.GetHint else if (Hyper <> nil) and (Hyper.CurElement <> nil) and (Hyper.CurElement.ElementType = etObject) and (Hyper.CurElement.Owner <> nil) then Hint := Hyper.CurElement.Owner.GetHint else Hint := ''; inherited; // show hints for IpHtmlTagABBR and IpHtmlTagACRONYM if (Hyper <> nil) and (Hyper.CurElement <> nil) then begin TmpOwnerNode := Hyper.CurElement.Owner; while TmpOwnerNode <> nil do begin if TmpOwnerNode is TIpHtmlNodePhrase then begin if (TIpHtmlNodePhrase(TmpOwnerNode).Style = hpsABBR) or (TIpHtmlNodePhrase(TmpOwnerNode).Style = hpsACRONYM) then begin Hint := TIpHtmlNodePhrase(TmpOwnerNode).Title; Break; end else begin TmpOwnerNode := TmpOwnerNode.FParentNode; end; end else begin TmpOwnerNode := TmpOwnerNode.FParentNode; end; end; end; // "refresh" hint if it should have new value OR cursors position changes significantly (then we reposition the hint with the same text) if (Hint <> CurHint) or ((abs(HintX - X) > 4) or (abs(HintY - Y) > 4)) then begin HintShownHere := False; HintX := X; HintY := Y; end; if not HintShownHere then ShowHintNow(Hint); end; procedure TIpHtmlInternalPanel.HideHint; begin HintWindow.Visible := False; end; procedure TIpHtmlInternalPanel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin MouseDownX := X; MouseDownY := Y; MouseIsDown := True; Self.SetFocus; if (Button=mbLeft) and HtmlPanel.AllowTextSelect then begin if Shift * [ssShift] = [] then begin ClearSelection; SelStart := Point(X + ViewLeft, Y + ViewTop); NewSelection := False; HaveSelection := True; end else if (Shift * [ssShift] = [ssShift]) and HaveSelection then begin SelEnd := Point(X + ViewLeft, Y + ViewTop); SetSelection; ScrollPtInView(SelEnd); end; end; inherited; end; procedure TIpHtmlInternalPanel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; MouseIsDown := False; if (abs(MouseDownX - X) < 4) and (abs(MouseDownY - Y) < 4) then if (Button = mbLeft) and (Shift = []) and (Hyper.HotNode <> nil) then // to avoid references to invalid objects do it asynchronously Application.QueueAsyncCall(AsyncHotInvoke, 0) else DoClick; end; procedure TIpHtmlInternalPanel.MouseLeave; begin HideHint; inherited MouseLeave; end; procedure TIpHtmlInternalPanel.KeyDown(var Key: Word; Shift: TShiftState); var TabList: TIpHtmlTabList; begin if (key = VK_TAB) and TIpHtmlCustomPanel(Owner).WantTabs then begin TabList := FHyper.FTabList; if TabList.Index = -1 then begin // TODO find best place to start the index at... TabList.Index := 0; end; if (TabList.Count > 0) then begin if TIpHtmlNode(TabList[TabList.Index]) is TIpHtmlNodeA then TIpHtmlNodeA(TabList[TabList.Index]).DoOnBlur else if TObject(TabList[TabList.Index]).InheritsFrom(TIpHtmlNodeControl) then TIpHtmlNodeControl(TabList[TabList.Index]).FControl.Parent.SetFocus; if (ssShift in Shift) then begin if (TabList.Index > 0) then begin TabList.Index := TabList.Index -1; Key := 0; end else TabList.Index:=TabList.Count-1; end; if not(ssShift in Shift) then begin if TabList.Index < TabList.Count-1 then begin TabList.Index := TabList.Index + 1; Key := 0; end else TabList.Index := 0; end; if Key = 0 then begin if TIpHtmlNode(TabList[TabList.Index]) is TIpHtmlNodeA then TIpHtmlNodeA(TabList[TabList.Index]).DoOnFocus else if TObject(TabList[TabList.Index]).InheritsFrom(TIpHtmlNodeControl) then TIpHtmlNodeControl(TabList[TabList.Index]).FControl.SetFocus; end; end; end else if (key = VK_PRIOR) or ((key = VK_SPACE) and (ssShift in Shift)) then // page up begin TIpHtmlCustomPanel(Owner).Scroll(hsaPgUp); Key := 0 end else if (key = VK_NEXT) or ((key = VK_SPACE) and not(ssShift in Shift)) then // page down begin TIpHtmlCustomPanel(Owner).Scroll(hsaPgDn); Key := 0 end else if key = VK_UP then // up begin TIpHtmlCustomPanel(Owner).Scroll(hsaUp, TIpHtmlCustomPanel(Owner).ScrollDist); Key := 0 end else if key = VK_DOWN then // down begin TIpHtmlCustomPanel(Owner).Scroll(hsaDown, TIpHtmlCustomPanel(Owner).ScrollDist); Key := 0 end else if key = VK_LEFT then // left begin TIpHtmlCustomPanel(Owner).Scroll(hsaLeft, TIpHtmlCustomPanel(Owner).ScrollDist); Key := 0 end else if key = VK_RIGHT then // right begin TIpHtmlCustomPanel(Owner).Scroll(hsaRight, TIpHtmlCustomPanel(Owner).ScrollDist); Key := 0 end else if key = VK_HOME then // home begin TIpHtmlCustomPanel(Owner).Scroll(hsaHome); Key := 0 end else if key = VK_END then // end begin TIpHtmlCustomPanel(Owner).Scroll(hsaEnd); Key := 0 end else if ((key = VK_C) or (key = VK_INSERT)) and (Shift = [ssCtrl]) then // copy to clipboard begin HtmlPanel.CopyToClipboard; // FHyper.CopyToClipboard; Key := 0; end else if (key = VK_A) and (Shift = [ssCtrl]) then // select all begin HtmlPanel.SelectAll; // FHyper.SelectAll; // Invalidate; Key := 0; end else if key = VK_RETURN then // return begin if (FHyper.FTabList.TabItem <> nil) and (FHyper.FTabList.TabItem is TIpHtmlNodeA) then begin TIpHtmlNodeA(FHyper.FTabList.TabItem).Hot:=True; FHyper.FHotNode := TIpHtmlNodeA(FHyper.FTabList.TabItem); DoHotChange; Application.QueueAsyncCall(AsyncHotInvoke, 0); Key := 0 end; end else if ((key = VK_C) or (key = VK_INSERT)) and (ssCtrl in Shift) then FHyper.CopyToClipboard else inherited KeyDown(Key, Shift); end; function TIpHtmlInternalPanel.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; const WHEEL_DELTA = 120; var i: Integer; begin inherited DoMouseWheel(Shift, WheelDelta, MousePos); for i := abs(Mouse.WheelScrollLines * WheelDelta div WHEEL_DELTA) downto 0 do if WheelDelta < 0 then Perform(LM_VSCROLL, MAKELONG(SB_LINEDOWN, 0), 0) else Perform(LM_VSCROLL, MAKELONG(SB_LINEUP, 0), 0); // should always return true to confirm that // the MouseWheel Event is handled by TIpHtmlInternalPanel Result:= true; end; procedure TIpHtmlInternalPanel.Paint; var CR: TRect; begin if FPaintingLock > 0 then exit; inc(FPaintingLock); try if Assigned(HTMLPanel.OnPaint) then HTMLPanel.OnPaint(HTMLPanel); CR := GetClientRect; if not ScaleBitmaps {printing} and (Hyper <> nil) then begin // update layout GetPageRect; // render Hyper.Render(Canvas, Rect( ViewLeft, ViewTop, ViewLeft + (CR.Right - CR.Left), ViewTop + (CR.Bottom - CR.Top) ), ViewTop, ViewTop + (CR.Bottom - CR.Top), HTMLPanel.UsePaintBuffer, Point(0, 0) ); FHyper.NeedResize := False; end else Canvas.FillRect(CR); //debugln(['TIpHtmlInternalPanel.Paint ',dbgs(CR)]); {$IFDEF IP_LAZARUS_DBG} DebugBox(Canvas, CR, clYellow); Debugbox(Canvas, Canvas.ClipRect, clLime, true); {$ENDIF} finally dec(FPaintingLock); end; end; {$IFDEF Html_Print} function TIpHtmlInternalPanel.PreviewAntiAliasingMode: TAntiAliasingMode; begin Result := HTMLPanel.PrintSettings.Preview.AntiAliasingMode; end; procedure TIpHtmlInternalPanel.BeginPrint; begin if InPrint = 0 then begin Printed := False; ScaleBitmaps := True; ResetPrint; end; Inc(InPrint); end; procedure TIpHtmlInternalPanel.EndPrint; begin Dec(InPrint); if InPrint = 0 then begin ScaleBitmaps := False; InvalidateSize; end; end; procedure TIpHtmlInternalPanel.ResetPrint; var LogPixX, LMarginPix, RMarginPix, LogPixY, TMarginPix, BMarginPix, H: Integer; oldPrinterFileName: String; begin // check ir BeginPrint was called if not Printed then begin SetRectEmpty(PrintPageRect); if Hyper.TitleNode <> nil then Printer.Title := Hyper.TitleNode.Title else Printer.Title := 'HTML Document'; // Avoid showing the print file selection dialog appearing in case of some // PDF printers. oldPrinterFileName := Printer.FileName; Printer.FileName := 'test'; Printer.BeginDoc; GetRelativeAspect(Printer.Canvas.Handle); {$IF NOT DEFINED(WINDOWS)} // this test looks weird, according to most references consulted, the number // of colors in a display is NColors = 1 shl (bitsPerPixel * Planes). A mono // printer should have 2 colors, somebody else needs to clarify. BWPrinter := false; {$ELSE} BWPrinter := GetDeviceCaps(Printer.Canvas.Handle, NUMCOLORS) = 2; {$ENDIF} LogPixX := Printer.XDPI; LMarginPix := round(HtmlPanel.PrintSettings.MarginLeft * LogPixX); RMarginPix := round(HtmlPanel.PrintSettings.MarginRight * LogPixX); PrintWidth := Printer.PageWidth - LMarginPix - RMarginPix; LogPixY := Printer.YDPI; TMarginPix := round(HtmlPanel.PrintSettings.MarginTop * LogPixY); BMarginPix := round(HtmlPanel.PrintSettings.MarginBottom * LogPixY); if Printer.Printers.Count = 0 then begin PrintHeight := 500; end else begin PrintHeight := Printer.PageHeight - TMarginPix - BMarginPix; end; PrintTopLeft := Point(LMarginPix, TMarginPix); {PrintBottomRight := Point( Printer.PageWidth - RMarginPix, Printer.PageHeight - BMarginPix);} PrintPageRect := Hyper.GetPageRect(Printer.Canvas, PrintWidth, PrintHeight); H := PrintPageRect.Bottom - PrintPageRect.Top; PageCount := H div PrintHeight; if H mod PrintHeight <> 0 then Inc(PageCount); Printer.Abort; Printer.FileName := oldPrinterFileName; end else raise Exception.Create('BeginPrint must be called before ResetPrint.'); end; function TIpHtmlInternalPanel.SelectPrinterDlg: boolean; var printDialog: TPrintDialog; begin Result := False; printDialog := TPrintDialog.Create(nil); if printDialog.Execute then begin ResetPrint; Result := true; end; printDialog.Free; end; procedure TIpHtmlInternalPanel.PrintPages(FromPage, ToPage: Integer); var CR : TRect; i : Integer; oldRD: TIpHtmlRenderDevice; begin if (Hyper <> nil) then begin oldRD := Hyper.RenderDevice; Printer.Refresh; BeginPrint; Printer.BeginDoc; try CR := Rect(0, 0, PrintWidth, 0); for i := FromPage to ToPage do begin CR.Top := (i - 1) * PrintHeight; CR.Bottom := Cr.Top + PrintHeight; Hyper.FRenderDev := rdPrinter; Hyper.Render(Printer.Canvas, CR, False, PrintTopLeft); if i < ToPage then Printer.NewPage; Printed := True; end; finally if Printed then Printer.EndDoc else Printer.Abort; EndPrint; Hyper.FRenderDev := oldRD; end; end; end; procedure TIpHtmlInternalPanel.PrintPreview; var preview: TIpHtmlPreview; p: TPosition; oldRD: TIpHtmlRenderDevice; begin if (Hyper <> nil) then begin oldRD := Hyper.RenderDevice; BeginPrint; try preview := TIpHTMLPreview.Create(Application); with preview do try p := HTMLPanel.PrintSettings.Preview.Position; if not (p in [poDefault, poDefaultSizeOnly]) then begin Width := HTMLPanel.PrintSettings.Preview.Width; Height := HTMLPanel.PrintSettings.Preview.Height; end; if (p = poDesigned) or (p = poDefaultSizeOnly) then begin Left := HTMLPanel.PrintSettings.Preview.Left; Top := HTMLPanel.PrintSettings.Preview.Top; end; Position := p; if HTMLPanel.PrintSettings.Preview.Maximized then WindowState := wsMaximized else WindowState := wsNormal; lblMaxPage.Caption := IntToStr(PageCount); FCurPage := 1; HTML := Hyper; ScaleFonts := True; try OwnerPanel := Self; Zoom := HTMLPanel.PrintSettings.Preview.Zoom; Hyper.FRenderDev := rdPreview; ShowModal; HTMLPanel.PrintSettings.Preview.Maximized := (WindowState = wsMaximized); if (WindowState = wsNormal) then begin if (p = poDesigned) or (p = poDefaultSizeOnly) then begin HTMLPanel.PrintSettings.Preview.Left := Left; HTMLPanel.PrintSettings.Preview.Top := Top; end; if not (p in [poDefault, poDefaultSizeOnly]) then begin HTMLPanel.PrintSettings.Preview.Width := Width; HTMLPanel.PrintSettings.Preview.Height := Height; end; end; finally ScaleFonts := False; end; finally Free; end; finally EndPrint; Hyper.FRenderDev := oldRD; end; end; end; {$ENDIF} procedure TIpHtmlInternalPanel.EraseBackground(DC: HDC); begin // end; {$IFDEF Html_Print} function TIpHtmlInternalPanel.GetPrintPageCount: Integer; begin BeginPrint; try Result := PageCount; finally EndPrint; end; end; {$ENDIF} procedure TIpHtmlInternalPanel.InvalidateSize; begin FPageRectValid:=false; if FPaintingLock = 0 then Invalidate; end; procedure TIpHtmlInternalPanel.DoOnResize; begin inherited; InvalidateSize; if Assigned(FHyper) then FHyper.NeedResize := True; end; function TIpHtmlInternalPanel.PagePtToScreen(const Pt : TPoint): TPoint; {-convert coordinates of point passed in to screen coordinates} begin Result := Pt; Dec(Result.x, ViewLeft); Dec(Result.y, ViewTop); end; procedure TIpHtmlInternalPanel.ScrollInViewRaw(R : TRect); begin R.TopLeft := PagePtToScreen(R.TopLeft); R.BottomRight := PagePtToScreen(R.BottomRight); if R.Left < 0 then with HScroll do Position := Position + R.Left else if R.Right > ClientWidth then begin if R.Right - R.Left > ClientWidth then R.Right := R.Left + ClientWidth; with HScroll do Position := Position + R.Right - ClientWidth; end; if R.Top < 0 then with VScroll do Position := Position + R.Top else if R.Bottom > ClientHeight then begin if R.Bottom - R.Top > ClientHeight then R.Bottom := R.Top + ClientHeight; with VScroll do Position := Position + R.Bottom - ClientHeight; end; end; procedure TIpHtmlInternalPanel.ScrollInView(R : TRect); begin R.Bottom := R.Top + (ClientHeight - (R.Bottom - R.Top) - 10); R.Right := R.Left + (ClientWidth - (R.Right - R.Left) - 10); ScrollInViewRaw(R); end; procedure TIpHtmlInternalPanel.ScrollPtInView(P : TPoint); begin P := PagePtToScreen(P); if P.x < 0 then with HScroll do Position := Position + P.x else if P.x > ClientWidth then begin with HScroll do Position := Position + P.x - ClientWidth; end; if P.y < 0 then with VScroll do Position := Position + P.y else if P.y > ClientHeight then begin with VScroll do Position := Position + P.y - ClientHeight; end; end; procedure TIpHtmlInternalPanel.ScrollRequest(Sender: TIpHtml; const R: TRect; ShowAtTop: Boolean = True); begin if not ShowAtTop then ScrollInViewRaw(R) else ScrollInView(R); end; procedure TIpHtmlInternalPanel.SetHtml(const Value: TIpHtml); begin FHyper := Value; InvalidateSize; end; function TIpHtmlInternalPanel.GetPageRect: TRect; begin if not FPageRectValid then begin if Hyper <> nil then PageRect := Hyper.GetPageRect(Canvas, ClientWidth, 0) else PageRect:=Rect(0,0,0,0); FPageRectValid:=true; end; Result:=FPageRect; end; procedure TIpHtmlInternalPanel.SetPageRect(const Value: TRect); begin if not SettingPageRect then begin SettingPageRect := True; FPageRect := Value; HScroll.CalcAutoRange; VScroll.CalcAutoRange; SettingPageRect := False; end; end; procedure TIpHtmlInternalPanel.UpdateScrollBars; begin if not FUpdatingScrollBars and HandleAllocated then try FUpdatingScrollBars := True; if VScroll.NeedsScrollBarVisible then begin HScroll.Update(False, True); VScroll.Update(True, False); end else if HScroll.NeedsScrollBarVisible then begin VScroll.Update(False, True); HScroll.Update(True, False); end else begin VScroll.Update(False, False); HScroll.Update(True, False); end; GetPageRect(); finally FUpdatingScrollBars := False; end; end; procedure TIpHtmlInternalPanel.WMHScroll(var Message: TLMHScroll); begin if HScroll.Visible then begin HScroll.ScrollMessage(Message); Message.Result := 1; end; end; procedure TIpHtmlInternalPanel.WMVScroll(var Message: TLMVScroll); begin if VScroll.Visible then begin VScroll.ScrollMessage(Message); Message.Result := 1; end; end; procedure TIpHtmlInternalPanel.AsyncHotInvoke(data: ptrint); begin DoHotInvoke; end; procedure TIpHtmlInternalPanel.WMEraseBkgnd(var Message: TWmEraseBkgnd); begin Message.Result := 1; end; procedure TIpHtmlInternalPanel.ClearSelection; begin Hyper.SetSelection(Point(-1, -1), Point(-1, -1)); HaveSelection := False; end; procedure TIpHtmlInternalPanel.SetSelection; begin if Hyper <> nil then Hyper.SetSelection(SelStart, SelEnd); end; function TIpHtmlInternalPanel.HtmlPanel: TIpHtmlCustomPanel; begin Result := TIpHtmlPanel(Parent); while not (Result is TIpHtmlPanel) do Result := TIpHtmlPanel(Result.Parent); end; { TIpHtmlScrollBar } constructor TIpHtmlScrollBar.Create(AControl: TIpHtmlInternalPanel; AKind: TScrollBarKind); begin inherited Create; FControl := AControl; FKind := AKind; FPageIncrement := 80; FIncrement := FPageIncrement div 10; FVisible := True; FUpdateNeeded := True; end; procedure TIpHtmlScrollBar.CalcAutoRange; begin if Kind = sbHorizontal then DoSetRange(FControl.PageRect.Right) else DoSetRange(FControl.PageRect.Bottom); end; function TIpHtmlScrollBar.ControlSize(ControlSB, AssumeSB: Boolean): Integer; var BorderAdjust: Integer; function ScrollBarVisible(Code: Word): Boolean; var Style: Longint; begin Style := WS_HSCROLL; if Code = SB_VERT then Style := WS_VSCROLL; Result := GetWindowLong(FControl.Handle, GWL_STYLE) and Style <> 0; end; function Adjustment(Code, Metric: Word): Integer; begin Result := 0; if not ControlSB then if AssumeSB and not ScrollBarVisible(Code) then Result := -(GetSystemMetrics(Metric) - BorderAdjust) else if not AssumeSB and ScrollBarVisible(Code) then Result := GetSystemMetrics(Metric) - BorderAdjust; end; begin BorderAdjust := Integer(GetWindowLong(FControl.Handle, GWL_STYLE) and (WS_BORDER or WS_THICKFRAME) <> 0); if Kind = sbVertical then Result := FControl.ClientHeight + Adjustment(SB_HORZ, SM_CXHSCROLL) else Result := FControl.ClientWidth + Adjustment(SB_VERT, SM_CYVSCROLL); end; function TIpHtmlScrollBar.NeedsScrollBarVisible: Boolean; begin Result := FRange > ControlSize(False, False); end; procedure TIpHtmlScrollBar.ScrollMessage(var Msg: TLMScroll); function GetRealScrollPosition: Integer; var SI: TScrollInfo; Code: Integer; begin SI.cbSize := SizeOf(TScrollInfo); SI.fMask := SIF_TRACKPOS; Code := SB_HORZ; if FKind = sbVertical then Code := SB_VERT; Result := Msg.Pos; if FlatSB_GetScrollInfo(FControl.Handle, Code, SI) then Result := SI.nTrackPos; end; begin with Msg do case ScrollCode of SB_LINEUP: SetPosition(FPosition - FIncrement); SB_LINEDOWN: SetPosition(FPosition + FIncrement); SB_PAGEUP: SetPosition(FPosition - ControlSize(True, False)); SB_PAGEDOWN: SetPosition(FPosition + ControlSize(True, False)); SB_THUMBPOSITION: if FCalcRange > 32767 then SetPosition(GetRealScrollPosition) else SetPosition(Pos); SB_THUMBTRACK: if Tracking then if FCalcRange > 32767 then SetPosition(GetRealScrollPosition) else SetPosition(Pos); SB_TOP: SetPosition(0); SB_BOTTOM: SetPosition(FCalcRange); SB_ENDSCROLL: ; end; end; procedure TIpHtmlScrollBar.SetPosition(Value: Integer); var Code: Word; begin if csReading in FControl.ComponentState then FPosition := Value else begin if Value > FCalcRange then Value := FCalcRange else if Value < 0 then Value := 0; if Kind = sbHorizontal then Code := SB_HORZ else Code := SB_VERT; if Value <> FPosition then begin FPosition := Value; if Kind = sbHorizontal then FControl.ViewLeft := Value else FControl.ViewTop := Value; FControl.Invalidate; end; if FlatSB_GetScrollPos(FControl.Handle, Code) <> FPosition then FlatSB_SetScrollPos(FControl.Handle, Code, FPosition, True); end; end; procedure TIpHtmlScrollBar.DoSetRange(Value: Integer); begin FRange := Value; if FRange < 0 then FRange := 0; FControl.UpdateScrollBars; end; procedure TIpHtmlScrollBar.SetVisible(Value: Boolean); begin FVisible := Value; FControl.UpdateScrollBars; end; procedure TIpHtmlScrollBar.Update(ControlSB, AssumeSB: Boolean); type TPropKind = (pkStyle, pkButtonSize, pkThumbSize, pkSize, pkBkColor); const Props: array[TScrollBarKind, TPropKind] of Integer = ( (WSB_PROP_HSTYLE, WSB_PROP_CXHSCROLL, WSB_PROP_CXHTHUMB, WSB_PROP_CYHSCROLL, WSB_PROP_HBKGCOLOR), (WSB_PROP_VSTYLE, WSB_PROP_CYVSCROLL, WSB_PROP_CYVTHUMB, WSB_PROP_CXVSCROLL, WSB_PROP_VBKGCOLOR)); var Code: Word; ScrollInfo: TScrollInfo; iPi: integer; procedure UpdateScrollProperties(Redraw: Boolean); begin FlatSB_SetScrollProp(FControl.Handle, Props[Kind, pkStyle], FSB_REGULAR_MODE, Redraw); FlatSB_SetScrollProp(FControl.Handle, Props[Kind, pkBkColor], integer(ColorToRGB(clBtnHighlight)), False); end; begin FCalcRange := 0; Code := SB_HORZ; if Kind = sbVertical then Code := SB_VERT; if Visible then begin FCalcRange := Range - ControlSize(ControlSB, AssumeSB); if FCalcRange < 0 then FCalcRange := 0; end; ScrollInfo.cbSize := SizeOf(ScrollInfo); ScrollInfo.fMask := SIF_ALL; ScrollInfo.nMin := 0; if FCalcRange > 0 then ScrollInfo.nMax := Range else ScrollInfo.nMax := 0; iPi := ControlSize(ControlSB, AssumeSB) + 1; if iPi < 1 then iPi := 1; ScrollInfo.nPage := iPi; ScrollInfo.nPos := FPosition; ScrollInfo.nTrackPos := FPosition; UpdateScrollProperties(FUpdateNeeded); FUpdateNeeded := False; FlatSB_SetScrollInfo(FControl.Handle, Code, ScrollInfo, True); SetPosition(FPosition); iPi := (ControlSize(True, False) * 9) div 10; if iPi < low(TScrollbarInc) then iPi := low(TScrollbarInc) else if iPi > high(TScrollbarInc) then iPi := high(TScrollbarInc); FPageIncrement := iPi; end; { TIpHtmlFrame } procedure TIpHtmlFrame.InitHtml; begin FHtml.FixedTypeface := Viewer.FixedTypeface; FHtml.DefaultTypeFace := Viewer.DefaultTypeFace; FHtml.DefaultFontSize := Viewer.DefaultFontSize; FHtml.TextColor := FViewer.TextColor; FHtml.LinkColor := FViewer.LinkColor; FHtml.ALinkColor := FViewer.ALinkColor; FHtml.VLinkColor := FViewer.VLinkColor; FHtml.BgColor := FViewer.BgColor; FHtml.LinksUnderlined := FViewer.LinksUnderlined; if FViewer.DataProvider <> nil then FHtml.OnGetImageX := FViewer.DataProvider.DoGetImage; FHtml.OnInvalidateRect := InvalidateRect; FHtml.OnInvalidateSize := InvalidateSize; FHtml.OnGet := Get; FHtml.OnPost := Post; FHtml.OnIFrameCreate := IFrameCreate; FHtml.OnURLCheck := FViewer.URLCheck; FHtml.OnReportURL := FViewer.ReportURL; FHtml.FlagErrors := FFlagErrors; FHtml.MarginWidth := FMarginWidth; FHtml.MarginHeight := FMarginHeight; if FDataProvider <> nil then FHtml.FDataProvider := FDataProvider; FHtml.FactBAParag := FViewer.FactBAParag; end; constructor TIpHtmlFrame.Create(Viewer: TIpHtmlCustomPanel; Parent: TCustomPanel; DataProvider : TIpAbstractHtmlDataProvider; FlagErrors, NoScroll: Boolean; MarginWidth, MarginHeight: Integer); begin inherited Create; FNoScroll := NoScroll; FParent := Parent; FViewer := Viewer; FDataProvider := DataProvider; FHtml := TIpHtml.Create; FFlagErrors := FlagErrors; FMarginWidth := MarginWidth; FMarginheight := MarginHeight; InitHtml; end; destructor TIpHtmlFrame.Destroy; var i : Integer; begin if FFramePanel <> nil then FFramePanel.OnResize := nil; for i := 0 to Pred(FFrameCount) do FreeAndNil(FFrames[i]); if HyperPanel <> nil then begin HyperPanel.Hyper := nil; HyperPanel.Free; HyperPanel := nil; end; //debugln(['TIpHtmlFrame.Destroy ',DbgSName(Self),' ',dbgs(Pointer(FDataProvider))]); if (FDataProvider <> nil) and (not (csDestroying in FDataProvider.ComponentState)) then FDataProvider.DoLeave(FHtml); FreeAndNil(FHtml); inherited; end; procedure TIpHtmlFrame.InvalidateRect(Sender: TIpHtml; const R: TRect); begin if HyperPanel <> nil then LCLIntf.InvalidateRect(HyperPanel.Handle, @R, False); end; procedure TIpHtmlFrame.InvalidateSize(Sender: TObject); begin if HyperPanel <> nil then if not InOpen then HyperPanel.InvalidateSize; end; procedure TIpHtmlFrame.OpenURL(const URL: string; Delayed: Boolean); begin if Delayed then begin FViewer.GetURL := URL; FViewer.PostURL := ''; FViewer.PostData := nil; PostMessage(FViewer.Handle, CM_IpHttpGetRequest, 0, PtrInt(Self)); end else OpenRelativeURL(URL); end; procedure TIpHtmlFrame.AlignPanels; var ColW : TIntArr; RowH : TIntArr; ColWCount, RowHCount : Integer; N, i, R, C, L, T : Integer; begin if (FHtml = nil) or (FHtml.FrameSet = nil) then Exit; if FFramePanel = nil then Exit; ColW := CalcMultiLength(FHtml.FrameSet.Cols, FFramePanel.ClientWidth, ColWCount); try RowH := CalcMultiLength(FHtml.FrameSet.Rows, FFramePanel.ClientHeight, RowHCount); try R := 0; C := 0; L := 0; T := 0; N := 0; for i := 0 to Pred(FHtml.FrameSet.ChildCount) do begin if FHtml.FrameSet.ChildNode[i] is TIpHtmlNodeFrame then begin if Pnl[N] <> nil then Pnl[N].SetBounds(L, T, ColW[C], RowH[R]); Inc(L, ColW[C]); if C < ColWCount - 1 then Inc(C) else begin C := 0; L := 0; Inc(T, RowH[R]); Inc(R); end; Inc(N); end; end; finally RowH.Free; end; finally ColW.Free; end; end; function TIpHtmlFrame.IsExternal(const URL: string): Boolean; var St, ResourceType : string; begin if Assigned(FDataProvider) then St := FDataProvider.BuildURL(FCurURL, URL) else St := IpUtils.BuildURL(FCurURL, URL); if FDataProvider = nil then raise EIpHtmlException.Create(SHtmlNoDataProvider); if not FDataProvider.DoCheckURL(St, ResourceType) then raise EIpHtmlException.Create(SHtmlResUnavail + St); if (PosI('text/', ResourceType) <> 1) and (PosI('image/', ResourceType) <> 1) then begin FViewer.FHotURL := St; FViewer.DoHotClick; Result := True; end else Result := False; end; function BuildImagePage(const URL: string): TMemoryStream; var S : string; begin Result := TMemoryStream.Create; S := ''; Result.Write(S[1], length(S)); Result.Seek(0, 0); end; procedure TIpHtmlFrame.InternalFreeFrames; var i: integer; begin for i := 0 to Pred(FFrameCount) do FFrames[i].Free; FFramePanel.Free; FFramePanel := nil; FFrameCount := 0; if HyperPanel <> nil then begin FHtml.OnScroll := nil; HyperPanel.Hyper := nil; HyperPanel.Free; HyperPanel := nil; end; if FDataProvider <> nil then FDataProvider.DoLeave(FHtml); FHtml.Clear; FHtml.Free; end; procedure TIpHtmlFrame.InternalCreateFrames; var MW, MH, i, R, C, L, T : Integer; ColW : TIntArr; RowH : TIntArr; ColWCount, RowHCount : Integer; Scroll : Boolean; CurFrameDef : TIpHtmlNodeFrame; begin ColWCount := 0; RowHCount := 0; if FHtml.HasFrames then begin FFramePanel := TPanel.Create(FParent); FFramePanel.BevelOuter := bvNone; FFramePanel.Align := alClient; FFramePanel.Parent := FParent; FFramePanel.OnResize := FramePanelResize; FFramePanel.FullRepaint := False; ColW := CalcMultiLength(FHtml.FrameSet.Cols, FFramePanel.ClientWidth, ColWCount); try RowH := CalcMultiLength(FHtml.FrameSet.Rows, FFramePanel.ClientHeight, RowHCount); try R := 0; C := 0; L := 0; T := 0; FFrameCount := 0; for i := 0 to Pred(FHtml.FrameSet.ChildCount) do begin if FHtml.FrameSet.ChildNode[i] is TIpHtmlNodeFrame then begin CurFrameDef := TIpHtmlNodeFrame(FHtml.FrameSet.ChildNode[i]); Pnl[FFrameCount] := TPanel.Create(FFramePanel); Pnl[FFrameCount].BevelOuter := bvNone; Pnl[FFrameCount].SetBounds(L, T, ColW[C], RowH[R]); Pnl[FFrameCount].Parent := FFramePanel; Pnl[FFrameCount].FullRepaint := False; if CurFrameDef.FrameBorder <> 0 then begin Pnl[FFrameCount].BorderStyle := bsSingle; Pnl[FFrameCount].BorderWidth := CurFrameDef.FrameBorder; end; Inc(L, ColW[C]); case CurFrameDef.Scrolling of hfsAuto, hfsYes : Scroll := True; else //hfsNo : Scroll := False; end; if CurFrameDef.MarginWidth <> -1 then MW := CurFrameDef.MarginWidth else MW := FViewer.MarginWidth; if CurFrameDef.MarginHeight <> -1 then MH:= CurFramedef.MarginHeight else MH := FViewer.MarginHeight; FFrames[FFrameCount] := TIpHtmlFrame.Create(FViewer, Pnl[FFrameCount], FDataProvider, FViewer.FlagErrors, not Scroll, MW, MH); FFrames[FFrameCount].FName := CurFrameDef.Name; if C < ColWCount - 1 then Inc(C) else begin C := 0; L := 0; Inc(T, RowH[R]); Inc(R); end; Inc(FFrameCount); end; end; finally RowH.Free; end; finally ColW.Free; end; Application.ProcessMessages; FFrameCount := 0; for i := 0 to Pred(FHtml.FrameSet.ChildCount) do begin if FHtml.FrameSet.ChildNode[i] is TIpHtmlNodeFrame then begin FFrames[FFrameCount].FCurURL := FCurURL; FFrames[FFrameCount].OpenRelativeURL( TIpHtmlNodeFrame(FHtml.FrameSet.ChildNode[i]).Src); Inc(FFrameCount); end; end; end else begin HyperPanel := TIpHtmlInternalPanel.Create(FParent); if FNoScroll then begin HyperPanel.HScroll.Visible := False; HyperPanel.VScroll.Visible := False; end; HyperPanel.Parent := FParent; HyperPanel.Align := alClient; HyperPanel.OnHotChange := FViewer.HotChange; HyperPanel.OnCurElementChange := FViewer.CurElementChange; HyperPanel.OnHotClick := FViewer.HotClick; HyperPanel.OnClick := FViewer.ClientClick; HyperPanel.TabStop := FViewer.WantTabs; FHtml.ControlParent := HyperPanel; FHtml.OnScroll := HyperPanel.ScrollRequest; FHtml.OnControlClick := ControlClick; FHtml.OnControlClick2 := ControlClick2; FHtml.OnControlChange := ControlOnChange; FHtml.OnControlEditingdone := ControlOnEditingDone; FHtml.OnControlCreate := ControlCreate; for i := 0 to Pred(FHtml.ControlList.Count) do TIpHtmlNode(FHtml.ControlList[i]).CreateControl(HyperPanel); HyperPanel.Hyper := FHtml; end; end; procedure TIpHtmlFrame.OpenRelativeURL(const URL: string); var S : TStream; St, ResourceType : string; IsImage : Boolean; begin InOpen := True; try if Assigned(FDataProvider) then St := FDataProvider.BuildURL(FCurURL, URL) else St := IpUtils.BuildURL(FCurURL, URL); if FDataProvider = nil then raise EIpHtmlException.Create(SHtmlNoDataProvider); if not FDataProvider.DoCheckURL(St, ResourceType) then raise EIpHtmlException.Create(SHtmlResUnavail + St); IsImage := False; S := nil; if PosI('image/', ResourceType) = 1 then begin IsImage := True; S := BuildImagePage(St); end else if PosI('text/', ResourceType) <> 1 then begin FViewer.FHotURL := St; FViewer.DoHotClick; Exit; end; FCurURL := St; FCurAnchor := ''; InternalFreeFrames; //Memory comsumption is too high without free FHtml := TIpHtml.Create; InitHtml; //see above if FDataProvider <> nil then begin if not IsImage then S := FDataProvider.DoGetHtmlStream(FCurURL, PostData); if S <> nil then try FHtml.FCurURL := FCurURL; FHtml.LoadFromStream(S); InternalCreateFrames; finally S.Free; end; end; finally InOpen := False; end; end; procedure TIpHtmlFrame.FramePanelResize(Sender: TObject); begin AlignPanels; end; procedure TIpHtmlFrame.MakeAnchorVisible(const URL: string); var E : TIpHtmlNode; i : Integer; begin E := FHtml.FindElement(URL); if E = nil then E := FHtml.FindElementID(URL); FCurAnchor := ''; if E <> nil then begin HyperPanel.GetPageRect; // Make sure that layout is valid E.MakeVisible; FCurAnchor := '#'+URL; end else for i := 0 to Pred(FFrameCount) do FFrames[i].MakeAnchorVisible(URL); end; procedure TIpHtmlFrame.Home; begin if FHtml <> nil then FHtml.Home; end; function TIpHtmlFrame.FindFrame(const FrameName: string): TIpHtmlFrame; var i : Integer; begin if AnsiCompareText(FrameName, FName) = 0 then Result := Self else begin Result := nil; for i := 0 to Pred(FFrameCount) do begin Result := FFrames[i].FindFrame(FrameName); if Result <> nil then Exit; end; end; end; procedure TIpHtmlFrame.Get(Sender: TIpHtml; const URL: string); begin FViewer.GetURL := URL; FViewer.PostURL := ''; FViewer.PostData := nil; PostMessage(FViewer.Handle, CM_IpHttpGetRequest, 0, PtrInt(Self)); end; procedure TIpHtmlFrame.Post(Sender: TIpHtml; const URL: string; FormData: TIpFormDataEntity); begin FViewer.GetURL := ''; FViewer.PostURL := URL; FViewer.PostData := FormData; PostMessage(FViewer.Handle, CM_IpHttpGetRequest, 0, PtrInt(Self)); end; function TIpHtmlFrame.HaveSelection: Boolean; var i : Integer; begin if FHtml = nil then Result := False else if FHtml.HaveSelection then Result := True else begin Result := False; for i := 0 to Pred(FFrameCount) do if FFrames[i].HaveSelection then begin Result := True; break; end; end; end; procedure TIpHtmlFrame.CopyToClipboard; var i : Integer; begin if FHtml <> nil then if FHtml.HaveSelection then FHtml.CopyToClipboard else begin for i := 0 to Pred(FFrameCount) do if FFrames[i].HaveSelection then begin FFrames[i].CopyToClipboard; Exit; end; end; end; procedure TIpHtmlFrame.SelectAll; var i : Integer; begin if FHtml <> nil then begin FHtml.SelectAll; for i := 0 to Pred(FFrameCount) do FFrames[i].SelectAll; end; end; procedure TIpHtmlFrame.DeselectAll; var i : Integer; begin if FHtml <> nil then begin FHtml.DeselectAll; for i := 0 to Pred(FFrameCount) do FFrames[i].DeselectAll; end; end; procedure TIpHtmlFrame.IFrameCreate(Sender: TIpHtml; Parent: TWinControl; Frame: TIpHtmlNodeIFRAME; var Control: TWinControl); var MW, MH, W, H : Integer; Scroll : Boolean; NewFrame : TIpHtmlFrame; begin Control := TPanel.Create(Parent); Pnl[FFrameCount] := TPanel(Control); TPanel(Control).BevelOuter := bvNone; case Frame.Width.LengthType of hlAbsolute : W := Frame.Width.LengthValue; else begin if Frame.Width.LengthType = hlUndefined then W := Parent.ClientWidth else W := round(Frame.Width.LengthValue * Parent.ClientWidth / 100); end; end; case Frame.Height.LengthType of hlAbsolute : H := Frame.Height.LengthValue; else begin if Frame.Height.LengthType = hlUndefined then H := Parent.ClientHeight else H := round(Frame.Height.LengthValue * Parent.ClientHeight / 100); end; end; TPanel(Control).SetBounds(0, 0, W, H); TPanel(Control).Parent := Parent; TPanel(Control).FullRepaint := False; case Frame.Scrolling of hfsAuto, hfsYes : Scroll := True; else Scroll := False; end; if Frame.FrameBorder <> 0 then begin TPanel(Control).BorderStyle := bsSingle; TPanel(Control).BorderWidth := Frame.FrameBorder; end; if Frame.MarginWidth <> -1 then MW := Frame.MarginWidth else MW := FViewer.MarginWidth; if Frame.MarginHeight <> -1 then MH:= Frame.MarginHeight else MH := FViewer.MarginHeight; NewFrame := TIpHtmlFrame.Create(FViewer, TCustomPanel(Control), FDataProvider, FViewer.FlagErrors, not Scroll, MW, MH); FFrames[FFrameCount] := NewFrame; NewFrame.FName := Frame.FName; Application.ProcessMessages; NewFrame.FCurURL := FCurURL; NewFrame.OpenRelativeURL(Frame.Src); Inc(FFrameCount); Frame.FFrame := NewFrame; end; procedure TIpHtmlFrame.SetHtml(NewHtml: TIpHtml); begin InternalFreeFrames; FHtml := NewHtml; InitHtml; FHtml.DoneLoading := True; InternalCreateFrames; end; procedure TIpHtmlFrame.EnumDocuments(Enumerator: TIpHtmlEnumerator); var i : Integer; begin if FHtml <> nil then Enumerator(FHtml); for i := 0 to Pred(FFrameCount) do FFrames[i].EnumDocuments(Enumerator); end; procedure TIpHtmlFrame.ControlClick(Sender: TIpHtml; Node: TIpHtmlNodeControl); begin FViewer.ControlClick(Self, Sender, Node); end; procedure TIpHtmlFrame.ControlClick2(Sender: TIpHtml; Node: TIpHtmlNodeControl; var cancel: boolean); begin FViewer.ControlClick2(Self, Sender, Node, cancel); end; procedure TIpHtmlFrame.ControlOnChange(Sender: TIpHtml; Node: TIpHtmlNodeControl); begin FViewer.ControlOnChange(Self, Sender, Node); end; procedure TIpHtmlFrame.ControlOnEditingDone(Sender: TIpHtml; Node: TIpHtmlNodeControl); begin FViewer.ControlOnEditingdone(Self, Sender, Node); end; procedure TIpHtmlFrame.ControlCreate(Sender: TIpHtml; Node: TIpHtmlNodeControl); begin FViewer.ControlCreate(Self, Sender, Node); end; { Returns false if view rect was not changed } function TIpHtmlFrame.Scroll(Action: TIpScrollAction; ADistance: Integer = 100): Boolean; var R : TRect; H, W : Integer; begin if FHtml = nil then Exit; if HyperPanel = nil then Exit; R := FHtml.FPageViewRect; H := R.Bottom - R.Top; W := R.Right - R.Left; case Action of hsaHome : begin R.Top := 0; R.Bottom := R.Top + H; end; hsaEnd : begin R.Bottom := FHtml.FPageRect.Bottom; R.Top := R.Bottom - H; end; hsaPgUp : begin OffsetRect(R, 0, -H); if R.Top < 0 then begin R.Top := 0; R.Bottom := R.Top + H; end; end; hsaPgDn : begin OffsetRect(R, 0, H); if R.Bottom > FHtml.FPageRect.Bottom then begin R.Bottom := FHtml.FPageRect.Bottom; R.Top := R.Bottom - H; end; end; hsaLeft : begin Result := FHtml.FPageViewRect.Left > 0; OffsetRect(R, -ADistance, 0); if R.Left < 0 then begin R.Left := 0; R.Right := R.Left + W; end; end; hsaRight : begin Result := FHtml.FPageViewRect.Right < FHtml.FPageRect.Right; OffsetRect(R, ADistance, 0); if R.Right > FHtml.FPageRect.Right then begin R.Bottom := FHtml.FPageRect.Right; R.Left := R.Right - W; end; end; hsaUp : begin Result := FHtml.FPageViewRect.Top > 0; OffsetRect(R, 0, -ADistance); if R.Top < 0 then begin R.Top := 0; R.Bottom := R.Top + H; end; end; hsaDown : begin Result := FHtml.FPageViewRect.Bottom < FHtml.FPageRect.Bottom; OffsetRect(R, 0, ADistance); if R.Bottom > FHtml.FPageRect.Bottom then begin R.Bottom := FHtml.FPageRect.Bottom; R.Top := R.Bottom - H; end; end; end; HyperPanel.ScrollInViewRaw(R); end; procedure TIpHtmlFrame.Stop; begin if FDataProvider <> nil then FDataProvider.DoLeave(FHtml); end; function TIpHtmlFrame.getFrame(i: integer): TIpHtmlFrame; begin result := FFrames[i]; end; procedure TIpHtmlFrame.RemoveDataProvider; var i: Integer; begin FDataProvider := nil; for i:=0 to High(FFrames) do if FFrames[i] <> nil then FFrames[i].FDataProvider := nil; end; { TIpHtmlNvFrame } procedure TIpHtmlNvFrame.InitHtml; begin if FScanner.DataProvider <> nil then FHtml.OnGetImageX := FScanner.DataProvider.DoGetImage; FHtml.FlagErrors := FFlagErrors; end; constructor TIpHtmlNvFrame.Create(Scanner: TIpHtmlCustomScanner; DataProvider : TIpAbstractHtmlDataProvider; FlagErrors: Boolean); begin inherited Create; FScanner := Scanner; FDataProvider := DataProvider; FHtml := TIpHtml.Create; FFlagErrors := FlagErrors; InitHtml; end; destructor TIpHtmlNvFrame.Destroy; var i : Integer; begin for i := 0 to Pred(FFrameCount) do FFrames[i].Free; FHtml.Free; inherited; end; procedure TIpHtmlNvFrame.OpenURL(const URL: string); begin OpenRelativeURL(URL); end; procedure TIpHtmlNvFrame.OpenRelativeURL(const {Base, }URL: string); var S : TStream; i, C : Integer; ColWCount : Integer; St, ResourceType : string; CurFrameDef : TIpHtmlNodeFrame; begin if Assigned(FDataProvider) then St := FDataProvider.BuildURL(FCurURL, URL) else St := IpUtils.BuildURL(FCurURL, URL); if FDataProvider = nil then raise EIpHtmlException.Create(SHtmlNoDataProvider); if not FDataProvider.DoCheckURL(St, ResourceType) then raise EIpHtmlException.Create(SHtmlResUnavail + St); if CompareText(ResourceType, 'text/html') <> 0 then Exit; if CompareText(St, FCurURL) = 0 then Exit; FCurURL := St; FCurAnchor := ''; for i := 0 to Pred(FFrameCount) do FFrames[i].Free; FFrameCount := 0; FDataProvider.DoLeave(FHtml); FHtml.Clear; ColWCount := 0; if FDataProvider <> nil then begin S := FDataProvider.DoGetHtmlStream(FCurURL, PostData); if S <> nil then try FHtml.FCurURL := FCurURL; FHtml.LoadFromStream(S); if FHtml.HasFrames then begin C := 0; FFrameCount := 0; for i := 0 to Pred(FHtml.FrameSet.ChildCount) do begin if FHtml.FrameSet.ChildNode[i] is TIpHtmlNodeFrame then begin CurFrameDef := TIpHtmlNodeFrame(FHtml.FrameSet.ChildNode[i]); FFrames[FFrameCount] := TIpHtmlNvFrame.Create(FScanner, FDataProvider, FScanner.FlagErrors); FFrames[FFrameCount].FName := CurFrameDef.Name; if C < ColWCount - 1 then Inc(C) else begin C := 0; end; Inc(FFrameCount); end; end; Application.ProcessMessages; FFrameCount := 0; for i := 0 to Pred(FHtml.FrameSet.ChildCount) do begin if FHtml.FrameSet.ChildNode[i] is TIpHtmlNodeFrame then begin FFrames[FFrameCount].FCurURL := FCurURL; FFrames[FFrameCount].OpenRelativeURL({Base,} TIpHtmlNodeFrame(FHtml.FrameSet.ChildNode[i]).Src); Inc(FFrameCount); end; end; end; finally S.Free; end; end; end; procedure TIpHtmlNvFrame.MakeAnchorVisible(const URL: string); var E : TIpHtmlNode; i : Integer; begin E := FHtml.FindElement(URL); if E = nil then E := FHtml.FindElementID(URL); FCurAnchor := ''; if E <> nil then begin E.MakeVisible; FCurAnchor := '#'+URL; end else for i := 0 to Pred(FFrameCount) do FFrames[i].MakeAnchorVisible(URL); end; procedure TIpHtmlNvFrame.Home; begin if FHtml <> nil then FHtml.Home; end; function TIpHtmlNvFrame.FindFrame(const FrameName: string): TIpHtmlNvFrame; var i : Integer; begin if AnsiCompareText(FrameName, FName) = 0 then Result := Self else begin Result := nil; for i := 0 to Pred(FFrameCount) do begin Result := FFrames[i].FindFrame(FrameName); if Result <> nil then Exit; end; end; end; function TIpHtmlNvFrame.HaveSelection: Boolean; var i : Integer; begin if FHtml = nil then Result := False else if FHtml.HaveSelection then Result := True else begin Result := False; for i := 0 to Pred(FFrameCount) do if FFrames[i].HaveSelection then begin Result := True; break; end; end; end; procedure TIpHtmlNvFrame.CopyToClipboard; var i : Integer; begin if FHtml <> nil then if FHtml.HaveSelection then FHtml.CopyToClipboard else begin for i := 0 to Pred(FFrameCount) do if FFrames[i].HaveSelection then begin FFrames[i].CopyToClipboard; Exit; end; end; end; procedure TIpHtmlNvFrame.SelectAll; var i : Integer; begin if FHtml <> nil then begin FHtml.SelectAll; for i := 0 to Pred(FFrameCount) do FFrames[i].SelectAll; end; end; procedure TIpHtmlNvFrame.EnumDocuments(Enumerator: TIpHtmlEnumerator); var i : Integer; begin if FHtml <> nil then Enumerator(FHtml); for i := 0 to Pred(FFrameCount) do FFrames[i].EnumDocuments(Enumerator); end; procedure TIpHtmlNVFrame.Stop; begin if FDataProvider <> nil then FDataProvider.DoLeave(FHtml); end; function TIpHtmlNVFrame.getFrame(i: integer): TIpHtmlNVFrame; begin result := FFrames[i]; end; { TIpHtmlCustomPanel } procedure TIpHtmlCustomPanel.DoHotChange; begin if Assigned(FHotChange) then FHotChange(Self); end; procedure TIpHtmlCustomPanel.DoHotClick; begin if Assigned(FHotClick) then FHotClick(Self); end; procedure TIpHtmlCustomPanel.DoOnMouseWheel(Shift: TShiftState; Delta, XPos, YPos: SmallInt); var I: Integer; begin if Delta < 0 then begin for I := 1 to WheelDelta do Scroll(hsaDown); end else if Delta > 0 then begin for I := 1 To WheelDelta do Scroll(hsaUp); end; end; procedure TIpHtmlCustomPanel.HotChange(Sender: TObject); var P : TIpHtmlInternalPanel; vHtml : TIpHtml; begin P := TIpHtmlInternalPanel(Sender); vHtml := P.Hyper; if vHtml.HotNode <> nil then begin if vHtml.HotPoint.x >= 0 then FHotURL := TIpHtmlNodeA(vHtml.HotNode).HRef+ '?'+IntToStr(vHtml.HotPoint.x)+','+IntToStr(vHtml.HotPoint.y) else if vHtml.HotNode is TIpHtmlNodeA then FHotURL := TIpHtmlNodeA(vHtml.HotNode).HRef else FHotURL := TIpHtmlNodeAREA(vHtml.HotNode).HRef; FHotNode := vHtml.HotNode; P.Cursor := crHandPoint; end else begin FHotNode := nil; FHotURL := ''; P.Cursor := crDefault; end; DoHotChange; end; procedure TIpHtmlCustomPanel.CurElementChange(Sender: TObject); var P : TIpHtmlInternalPanel; vHtml : TIpHtml; begin P := TIpHtmlInternalPanel(Sender); vHtml := P.Hyper; FCurElement := vHtml.CurElement; if assigned(FCurElementChange) then FCurElementChange(Self); end; function TIpHtmlCustomPanel.GetTitle: string; begin if (FMasterFrame <> nil) and (FMasterFrame.FHtml <> nil) and (FMasterFrame.FHtml.TitleNode <> nil) then Result := FMasterFrame.FHtml.TitleNode.Title else Result := ''; end; constructor TIpHtmlCustomPanel.Create(AOwner: TComponent); begin inherited; BevelOuter := bvNone; Caption := ''; ControlStyle := [csCaptureMouse, csClickEvents, csSetCaption, csOpaque, csDoubleClicks, csReplicatable]; TargetStack := TStringList.Create; URLStack := TStringList.Create; VisitedList := TStringMap.Create(False); FLinksUnderlined := DEFAULT_LINKS_UNDERLINED; FTextColor := clBlack; FLinkColor := clBlue; FVLinkColor := clMaroon; FALinkColor := clRed; FBgColor := clWhite; FShowHints := True; FMarginWidth := 10; FMarginHeight := 10; FAllowTextSelect := True; {$IFDEF MSWINDOWS} FixedTypeface := 'Courier New'; {$ELSE} FixedTypeFace := 'Courier'; {$ENDIF} DefaultTypeFace := Graphics.DefFontData.Name; DefaultFontSize := 12; FFontQuality := fqDefault; FPrintSettings := TIpHtmlPrintSettings.Create; FFactBAParag := 1; FWantTabs := True; FScrollDist := 100; FUsePaintBuffer := true; end; destructor TIpHtmlCustomPanel.Destroy; begin FPrintSettings.Free; TargetStack.Free; URLStack.Free; FMasterFrame.Free; FMasterFrame := nil; VisitedList.Free; inherited; end; procedure TIpHtmlCustomPanel.EraseBackground(DC: HDC); begin // end; procedure TIpHtmlCustomPanel.OpenURL(const URL: string); begin InternalOpenURL('', URL); end; procedure TIpHtmlCustomPanel.MakeAnchorVisible(const Name: string); begin if FMasterFrame <> nil then FMasterFrame.MakeAnchorVisible(Name) end; procedure TIpHtmlCustomPanel.InternalOpenURL(const Target, HRef : string); var URL, BaseURL, RelURL : string; P : Integer; TargetFrame : TIpHtmlFrame; begin if HRef = '' then Exit; if HRef[1] = '#' then begin RelURL := copy(HRef, 2, length(HRef) - 1); BaseURL := ''; end else begin if FMasterFrame <> nil then begin if Assigned(FDataProvider) then URL := FDataProvider.BuildURL(FMasterFrame.FHtml.FCurURL, HRef) else URL := IpUtils.BuildURL(FMasterFrame.FHtml.FCurURL, HRef); end else URL := HRef; P := CharPos('#', URL); if P = 0 then begin RelURL := ''; BaseURL := URL; end else begin BaseURL := copy(URL, 1, P - 1); RelURL := copy(URL, P + 1, length(URL)); end; end; if BaseURL = '' then begin if FMasterFrame <> nil then Push('', RelURL); end else begin if not VisitedList.Contains(BaseURL) then VisitedList.Add(BaseURL); if (Target <> '') and (FMasterFrame <> nil) then TargetFrame := FMasterFrame.FindFrame(Target) else TargetFrame := nil; if TargetFrame = nil then begin if FMasterFrame <> nil then Push('', FMasterFrame.FCurURL + FMasterFrame.FCurAnchor); if DataProvider = nil then raise EIpHtmlException.Create(SHtmlNoDataProvider); if (FMasterFrame = nil) or ((FMasterFrame <> nil) and (not FMasterFrame.IsExternal(URL))) then begin if (FMasterFrame <> nil) and (FMasterFrame.FHtml <> nil) then FDataProvider.DoLeave(FMasterFrame.FHtml); FMasterFrame.Free; FMasterFrame := nil; Application.ProcessMessages; FMasterFrame := TIpHtmlFrame.Create(Self, Self, DataProvider, FlagErrors, False, MarginWidth, MarginHeight); FMasterFrame.OpenURL(URL, False); end; end else begin Push(Target, TargetFrame.FCurURL + TargetFrame.FCurAnchor); TargetFrame.OpenURL(BaseURL, False); end; end; if RelURL <> '' then FMasterFrame.MakeAnchorVisible(RelURL) else if FMasterFrame <> nil then FMasterFrame.Home; if assigned(FDocumentOpen) then FDocumentOpen(Self); end; procedure TIpHtmlCustomPanel.HotClick(Sender: TObject); var HRef : string; Target : string; begin if TIpHtml(Sender).HotNode is TIpHtmlNodeA then begin HRef := TIpHtmlNodeA(TIpHtml(Sender).HotNode).HRef; Target := TIpHtmlNodeA(TIpHtml(Sender).HotNode).Target; end else begin HRef := TIpHtmlNodeAREA(TIpHtml(Sender).HotNode).HRef; Target := TIpHtmlNodeAREA(TIpHtml(Sender).HotNode).Target; end; if (FDataProvider <> nil) and FDataProvider.CanHandle(HRef) then InternalOpenURL(Target, HRef) else DoHotClick; end; procedure TIpHtmlCustomPanel.GoBack; begin if (URLStack.Count > 0) then begin if URLStack.Count >= URLStack.count then Stp := URLStack.Count - 1; if URLStack.Count > 0 then begin InternalOpenURL(TargetStack[Stp], URLStack[Stp]); Dec(Stp); end; end; end; function TIpHtmlCustomPanel.canGoBack : boolean; begin Result := (URLStack.Count > 0); end; procedure TIpHtmlCustomPanel.GoForward; begin if Stp < URLStack.Count - 1 then begin InternalOpenURL(TargetStack[Stp + 1], URLStack[Stp + 1]); Inc(Stp); end; end; function TIpHtmlCustomPanel.canGoForward : boolean; begin Result := (Stp < URLStack.Count - 1); end; procedure TIpHtmlCustomPanel.Push(const Target, URL: string); begin if (Stp > 0) and (TargetStack[Stp] = Target) and (URLStack[Stp] = URL) then Exit; while STP < URLStack.Count - 1 do begin URLStack.Delete(Stp); TargetStack.Delete(Stp); end; URLStack.Add(URL); TargetStack.Add(Target); Stp := URLStack.Count - 1; end; procedure TIpHtmlCustomPanel.Notification(AComponent: TComponent; Operation: TOperation); begin //debugln(['TIpHtmlCustomPanel.Notification ',DbgSName(Self),' ',dbgs(Pointer(Self)),' AComponent=',DbgSName(AComponent),' ',dbgs(Pointer(AComponent))]); if (Operation = opRemove) then if (AComponent = DataProvider) then begin DataProvider := nil; if Assigned(FMasterFrame) then FMasterFrame.RemoveDataProvider; end; inherited Notification(AComponent, Operation); end; procedure TIpHtmlCustomPanel.Paint; var Sz: TSize; begin if csDesigning in ComponentState then begin Canvas.Brush.Color := clBtnFace; Canvas.FillRect(Canvas.ClipRect); Canvas.Pen.Color := clWhite; Sz := Canvas.TextExtent('Html'); Canvas.Polygon([ Point(0,4), Point(0, Height - 5), Point(Width div 2 - Sz.cx div 2, Height div 2)]); Canvas.Polygon([ Point(Width - 1,4), Point(Width - 1, Height - 5), Point(Width div 2 + Sz.cx div 2, Height div 2)]); Canvas.Polygon([ Point(2, 4), Point(Width - 3, 4), Point(Width div 2, Height div 2 - Sz.cy div 2)]); Canvas.Polygon([ Point(2, Height - 4), Point(Width - 3, Height - 4), Point(Width div 2, Height div 2 + Sz.cy div 2)]); Canvas.Brush.Color := clRed; Canvas.Pen.Color := clBlack; Canvas.Ellipse( Width div 2 - Sz.cx, Height div 2 - Sz.cy, Width div 2 + Sz.cx, Height div 2 + Sz.cy); Canvas.TextOut(Width div 2 - Sz.cx div 2, Height div 2 - Sz.cy div 2, 'Html'); Canvas.Brush.Color := clWhite; Canvas.Pen.Color := clBlack; end; end; procedure TIpHtmlCustomPanel.WMEraseBkgnd(var Message: TWmEraseBkgnd); begin if (FMasterFrame = nil) or (FMasterFrame.FHtml = nil) or (not FMasterFrame.FHtml.CanPaint) then if not (csDesigning in ComponentState) then FillRect(Message.DC, ClientRect, Brush.Reference.Handle); Message.Result := 1; end; procedure TIpHtmlCustomPanel.CMIpHttpGetRequest(var Message: TMessage); var FB : TIpHtmlFrame; begin FB := TIpHtmlFrame(Message.lParam); if PostData <> nil then begin FB.PostData := PostData; FB.OpenRelativeURL(PostURL); {$IFNDEF HtmlWithoutHttp} PostData.Free; PostData := nil; {$ENDIF} end else FB.OpenRelativeURL(GetURL); if assigned(FDocumentOpen) then FDocumentOpen(Self); end; procedure TIpHtmlCustomPanel.ClientClick(Sender: TObject); begin Click; end; function TIpHtmlCustomPanel.HaveSelection: Boolean; begin Result := (FMasterFrame <> nil) and (FMasterFrame.HaveSelection); end; procedure TIpHtmlCustomPanel.SelectAll; begin if FMasterFrame <> nil then begin FMasterFrame.SelectAll; Invalidate; end; end; procedure TIpHtmlCustomPanel.DeselectAll; begin if FMasterFrame <> nil then begin FMasterFrame.DeselectAll; Invalidate; end; end; procedure TIpHtmlCustomPanel.CopyToClipboard; begin if FMasterFrame <> nil then FMasterFrame.CopyToClipboard; end; procedure TIpHtmlCustomPanel.SetHtml(NewHtml: TIpHtml); begin if (FMasterFrame <> nil) and (FMasterFrame.FHtml <> nil) and (FDataProvider <> nil) then FDataProvider.DoLeave(FMasterFrame.FHtml); FMasterFrame.Free; FMasterFrame := nil; FMasterFrame := TIpHtmlFrame.Create(Self, Self, DataProvider, FlagErrors, False, MarginWidth, MarginHeight); if NewHtml <> nil then begin NewHtml.FactBAParag := FactBAParag; NewHtml.BgColor := BgColor; NewHtml.FixedTypeface := FixedTypeface; NewHtml.DefaultTypeFace := DefaultTypeFace; NewHtml.DefaultFontSize := FDefaultFontSize; NewHtml.LinksUnderlined := FLinksUnderlined; FMasterFrame.SetHtml(NewHtml); end; end; procedure TIpHtmlCustomPanel.SetHtmlFromFile(const AFileName: String); var strm: TFileStream; begin strm := TFileStream.Create(AFileName, fmOpenRead + fmShareDenyNone); try SetHtmlFromStream(strm); finally strm.Free; end; end; procedure TIpHtmlCustomPanel.SetHtmlFromStr(NewHtml: string); var strm: TStringStream; begin strm:= TStringStream.Create(NewHtml); try SetHtmlFromStream(strm); finally strm.Free; end; end; procedure TIpHtmlCustomPanel.SetHtmlFromStream(NewHtml: TStream); var iphtml: TIpHtml; begin iphtml:= TIpHtml.Create; iphtml.LoadFromStream(NewHtml); SetHtml(iphtml); end; procedure TIpHtmlCustomPanel.URLCheck(Sender: TIpHtml; const URL: string; var Visited: Boolean); begin Visited := VisitedList.Contains(URL); end; procedure TIpHtmlCustomPanel.ReportURL(Sender: TIpHtml; const URL: string); begin if (FDataProvider <> nil) then FDataProvider.DoReference(URL); end; procedure TIpHtmlCustomPanel.EnumDocuments(Enumerator: TIpHtmlEnumerator); begin if FMasterFrame <> nil then FMasterFrame.EnumDocuments(Enumerator); end; procedure TIpHtmlCustomPanel.ControlClick(pFrame: TIpHtmlFrame; pHtml: TIpHtml; pNode: TIpHtmlNodeControl); begin if assigned(FControlClick) then FControlClick(Self, pFrame, pHtml, pNode); end; procedure TIpHtmlCustomPanel.ControlClick2(pFrame: TIpHtmlFrame; pHtml: TIpHtml; pNode: TIpHtmlNodeControl; var pCancel: boolean); begin if assigned(FControlClick2) then FControlClick2(Self, pFrame, pHtml, pNode, pCancel); end; procedure TIpHtmlCustomPanel.ControlOnChange(pFrame: TIpHtmlFrame; pHtml: TIpHtml; pNode: TIpHtmlNodeControl); begin if assigned(FControlOnChange) then FControlOnChange(Self, pFrame, pHtml, pNode); end; procedure TIpHtmlCustomPanel.ControlOnEditingDone(pFrame: TIpHtmlFrame; pHtml: TIpHtml; pNode: TIpHtmlNodeControl); begin if assigned(FControlOnEditingDone) then FControlOnEditingDone(Self, pFrame, pHtml, pNode); end; procedure TIpHtmlCustomPanel.ControlCreate(pFrame: TIpHtmlFrame; pHtml: TIpHtml; pNode: TIpHtmlNodeControl); begin if assigned(FControlCreate) then FControlCreate(Self, pFrame, pHtml, pNode); end; function TIpHtmlCustomPanel.IsURLHtml(const URL: string): Boolean; var ResourceType: string; begin Result := (FDataProvider <> nil) and FDataProvider.DoCheckURL(URL, ResourceType) and (CompareText(ResourceType, 'text/html') = 0); end; procedure TIpHtmlCustomPanel.Stop; begin if assigned(FMasterFrame) then FMasterFrame.Stop; end; {$IFDEF Html_Print} function TIpHtmlCustomPanel.GetPrintPageCount: Integer; begin if Assigned(FMasterFrame) and Assigned(FMasterFrame.HyperPanel) then Result := FMasterFrame.HyperPanel.GetPrintPageCount else Result := 0; end; procedure TIpHtmlCustomPanel.Print(FromPg, ToPg: LongInt); begin if Assigned(FMasterFrame) then FMasterFrame.HyperPanel.PrintPages(FromPg, ToPg); end; procedure TIpHtmlCustomPanel.PrintPreview; begin if not assigned(printer) then begin raise exception.create( 'Printer has not been assigned, checkout that package'#13+ 'Printer4lazarus.lpk has been installed and OSPrinters'#13+ 'or PrintDialog is in uses clause of main unit'); end; if Assigned(FMasterFrame) then FMasterFrame.HyperPanel.PrintPreview; end; {$ENDIF} function TIpHtmlCustomPanel.GetContentSize: TSize; begin if FMasterFrame <> nil then begin with FMasterFrame.FHtml.FPageRect do begin Result.cx := Right - Left; Result.cy := Bottom - Top; end; end else Result := Size(0, 0); end; function TIpHtmlCustomPanel.Scroll(Action: TIpScrollAction; ADistance: Integer = 100): Boolean; begin if FMasterFrame <> nil then Result := FMasterFrame.Scroll(Action, ADistance); end; procedure TIpHtmlCustomPanel.WMGetDlgCode(var Msg: TMessage); begin { we want 'em all! For Lazarus: Then use OnKeyDown! } Msg.Result := DLGC_WANTALLKEYS + DLGC_WANTARROWS + DLGC_WANTCHARS + DLGC_WANTTAB end; function TIpHtmlCustomPanel.GetVersion : string; begin Result := IpShortVersion; end; function TIpHtmlCustomPanel.GetCurUrl: string; begin Result := FMasterFrame.FCurURL; end; procedure TIpHtmlCustomPanel.SetVersion(const Value : string); begin { Intentionally empty } end; procedure TIpHtmlCustomPanel.SetDefaultTypeFace(const Value: string); begin if FDefaultTypeFace<>Value then begin FDefaultTypeFace := Value; if (FMasterFrame<>nil)and(FMasterFrame.FHtml<>nil) then begin FMasterFrame.FHtml.DefaultTypeFace := FDefaultTypeFace; Invalidate; end; end; end; procedure TIpHtmlCustomPanel.SetDefaultFontSize(const Value: integer); begin if FDefaultFontSize<>Value then begin FDefaultFontSize := Value; if (FMasterFrame<>nil)and(FMasterFrame.FHtml<>nil) then begin FMasterFrame.FHtml.DefaultFontSize := FDefaultFontSize; Invalidate; end; end; end; procedure TIpHtmlCustomPanel.SetFontQuality(const AValue: TFontQuality); begin if FFontQuality <> AValue then begin FFontQuality := AValue; if (FMasterFrame <> nil) and (FMasterFrame.FHtml <> nil) then begin FMasterFrame.FHtml.FontQuality := FFontQuality; Invalidate; end; end; end; procedure TIpHtmlCustomPanel.CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean); var r: TRect; begin //debugln(['TIpHtmlCustomPanel.CalculatePreferredSize ',DbgSName(Self)]); r:=Rect(0,0,0,0); if (FMasterFrame<>nil) and (FMasterFrame.HyperPanel<>nil) and (FMasterFrame.HyperPanel.Hyper<>nil) then r:=FMasterFrame.HyperPanel.Hyper.GetPageRect(Canvas, 0, 0); inherited CalculatePreferredSize(PreferredWidth, PreferredHeight, WithThemeSpace); if PreferredWidth 2 then V := 2 else if V < 0 then V := 0; FFactBAParag := V; end; procedure TIpHtmlCustomPanel.SetDataProvider(const AValue: TIpAbstractHtmlDataProvider); begin if FDataProvider=AValue then exit; //debugln(['TIpHtmlCustomPanel.SetDataProvider Old=',DbgSName(FDataProvider),' ',dbgs(Pointer(FDataProvider)),' New=',DbgSName(AValue),' ',dbgs(Pointer(AValue))]); FDataProvider:=AValue; if FDataProvider<>nil then FDataProvider.FreeNotification(Self); end; function TIpHtmlCustomPanel.FactBAParagNotIs1: Boolean; begin Result := FactBAParag <> 1; end; function TIpHtmlCustomPanel.GetVScrollPos: Integer; begin if FMasterFrame <> nil then Result := FMasterFrame.HyperPanel.VScroll.Position else Result := -1; end; procedure TIpHtmlCustomPanel.SetVScrollPos(const Value: Integer); begin if (FMasterFrame <> nil) and (Value >= 0) then FMasterFrame.HyperPanel.VScroll.Position := Value; end; { TIpHtmlCustomScanner } function TIpHtmlCustomScanner.GetTitle: string; begin if (FMasterFrame <> nil) and (FMasterFrame.FHtml <> nil) and (FMasterFrame.FHtml.TitleNode <> nil) then Result := FMasterFrame.FHtml.TitleNode.Title else Result := ''; end; constructor TIpHtmlCustomScanner.Create(AOwner: TComponent); begin inherited; TargetStack := TStringList.Create; URLStack := TStringList.Create; end; destructor TIpHtmlCustomScanner.Destroy; begin TargetStack.Free; URLStack.Free; FMasterFrame.Free; FMasterFrame := nil; inherited; end; procedure TIpHtmlCustomScanner.OpenURL(const URL: string); begin InternalOpenURL('', URL); end; procedure TIpHtmlCustomScanner.InternalOpenURL(const Target, HRef : string); var URL, BaseURL, RelURL : string; P : Integer; TargetFrame : TIpHtmlNvFrame; begin if HRef = '' then Exit; if HRef[1] = '#' then begin RelURL := copy(HRef, 2, length(HRef) - 1); BaseURL := ''; end else begin if FMasterFrame <> nil then begin if Assigned(FDataProvider) then URL := FDataProvider.BuildURL(FMasterFrame.FHtml.FCurURL, HRef) else URL := IpUtils.BuildURL(FMasterFrame.FHtml.FCurURL, HRef); end else URL := HRef; P := CharPos('#', URL); if P = 0 then begin RelURL := ''; BaseURL := URL; end else begin BaseURL := copy(URL, 1, P - 1); RelURL := copy(URL, P + 1, length(URL)); end; end; if BaseURL <> '' then begin if (Target <> '') and (FMasterFrame <> nil) then TargetFrame := FMasterFrame.FindFrame(Target) else TargetFrame := nil; if TargetFrame = nil then begin if FMasterFrame <> nil then Push('', FMasterFrame.FCurURL + FMasterFrame.FCurAnchor); if DataProvider = nil then raise EIpHtmlException.Create(SHtmlNoDataProvider); if (FMasterFrame <> nil) and (FMasterFrame.FHtml <> nil) then FDataProvider.DoLeave(FMasterFrame.FHtml); FMasterFrame.Free; FMasterFrame := nil; Application.ProcessMessages; FMasterFrame := TIpHtmlNVFrame.Create(Self, DataProvider, FlagErrors); FMasterFrame.OpenURL(URL); FCurURL := URL; end else begin Push(Target, TargetFrame.FCurURL + TargetFrame.FCurAnchor); TargetFrame.OpenURL(BaseURL); end; end; if RelURL <> '' then FMasterFrame.MakeAnchorVisible(RelURL) else FMasterFrame.Home; end; procedure TIpHtmlCustomScanner.Push(const Target, URL: string); begin if (Stp > 0) and (TargetStack[Stp] = Target) and (URLStack[Stp] = URL) then Exit; while STP < URLStack.Count - 1 do begin URLStack.Delete(Stp); TargetStack.Delete(Stp); end; URLStack.Add(URL); TargetStack.Add(Target); Stp := URLStack.Count - 1; end; procedure TIpHtmlCustomScanner.EnumDocuments(Enumerator: TIpHtmlEnumerator); begin if FMasterFrame <> nil then FMasterFrame.EnumDocuments(Enumerator); end; function TIpHtmlCustomScanner.IsURLHtml(const URL: string): Boolean; var ResourceType: string; begin Result := (FDataProvider <> nil) and FDataProvider.DoCheckURL(URL, ResourceType) and (CompareText(ResourceType, 'text/html') = 0); end; procedure TIpHtmlCustomScanner.Stop; begin if assigned(FMasterFrame) then FMasterFrame.Stop; end; function TIpHtmlCustomScanner.GetVersion : string; begin Result := IpShortVersion; end; procedure TIpHtmlCustomScanner.SetVersion(const Value : string); begin { Intentionally empty } end; function LazFlatSB_GetScrollInfo(hWnd: HWND; BarFlag: Integer; var ScrollInfo: TScrollInfo): BOOL; stdcall; begin Result:=LCLIntf.GetScrollInfo(HWnd,BarFlag,ScrollInfo); end; function LazFlatSB_GetScrollPos(hWnd: HWND; nBar: Integer): Integer; stdcall; begin Result:=LCLIntf.GetScrollPos(HWnd,nBar); end; function LazFlatSB_SetScrollPos(hWnd: HWND; nBar, nPos: Integer; bRedraw: BOOL): Integer; stdcall; begin Result:=LCLIntf.SetScrollPos(HWnd,nBar,nPos,bRedraw); end; function LazFlatSB_SetScrollProp(p1: HWND; index: Integer; newValue: Integer; p4: Bool): Bool; stdcall; begin // ToDo Result:=true; end; function LazFlatSB_SetScrollInfo(hWnd: HWND; BarFlag: Integer; const ScrollInfo: TScrollInfo; Redraw: BOOL): Integer; stdcall; begin Result:=LCLIntf.SetScrollInfo(HWnd,BarFlag,ScrollInfo,Redraw); end; procedure InitScrollProcs; begin @FlatSB_GetScrollInfo := @LazFlatSB_GetScrollInfo; @FlatSB_GetScrollPos := @LazFlatSB_GetScrollPos; @FlatSB_SetScrollPos := @LazFlatSB_SetScrollPos; @FlatSB_SetScrollProp := @LazFlatSB_SetScrollProp; @FlatSB_SetScrollInfo := @LazFlatSB_SetScrollInfo; end; procedure Register; begin RegisterComponents('IPro', [TIpHtmlPanel]); end; initialization InitScrollProcs; end.