{Version 9.45} {*********************************************************} {* HTMLVIEW.PAS *} {*********************************************************} { Copyright (c) 1995-2008 by L. David Baldwin Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. Note that the source modules, HTMLGIF1.PAS, PNGZLIB1.PAS, DITHERUNIT.PAS, and URLCON.PAS are covered by separate copyright notices located in those modules. } {$i htmlcons.inc} unit Htmlview; interface uses SysUtils, Classes, {$IFNDEF LCL} WinTypes, WinProcs, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, FPimage, HtmlMisc, {$ENDIF} Graphics, Controls, StdCtrls, {$IFNDEF LCL} vwPrint, MetafilePrinter, mmSystem, {$ENDIF} HTMLUn2, Forms, Dialogs, ExtCtrls, ReadHTML, HTMLSubs, StyleUn, Printers, Menus, GDIPL2A; const wm_FormSubmit = wm_User+100; wm_MouseScroll = wm_User+102; wm_UrlAction = wm_User+103; type THTMLViewer = class; THTMLBorderStyle = (htFocused, htNone, htSingle); TRightClickParameters = Class(TObject) URL, Target: string; Image: TImageObj; ImageX, ImageY: integer; ClickWord: WideString; end; TRightClickEvent = procedure(Sender: TObject; Parameters: TRightClickParameters) of Object; THotSpotEvent = procedure(Sender: TObject; const SRC: string) of Object; THotSpotClickEvent = procedure(Sender: TObject; const SRC: string; var Handled: boolean) of Object; TProcessingEvent = procedure(Sender: TObject; ProcessingOn: boolean) of Object; TPagePrinted = procedure( Sender: TObject; Canvas : TCanvas ; NumPage, W, H: Integer ; var StopPrinting : Boolean) of Object; ThtmlPagePrinted = procedure(Sender: TObject; HFViewer: ThtmlViewer; NumPage: Integer; LastPage: boolean; var XL, XR: integer; var StopPrinting: Boolean) of Object; TImageClickEvent = procedure(Sender, Obj: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) of Object; TImageOverEvent = procedure(Sender, Obj: TObject; Shift: TShiftState; X, Y: Integer) of Object; TMetaRefreshType = procedure(Sender: TObject; Delay: integer; const URL: string) of Object; TParseEvent = procedure(Sender: TObject; var Source: string) of Object; htOptionEnum = (htOverLinksActive,htNoLinkUnderline,htPrintTableBackground, htPrintBackground, htPrintMonochromeBlack, htShowDummyCaret, htShowVScroll, htNoWheelMouse, htNoLinkHilite); ThtmlViewerOptions = set of htOptionEnum; ThtProgressEvent = procedure(Sender: TObject; Stage: TProgressStage; PercentDone: integer) of Object; TPaintPanel = class(TCustomPanel) private FOnPaint: TNotifyEvent; FViewer: ThtmlViewer; Canvas2: TCanvas; procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_EraseBkgnd; procedure WMLButtonDblClk(var Message: TWMMouse); message WM_LButtonDblClk; procedure DoBackground(ACanvas: TCanvas); constructor CreateIt(AOwner: TComponent; Viewer: ThtmlViewer); property OnPaint: TNotifyEvent read FOnPaint write FOnPaint; public procedure Paint; override; end; {$IFNDEF LCL} T32ScrollBar = Class(TScrollBar) {a 32 bit scrollbar} private FPosition: integer; FMin, FMax, FPage: integer; procedure SetPosition(Value: integer); procedure SetMin(Value: Integer); procedure SetMax(Value: Integer); procedure CNVScroll(var Message: TWMVScroll); message CN_VSCROLL; public property Position: integer read FPosition write SetPosition; property Min: integer read FMin write SetMin; property Max: integer read FMax write SetMax; procedure SetParams(APosition, APage, AMin, AMax: Integer); end; {$ELSE} T32ScrollBar = class(TScrollBar) private procedure DoOnScroll(sender : TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); end; {$ENDIF} ThtmlFileType = (HTMLType, TextType, ImgType, OtherType); {$IFDEF LCL} //From MetaFilePrinter.pas TPageEvent = procedure( Sender: TObject; NumPage: Integer ; var StopPrinting : Boolean) of Object; {$ENDIF} {$IFNDEF LCL} THTMLViewer = class(TWinControl) {$ELSE} THTMLViewer = class(TCustomControl) {$ENDIF} private {$IFNDEF LCL} vwP, OldPrinter: TvwPrinter; {$ELSE} vwP: TPrinter; {$ENDIF} fScaleX, fScaleY: single; FCodePage: integer; function GetCursor: TCursor; procedure SetCursor(Value: TCursor); protected InCreate: boolean; FOnDragDrop: TDragDropEvent; FOnDragOver: TDragOverEvent; DontDraw: boolean; FTitle: String; FURL: String; FTarget: String; FBase, FBaseEx: String; FBaseTarget: String; FCurrentFile: String; FNameList: TStringList; FCurrentFileType: ThtmlFileType; FOnHotSpotCovered: THotSpotEvent; FOnHotSpotClick: THotSpotClickEvent; FOnBitmapRequest: TGetBitmapEvent; FOnImageRequest: TGetImageEvent; FOnScript: TScriptEvent; FOnFormSubmit: TFormSubmitEvent; FOnHistoryChange: TNotifyEvent; FOnProcessing: TProcessingEvent; FOnInclude: TIncludeType; FOnSoundRequest: TSoundType; FOnLink: TLinkType; FOnMeta: TMetaType; FOnMetaRefresh: TMetaRefreshType; FOnPanelCreate: TPanelCreateEvent; FOnPanelDestroy: TPanelDestroyEvent; FOnPanelPrint: TPanelPrintEvent; FRefreshURL: string; FRefreshDelay: Integer; FOnRightClick: TRightClickEvent; FOnImageClick: TImageClickEvent; FOnImageOver: TImageOverEvent; FOnObjectClick: TObjectClickEvent; FOnFileBrowse: TFileBrowseEvent; FOnObjectFocus: ThtObjectEvent; FOnObjectBlur: ThtObjectEvent; FOnObjectChange: ThtObjectEvent; FOnProgress: ThtProgressEvent; FHistory, FTitleHistory: TStrings; FPositionHistory: TFreeList; FHistoryIndex: integer; FHistoryMaxCount: integer; FFontName: TFontName; FPreFontName: String; FFontColor: TColor; FHotSpotColor, FVisitedColor, FOverColor: TColor; FVisitedMaxCount: integer; FBackGround: TColor; FFontSize: integer; FProcessing: boolean; FAction, FFormTarget, FEncType, FMethod: String; FStringList: TStringList; FImageCacheCount: integer; FNoSelect: boolean; FScrollBars: TScrollStyle; FBorderStyle: THTMLBorderStyle; FDither: boolean; FCaretPos: integer; FOptions: ThtmlViewerOptions; sbWidth: integer; ScrollWidth: integer; FMaxVertical: integer; MouseScrolling: boolean; LeftButtonDown: boolean; MiddleScrollOn: boolean; MiddleY: integer; Hiliting: boolean; FPrintMarginLeft, FPrintMarginRight, FPrintMarginTop, FPrintMarginBottom: double; FCharset: TFontCharset; {see htmlun2.pas for Delphi 2 TFontCharSet definition} FOnPrintHeader, FOnPrintFooter: TPagePrinted; FOnPrintHTMLHeader, FOnPrintHTMLFooter: ThtmlPagePrinted; FPage: integer; FOnPageEvent: TPageEvent; FOnMouseDouble: TMouseEvent; HotSpotAction: boolean; FMarginHeight, FMarginWidth: integer; FServerRoot: string; FSectionList: TSectionList; FImageStream: TMemoryStream; FOnExpandName: TExpandNameEvent; HTMLTimer: TTimer; FOnhtStreamRequest: TGetStreamEvent; LocalBitmapList: boolean; FDocumentSource: string; FOnParseBegin: TParseEvent; FOnParseEnd: TNotifyEvent; FTitleAttr: string; BGFixed: boolean; FPrintScale: double; NoJump: boolean; FOnLinkDrawn: TLinkDrawnEvent; FLinkAttributes: TStringList; FLinkText: WideString; FLinkStart: TPoint; FWidthRatio: double; FOnObjectTag: TObjectTagEvent; function CreateHeaderFooter: ThtmlViewer; procedure WMSize(var Message: TWMSize); message WM_SIZE; procedure ScrollTo(Y: integer); procedure Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); procedure Layout; procedure SetViewImages(Value: boolean); function GetViewImages: boolean; procedure SetColor(Value: TColor); function GetBase: string; procedure SetBase(Value: string); function GetBaseTarget: string; function GetTitle: string; function GetCurrentFile: string; procedure SetBorderStyle(Value: THTMLBorderStyle); function GetPosition: integer; procedure SetPosition(Value: integer); function GetScrollPos: integer; procedure SetScrollPos(Value: integer); function GetScrollBarRange: integer; function GetHScrollPos: integer; procedure SetHScrollPos(Value: integer); function GetHScrollBarRange: integer; procedure SetHistoryIndex(Value: integer); function GetPreFontName: TFontName; procedure SetPreFontName(Value: TFontName); procedure SetFontSize(Value: integer); procedure SetHotSpotColor(Value: TColor); procedure SetActiveColor(Value: TColor); procedure SetVisitedColor(Value: TColor); procedure SetVisitedMaxCount(Value: integer); procedure SetOnBitmapRequest(Handler: TGetBitmapEvent); procedure SetOnImageRequest(Handler: TGetImageEvent); procedure SetOnScript(Handler: TScriptEvent); procedure SetOnFormSubmit(Handler: TFormSubmitEvent); function GetOurPalette: HPalette; procedure SetOurPalette(Value: HPalette); procedure SetDither(Value: boolean); procedure SetCaretPos(Value: integer); procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE; procedure BackgroundChange(Sender: TObject); procedure SubmitForm(Sender: TObject; const Action, Target, EncType, Method: string; Results: TStringList); procedure SetImageCacheCount(Value: integer); procedure WMFormSubmit(var Message: TMessage); message WM_FormSubmit; procedure WMMouseScroll(var Message: TMessage); message WM_MouseScroll; procedure WMUrlAction(var Message: TMessage); message WM_UrlAction; procedure SetSelLength(Value: integer); procedure SetSelStart(Value: integer); function GetSelLength: integer; function GetSelText: WideString; procedure SetNoSelect(Value: boolean); procedure SetHistoryMaxCount(Value: integer); procedure DrawBorder; procedure DoHilite(X, Y: integer); virtual; procedure SetScrollBars(Value: TScrollStyle); procedure SetProcessing(Value: boolean); procedure SetCharset(Value: TFontCharset); function GetFormControlList: TList; function GetNameList: TStringList; function GetLinkList: TList; procedure SetServerRoot(Value: string); procedure SetOnFileBrowse(Handler: TFileBrowseEvent); procedure SetOnObjectClick(Handler: TObjectClickEvent); procedure SetOnObjectFocus(Handler: ThtObjectEvent); procedure SetOnObjectBlur(Handler: ThtObjectEvent); procedure SetOnObjectChange(Handler: ThtObjectEvent); procedure FormControlEnterEvent(Sender: TObject); procedure HandleMeta(Sender: TObject; const HttpEq, Name, Content: string); procedure SetOptions(Value: ThtmlViewerOptions); procedure DoImage(Sender: TObject; const SRC: string; var Stream: TMemoryStream); procedure SetOnExpandName(Handler: TExpandNameEvent); function GetWordAtCursor(X, Y: integer; var St, En: integer; var AWord: WideString): boolean; procedure SetOnPanelCreate(Handler: TPanelCreateEvent); procedure SetOnPanelDestroy(Handler: TPanelDestroyEvent); procedure SetOnPanelPrint(Handler: TPanelPrintEvent); procedure HTMLTimerTimer(Sender: TObject); function GetDragDrop: TDragDropEvent; function GetDragOver: TDragOverEvent; procedure SetDragDrop(const Value: TDragDropEvent); procedure SetDragOver(const Value: TDragOverEvent); procedure HTMLDragDrop(Sender, Source: TObject; X, Y: Integer); procedure HTMLDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); procedure InitLoad; function GetFormData: TFreeList; procedure SetFormData(T: TFreeList); function GetIDControl(const ID: string): TObject; function GetIDDisplay(const ID: string): boolean; procedure SetIDDisplay(const ID: string; Value: boolean); procedure SetPrintScale(Value: double); protected { Protected declarations } PaintPanel: TPaintPanel; BorderPanel: TPanel; Sel1: integer; procedure DoLogic; procedure DoScrollBars; procedure SetupAndLogic; function GetURL(X, Y: integer; var UrlTarg: TUrlTarget; var FormControl: TImageFormControlObj; var ATitle: string): guResultType; function GetPalette: HPALETTE; override; procedure HTMLPaint(Sender: TObject); virtual; procedure HTMLMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; {$ifdef ver120_plus} procedure HTMLMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint); function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override; {$endif} procedure HTMLMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); virtual; procedure HTMLMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; procedure HTMLMouseDblClk(Message: TWMMouse); function HotSpotClickHandled: boolean; dynamic; procedure LoadFile(const FileName: string; ft: ThtmlFileType); virtual; procedure PaintWindow(DC: HDC); override; procedure UpdateImageCache; procedure DrawBackground2(ACanvas: TCanvas; ARect: TRect; XStart, YStart, XLast, YLast: integer; Image: TGpObject; Mask: TBitmap; BW, BH: integer; BGColor: TColor); procedure DoBackground1(ACanvas: TCanvas; ATop, AWidth, AHeight, FullHeight: integer); procedure DoBackground2(ACanvas: TCanvas; ALeft, ATop, AWidth, AHeight: integer; AColor: TColor); procedure LoadString(const Source, Reference: string; ft: ThtmlFileType); public { Public declarations } FrameOwner: TObject; VScrollBar: T32ScrollBar; HScrollBar: TScrollBar; TablePartRec: TTablePartRec; Visited: TStringList; {visited URLs} procedure AddVisitedLink(const S: string); procedure CheckVisitedLinks; procedure UrlAction; procedure TriggerUrlAction; constructor Create(AOwner: TComponent); override; destructor Destroy; override; function HTMLExpandFilename(const Filename: string): string; virtual; procedure LoadFromFile(const FileName: string); procedure LoadTextFromString(const S: string); {$ifdef ver120_plus} {Delphi 4 and higher} procedure LoadFromString(const S: string; const Reference: string = ''); overload; {$ifdef Delphi6_Plus} procedure LoadFromString(const WS: WideString; const Reference: string = ''); overload; {$endif} procedure LoadFromStream(const AStream: TStream; const Reference: string = ''); procedure LoadStrings(const Strings: TStrings; const Reference: string = ''); procedure LoadFromBuffer(Buffer: PChar; BufSize: integer; const Reference: string = ''); {$else} procedure LoadFromString(const S: string; const Reference: string); procedure LoadFromStream(const AStream: TStream; const Reference: string); procedure LoadStrings(const Strings: TStrings; const Reference: string); procedure LoadFromBuffer(Buffer: PChar; BufSize: integer; const Reference: string); {$endif} procedure LoadTextFile(const FileName: string); procedure LoadImageFile(const FileName: string); procedure LoadTextStrings(Strings: TStrings); procedure LoadStream(const URL: string; AStream: TMemoryStream; ft: ThtmlFileType); procedure Print(FromPage, ToPage: integer); function NumPrinterPages: integer; overload; function NumPrinterPages(var WidthRatio: double): integer; overload; {$IFNDEF LCL} function PrintPreview(MFPrinter: TMetaFilePrinter; NoOutput: boolean = False): integer; {$ENDIF} function PositionTo(Dest: string): boolean; function Find(const S: WideString; MatchCase: boolean): boolean; function FindEx(const S: WideString; MatchCase, Reverse: boolean): boolean; procedure Clear; virtual; procedure CopyToClipboard; procedure SelectAll; procedure ClearHistory; procedure Reload; procedure BumpHistory(const FileName, Title: string; OldPos: integer; OldFormData: TFreeList; ft: ThtmlFileType); function GetSelTextBuf(Buffer: PWideChar; BufSize: integer): integer; function InsertImage(const Src: string; Stream: TMemoryStream): boolean; procedure DoEnter; override; procedure DoExit; override; procedure Repaint; override; function FindSourcePos(DisplayPos: integer): integer; function FindDisplayPos(SourcePos: integer; Prev: boolean): integer; function DisplayPosToXy(DisplayPos: integer; var X, Y: integer): boolean; function PtInObject(X, Y: integer; var Obj: TObject): boolean; {X, Y, are client coord} procedure SetStringBitmapList(BitmapList: TStringBitmapList); function XYToDisplayPos(X, Y: integer): integer; procedure ReplaceImage(const NameID: string; NewImage: TStream); procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure Reformat; procedure htProgress(Percent: Integer); procedure htProgressEnd; procedure htProgressInit; function FullDisplaySize(FormatWidth: integer): TSize; function MakeBitmap(YTop, FormatWidth, Width, Height: integer): TBitmap; {$IFNDEF LCL} function MakeMetaFile(YTop, FormatWidth, Width, Height: integer): TMetaFile; function MakePagedMetaFiles(Width, Height: integer): TList; {$ENDIF} procedure ControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); function GetCharAtPos(Pos: integer; var Ch: WideChar; var Font: TFont): boolean; function GetTextByIndices(AStart, ALast: integer): WideString; procedure OpenPrint; procedure ClosePrint; procedure AbortPrint; property DocumentTitle: string read GetTitle; property URL: string read FURL write FURL; property Base: string read GetBase write SetBase; property BaseTarget: string read GetBaseTarget; property Position: integer read GetPosition write SetPosition; property VScrollBarPosition: integer read GetScrollPos write SetScrollPos; property VScrollBarRange: integer read GetScrollBarRange; property HScrollBarPosition: integer read GetHScrollPos write SetHScrollPos; property HScrollBarRange: integer read GetHScrollBarRange; property CurrentFile: string read GetCurrentFile; property History: TStrings read FHistory; property TitleHistory: TStrings read FTitleHistory; property HistoryIndex: integer read FHistoryIndex write SetHistoryIndex; property Processing: boolean read FProcessing; property SelStart: integer read FCaretPos write SetSelStart; property SelLength: integer read GetSelLength write SetSelLength; property SelText: WideString read GetSelText; property Target: string read FTarget write FTarget; property Palette: HPalette read GetOurPalette write SetOurPalette; property Dither: boolean read FDither write SetDither default True; property CaretPos: integer read FCaretPos write SetCaretPos; property FormControlList: TList read GetFormControlList; property NameList: TStringList read GetNameList; property LinkList: TList read GetLinkList; property SectionList: TSectionList read FSectionList; property OnPageEvent: TPageEvent read FOnPageEvent write FOnPageEvent; property OnExpandName: TExpandNameEvent read FOnExpandName write SetOnExpandName; property FormData: TFreeList read GetFormData write SetFormData; property DocumentSource: string read FDocumentSource; property MaxVertical: integer read FMaxVertical; property TitleAttr: string read FTitleAttr; property IDDisplay[const ID: string]: boolean read GetIDDisplay write SetIDDisplay; property IDControl[const ID: string]: TObject read GetIDControl; property OnLinkDrawn: TLinkDrawnEvent read FOnLinkDrawn write FOnLinkDrawn; property LinkAttributes: TStringList read FLinkAttributes; Property LinkText: WideString read FLinkText write FLinkText; Property LinkStart: TPoint read FLinkStart; property CodePage: integer read FCodePage write FCodePage; published { Published declarations } property OnHotSpotCovered: THotSpotEvent read FOnHotSpotCovered write FOnHotSpotCovered; property OnHotSpotClick: THotSpotClickEvent read FOnHotSpotClick write FOnHotSpotClick; property OnBitmapRequest: TGetBitmapEvent read FOnBitmapRequest write SetOnBitmapRequest; property OnImageRequest: TGetImageEvent read FOnImageRequest write SetOnImageRequest; property OnScript: TScriptEvent read FOnScript write SetOnScript; property OnFormSubmit: TFormSubmitEvent read FOnFormSubmit write SetOnFormSubmit; property OnHistoryChange: TNotifyEvent read FOnHistoryChange write FOnHistoryChange; property OnProgress: ThtProgressEvent read FOnProgress write FOnProgress; property ViewImages: boolean read GetViewImages write SetViewImages default True; property Enabled; property TabStop; property TabOrder; property Align; property Name; property Tag; property PopupMenu; property ShowHint; {$ifdef ver120_plus} property Anchors; {$endif} property Height default 150; property Width default 150; property DefBackground: TColor read FBackground write SetColor default clBtnFace; property BorderStyle: THTMLBorderStyle read FBorderStyle write SetBorderStyle; property Visible; property HistoryMaxCount: integer read FHistoryMaxCount write SetHistoryMaxCount; property DefFontName: TFontName read FFontName write FFontName; property DefPreFontName: TFontName read GetPreFontName write SetPreFontName; property DefFontSize: integer read FFontSize write SetFontSize default 12; property DefFontColor: TColor read FFontColor write FFontColor default clBtnText; property DefHotSpotColor: TColor read FHotSpotColor write SetHotSpotColor default clBlue; property DefVisitedLinkColor: TColor read FVisitedColor write SetVisitedColor default clPurple; property DefOverLinkColor: TColor read FOverColor write SetActiveColor default clBlue; property VisitedMaxCount: integer read FVisitedMaxCount write SetVisitedMaxCount default 50; property ImageCacheCount: integer read FImageCacheCount write SetImageCacheCount default 5; property NoSelect: boolean read FNoSelect write SetNoSelect; property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssBoth; property CharSet: TFontCharset read FCharSet write SetCharset; property MarginHeight: integer read FMarginHeight write FMarginHeight default 5; property MarginWidth: integer read FMarginWidth write FMarginWidth default 10; property ServerRoot: string read FServerRoot write SetServerRoot; property PrintMarginLeft: double read FPrintMarginLeft write FPrintMarginLeft; property PrintMarginRight: double read FPrintMarginRight write FPrintMarginRight; property PrintMarginTop: double read FPrintMarginTop write FPrintMarginTop; property PrintMarginBottom: double read FPrintMarginBottom write FPrintMarginBottom; property PrintScale: double read FPrintScale write SetPrintScale; property htOptions: ThtmlViewerOptions read FOptions write SetOptions default [htPrintTableBackground, htPrintMonochromeBlack]; property OnMouseMove; property OnMouseUp; property OnMouseDown; {$ifdef ver120_plus} property OnMouseWheel; {$endif} property OnKeyDown; property OnKeyUp; property OnKeyPress; property OnEnter; property OnExit; property OnProcessing: TProcessingEvent read FOnProcessing write FOnProcessing; property OnPrintHeader: TPagePrinted read FOnPrintHeader write FOnPrintHeader; property OnPrintFooter: TPagePrinted read FOnPrintFooter write FOnPrintFooter; property OnPrintHTMLHeader: ThtmlPagePrinted read FOnPrintHTMLHeader write FOnPrintHTMLHeader; property OnPrintHTMLFooter: ThtmlPagePrinted read FOnPrintHTMLFooter write FOnPrintHTMLFooter; property OnInclude: TIncludeType read FOnInclude write FOnInclude; property OnSoundRequest: TSoundType read FOnSoundRequest write FOnSoundRequest; property OnMeta: TMetaType read FOnMeta write FOnMeta; property OnLink: TLinkType read FOnLink write FOnLink; property OnMetaRefresh: TMetaRefreshType read FOnMetaRefresh write FOnMetaRefresh; property OnImageClick: TImageClickEvent read FOnImageClick write FOnImageClick; property OnImageOver: TImageOverEvent read FOnImageOver write FOnImageOver; property OnFileBrowse: TFileBrowseEvent read FOnFileBrowse write SetOnFileBrowse; property OnObjectClick: TObjectClickEvent read FOnObjectClick write SetOnObjectClick; property OnObjectFocus: ThtObjectEvent read FOnObjectFocus write SetOnObjectFocus; property OnObjectBlur: ThtObjectEvent read FOnObjectBlur write SetOnObjectBlur; property OnObjectChange: ThtObjectEvent read FOnObjectChange write SetOnObjectChange; property OnRightClick: TRightClickEvent read FOnRightClick write FOnRightClick; property OnMouseDouble: TMouseEvent read FOnMouseDouble write FOnMouseDouble; property OnPanelCreate: TPanelCreateEvent read FOnPanelCreate write SetOnPanelCreate; property OnPanelDestroy: TPanelDestroyEvent read FOnPanelDestroy write SetOnPanelDestroy; property OnPanelPrint: TPanelPrintEvent read FOnPanelPrint write SetOnPanelPrint; {$IFNDEF LCL} property OnDragDrop: TDragDropEvent read GetDragDrop write SetDragDrop; property OnDragOver: TDragOverEvent read GetDragOver write SetDragOver; {$ELSE} //Previous gives AV on Intel Mac in Laz designer (and inconsistent with framview/frambrwz) property OnDragDrop: TDragDropEvent read FOnDragDrop write SetDragDrop; property OnDragOver: TDragOverEvent read FOnDragOver write SetDragOver; {$ENDIF} property OnhtStreamRequest: TGetStreamEvent read FOnhtStreamRequest write FOnhtStreamRequest; property OnParseBegin: TParseEvent read FOnParseBegin write FOnParseBegin; property OnParseEnd: TNotifyEvent read FOnParseEnd write FOnParseEnd; property OnObjectTag: TObjectTagEvent read FOnObjectTag write FOnObjectTag; property Cursor: TCursor read GetCursor write SetCursor default crIBeam; end; implementation uses Clipbrd, htmlgif2; const ScrollGap = 20; type PositionObj = class(TObject) Pos: integer; FileType: ThtmlFileType; FormData: TFreeList; destructor Destroy; override; end; constructor THTMLViewer.Create(AOwner: TComponent); begin inherited Create(AOwner); InCreate := True; ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks]; Height := 150; Width := 150; SetCursor(crIBeam); FPrintMarginLeft := 2.0; FPrintMarginRight := 2.0; FPrintMarginTop := 2.0; FPrintMarginBottom := 2.0; FPrintScale := 1.0; FCharset := DEFAULT_CHARSET; FMarginHeight := 5; FMarginWidth := 10; // LCL port note: BorderPanel presumably used to simulate viewer border // since TWinControl does not have BorderStyle property. But this use of // TPanel interferes with Win32/GTK2 text display. However, eliminating // it altogether interferes with Carbon animated GIFs, so create and add, // but don't do anything with it. // Since we're using TCustomControl, which introduces BorderStyle in LCL, // instead of TWinControl, might eventually be able to set its border. BorderPanel := TPanel.Create(Self); BorderPanel.BevelInner := bvNone; BorderPanel.BevelOuter := bvNone; {$IFNDEF LCL} BorderPanel.Ctl3D := False; //Not LCL property BorderPanel.Align := alClient; //Interferes with GTK2 scrollbar BorderPanel.ParentCtl3D := False; //Not LCL property {$ifdef delphi7_plus} BorderPanel.ParentBackground := False; //Not LCL property {$endif} {$ENDIF} BorderPanel.Parent := Self; PaintPanel := TPaintPanel.CreateIt(Self, Self); PaintPanel.ParentFont := False; PaintPanel.Parent := Self; PaintPanel.Top := 1; PaintPanel.Left := 1; PaintPanel.BevelOuter := bvNone; PaintPanel.BevelInner := bvNone; {$IFNDEF LCL} PaintPanel.ctl3D := False; {$ENDIF} PaintPanel.OnPaint := HTMLPaint; PaintPanel.OnMouseDown := HTMLMouseDown; PaintPanel.OnMouseMove := HTMLMouseMove; PaintPanel.OnMouseUp := HTMLMouseUp; VScrollBar := T32ScrollBar.Create(Self); VScrollBar.Kind := sbVertical; VScrollBar.SmallChange := 16; VScrollBar.Visible := False; VScrollBar.TabStop := False; sbWidth := VScrollBar.Width; VScrollBar.Parent := Self; {$IFDEF LCL} VScrollBar.OnScroll := VScrollBar.DoOnScroll; {$ENDIF} HScrollBar := TScrollBar.Create(Self); HScrollBar.Kind := sbHorizontal; HScrollBar.SmallChange := 15; HScrollBar.OnScroll := Scroll; HScrollBar.Visible := False; HScrollBar.TabStop := False; HScrollBar.Parent := Self; HScrollBar.Width := sbWidth; FScrollBars := ssBoth; FSectionList := TSectionList.Create(Self, PaintPanel); FSectionList.ControlEnterEvent := FormControlEnterEvent; FSectionList.OnBackgroundChange := BackgroundChange; FSectionList.ShowImages := True; FNameList := FSectionList.IDNameList; DefBackground := clBtnFace; DefFontColor := clBtnText; DefHotSpotColor := clBlue; DefOverLinkColor := clBlue; DefVisitedLinkColor := clPurple; FVisitedMaxCount := 50; DefFontSize := 12; DefFontName := 'Times New Roman'; DefPreFontName := 'Courier New'; SetImageCacheCount(5); SetOptions([htPrintTableBackground, htPrintMonochromeBlack]); FHistory := TStringList.Create; FPositionHistory := TFreeList.Create; FTitleHistory := TStringList.Create; FDither := True; Visited := TStringList.Create; HTMLTimer := TTimer.Create(Self); HTMLTimer.Enabled := False; HTMLTimer.Interval := 200; HTMLTimer.OnTimer := HTMLTimerTimer; FLinkAttributes := TStringList.Create; InCreate := False; end; destructor ThtmlViewer.Destroy; begin if LocalBitmapList then begin FSectionList.Clear; FSectionList.BitmapList.Free; end; FSectionList.Free; FHistory.Free; FPositionHistory.Free; FTitleHistory.Free; Visited.Free; HTMLTimer.Free; FLinkAttributes.Free; AbortPrint; inherited Destroy; end; procedure THtmlViewer.SetupAndLogic; begin FTitle := ReadHTML.Title; if ReadHTML.Base <> '' then FBase := ReadHTML.Base else FBase := FBaseEx; FBaseTarget := ReadHTML.BaseTarget; if Assigned(FOnParseEnd) then FOnParseEnd(Self); try DontDraw := True; {Load the background bitmap if any and if ViewImages set} FSectionList.GetBackgroundBitmap; DoLogic; finally DontDraw := False; end; end; procedure ThtmlViewer.LoadFile(const FileName: string; ft: ThtmlFileType); var I: integer; Dest, FName, OldFile: string; SBuffer: string; OldCursor: TCursor; FS: TFileStream; begin with Screen do begin OldCursor := Cursor; Cursor := crHourGlass; end; IOResult; {eat up any pending errors} FName := FileName; I := Pos('#', FName); if I > 0 then begin Dest := Copy(FName, I+1, Length(FName)-I); {positioning information} FName := Copy(FName, 1, I-1); end else Dest := ''; FRefreshDelay := 0; try SetProcessing(True); if not FileExists(FName) then Raise(EInOutError.Create('Can''t locate file: '+FName)); FSectionList.ProgressStart := 75; htProgressInit; DontDraw := True; InitLoad; CaretPos := 0; Sel1 := -1; try OldFile := FCurrentFile; FCurrentFile := ExpandFileName(FName); FCurrentFileType := ft; if ft in [HTMLType, TextType] then begin FS := TFileStream.Create(FName, fmOpenRead or fmShareDenyWrite); try SetLength(FDocumentSource, FS.Size); FS.ReadBuffer(FDocumentSource[1], FS.Size); finally FS.Free; end; end else FDocumentSource := ''; if Assigned(FOnParseBegin) then FOnParseBegin(Self, FDocumentSource); if ft = HTMLType then begin if Assigned(FOnSoundRequest) then FOnSoundRequest(Self, '', 0, True); ParseHTMLString(FDocumentSource, FSectionList, FOnInclude, FOnSoundRequest, HandleMeta, FOnLink); end else if ft = TextType then ParseTextString(FDocumentSource, FSectionList) else begin SBuffer := ''; ParseHTMLString(SBuffer, FSectionList, Nil, Nil, Nil, Nil); end; finally SetupAndLogic; CheckVisitedLinks; if (Dest <> '') and PositionTo(Dest) then {change position, if applicable} else if FCurrentFile <> OldFile then begin ScrollTo(0); HScrollBar.Position := 0; end; {else if same file leave position alone} DontDraw := False; PaintPanel.Invalidate; end; finally Screen.Cursor := OldCursor; htProgressEnd; SetProcessing(False); end; if (FRefreshDelay > 0) and Assigned(FOnMetaRefresh) then FOnMetaRefresh(Self, FRefreshDelay, FRefreshURL); end; procedure ThtmlViewer.LoadFromFile(const FileName: string); var OldFile, OldTitle: string; OldPos: integer; OldType: ThtmlFileType; OldFormData: TFreeList; (*Stream: TMemoryStream; //debugging aid Indent, Tree: string; *) begin if FProcessing then Exit; if Filename <> '' then begin OldFile := FCurrentFile; OldTitle := FTitle; OldPos := Position; OldType := FCurrentFileType; OldFormData := GetFormData; try LoadFile(FileName, HTMLType); (*Indent := ''; //debugging aid Tree := ''; FSectionList.FormTree(Indent, Tree); Stream := TMemoryStream.Create; Stream.Size := Length(Tree); Move(Tree[1], Stream.Memory^, Length(Tree)); Stream.SaveToFile('C:\css2\exec\Tree.txt'); Stream.Free; *) if (OldFile <> FCurrentFile) or (OldType <> FCurrentFileType) then BumpHistory(OldFile, OldTitle, OldPos, OldFormData, OldType) else OldFormData.Free; except OldFormData.Free; Raise; end; end; end; {----------------ThtmlViewer.LoadTextFile} procedure ThtmlViewer.LoadTextFile(const FileName: string); var OldFile, OldTitle: string; OldPos: integer; OldType: ThtmlFileType; OldFormData: TFreeList; begin if FProcessing then Exit; if Filename <> '' then begin OldFile := FCurrentFile; OldTitle := FTitle; OldPos := Position; OldType := FCurrentFileType; OldFormData := GetFormData; try LoadFile(FileName, TextType); if (OldFile <> FCurrentFile) or (OldType <> FCurrentFileType) then BumpHistory(OldFile, OldTitle, OldPos, OldFormData, OldType) else OldFormData.Free; except OldFormData.Free; Raise; end; end; end; {----------------ThtmlViewer.LoadImageFile} procedure ThtmlViewer.LoadImageFile(const FileName: string); var OldFile, OldTitle: string; OldPos: integer; OldType: ThtmlFileType; OldFormData: TFreeList; begin if FProcessing then Exit; if Filename <> '' then begin OldFile := FCurrentFile; OldTitle := FTitle; OldPos := Position; OldType := FCurrentFileType; OldFormData := GetFormData; try LoadFile(FileName, ImgType); if (OldFile <> FCurrentFile) or (OldType <> FCurrentFileType) then BumpHistory(OldFile, OldTitle, OldPos, OldFormData, OldType) else OldFormData.Free; except OldFormData.Free; Raise; end; end; end; {----------------THtmlViewer.LoadStrings} procedure THtmlViewer.LoadStrings(const Strings: TStrings; const Reference: string); begin LoadString(Strings.Text, Reference, HTMLType); if (FRefreshDelay > 0) and Assigned(FOnMetaRefresh) then FOnMetaRefresh(Self, FRefreshDelay, FRefreshURL); end; {----------------THtmlViewer.LoadTextStrings} procedure THtmlViewer.LoadTextStrings(Strings: TStrings); begin LoadString(Strings.Text, '', TextType); end; {----------------ThtmlViewer.LoadFromBuffer} procedure ThtmlViewer.LoadFromBuffer(Buffer: PChar; BufSize: integer; const Reference: string); var S: string; begin SetLength(S, BufSize); Move(Buffer^, S[1], BufSize); LoadString(S, Reference, HTMLType); if (FRefreshDelay > 0) and Assigned(FOnMetaRefresh) then FOnMetaRefresh(Self, FRefreshDelay, FRefreshURL); end; {----------------ThtmlViewer.LoadTextFromString} procedure ThtmlViewer.LoadTextFromString(const S: string); begin LoadString(S, '', TextType); end; {----------------ThtmlViewer.LoadFromString} procedure ThtmlViewer.LoadFromString(const S: string; const Reference: string); begin LoadString(S, Reference, HTMLType); if (FRefreshDelay > 0) and Assigned(FOnMetaRefresh) then FOnMetaRefresh(Self, FRefreshDelay, FRefreshURL); end; {$ifdef Delphi6_Plus} procedure ThtmlViewer.LoadFromString(const WS: WideString; const Reference: string); begin LoadFromString(#$EF+#$BB+#$BF+UTF8Encode(WS), Reference); end; {$endif} {----------------ThtmlViewer.LoadString} procedure ThtmlViewer.LoadString(const Source, Reference: string; ft: ThtmlFileType); var I: integer; Dest, FName, OldFile: string; begin if FProcessing then Exit; SetProcessing(True); FRefreshDelay := 0; FName := Reference; I := Pos('#', FName); if I > 0 then begin Dest := Copy(FName, I+1, Length(FName)-I); {positioning information} FName := Copy(FName, 1, I-1); end else Dest := ''; DontDraw := True; try OldFile := FCurrentFile; FCurrentFile := ExpandFileName(FName); FCurrentFileType := ft; FSectionList.ProgressStart := 75; htProgressInit; InitLoad; CaretPos := 0; Sel1 := -1; if Assigned(FOnSoundRequest) then FOnSoundRequest(Self, '', 0, True); FDocumentSource := Source; if Assigned(FOnParseBegin) then FOnParseBegin(Self, FDocumentSource); if Ft = HTMLType then ParseHTMLString(FDocumentSource, FSectionList, FOnInclude, FOnSoundRequest, HandleMeta, FOnLink) else ParseTextString(FDocumentSource, FSectionList); SetupAndLogic; CheckVisitedLinks; if (Dest <> '') and PositionTo(Dest) then {change position, if applicable} else if (FCurrentFile = '') or (FCurrentFile <> OldFile) then begin ScrollTo(0); HScrollBar.Position := 0; end; {else if same file leave position alone} PaintPanel.Invalidate; finally htProgressEnd; SetProcessing(False); DontDraw := False; end; end; {----------------ThtmlViewer.LoadFromStream} procedure ThtmlViewer.LoadFromStream(const AStream: TStream; const Reference: string); var Stream: TMemoryStream; S: string; begin Stream := TMemoryStream.Create; try Stream.LoadFromStream(AStream); SetLength(S, Stream.Size); Move(Stream.Memory^, S[1], Stream.Size); LoadString(S, Reference, HTMLType); if (FRefreshDelay > 0) and Assigned(FOnMetaRefresh) then FOnMetaRefresh(Self, FRefreshDelay, FRefreshURL); finally Stream.Free; end; end; procedure ThtmlViewer.DoImage(Sender: TObject; const SRC: string; var Stream: TMemoryStream); begin Stream := FImageStream; end; {----------------ThtmlViewer.LoadStream} procedure ThtmlViewer.LoadStream(const URL: string; AStream: TMemoryStream; ft: ThtmlFileType); var SaveOnImageRequest: TGetImageEvent; SBuffer: string; begin if FProcessing or not Assigned(AStream) then Exit; SetProcessing(True); FRefreshDelay := 0; DontDraw := True; try FSectionList.ProgressStart := 75; htProgressInit; InitLoad; CaretPos := 0; Sel1 := -1; if ft in [HTMLType, TextType] then begin SetLength(FDocumentSource, AStream.Size); Move(AStream.Memory^, FDocumentSource[1], AStream.Size); end else FDocumentSource := ''; if Assigned(FOnParseBegin) then FOnParseBegin(Self, FDocumentSource); if ft = HTMLType then begin if Assigned(FOnSoundRequest) then FOnSoundRequest(Self, '', 0, True); ParseHTMLString(FDocumentSource, FSectionList, FOnInclude, FOnSoundRequest, HandleMeta, FOnLink); SetupAndLogic; end else if ft = TextType then begin ParseTextString(FDocumentSource, FSectionList); SetupAndLogic; end else begin SaveOnImageRequest := FOnImageRequest; SetOnImageRequest(DoImage); FImageStream := AStream; SBuffer := ''; try ParseHTMLString(SBuffer, FSectionList, Nil, Nil, Nil, Nil); SetupAndLogic; finally SetOnImageRequest(SaveOnImageRequest); end; end; ScrollTo(0); HScrollBar.Position := 0; PaintPanel.Invalidate; FCurrentFile := URL; finally htProgressEnd; DontDraw := False; SetProcessing(False); end; if (FRefreshDelay > 0) and Assigned(FOnMetaRefresh) then FOnMetaRefresh(Self, FRefreshDelay, FRefreshURL); end; {----------------ThtmlViewer.DoScrollBars} procedure ThtmlViewer.DoScrollBars; var VBar, VBar1, HBar: boolean; Wid, HWidth, WFactor, WFactor2, VHeight: integer; ScrollInfo :TScrollInfo; begin ScrollWidth := IntMin(ScrollWidth, MaxHScroll); if FBorderStyle = htNone then begin WFactor := 0; PaintPanel.Top := 0; PaintPanel.Left := 0; {$IFNDEF LCL} BorderPanel.Visible := False; {$ENDIF} end else begin WFactor := 1; PaintPanel.Top := 1; PaintPanel.Left := 1; {$IFNDEF LCL} BorderPanel.Visible := False; BorderPanel.Visible := True; {$ENDIF} end; WFactor2 := 2*WFactor; VBar := False; VBar1 := False; if (not (htShowVScroll in htOptions) and (FMaxVertical <= Height-WFactor2) and (ScrollWidth <= Width-WFactor2)) or (FScrollBars = ssNone) then {there are no scrollbars} HBar := False else if FScrollBars in [ssBoth, ssVertical] then begin {assume a vertical scrollbar} VBar1 := (FMaxVertical >= Height-WFactor2) or ((FScrollBars in [ssBoth, ssHorizontal]) and (FMaxVertical >= Height-WFactor2-sbWidth) and (ScrollWidth > Width-sbWidth-WFactor2)); HBar := (FScrollBars in [ssBoth, ssHorizontal]) and ((ScrollWidth > Width-WFactor2) or ((VBar1 or (htShowVScroll in FOptions)) and (ScrollWidth > Width-sbWidth-WFactor2))); VBar := Vbar1 or (htShowVScroll in htOptions); end else {there is no vertical scrollbar} HBar := (FScrollBars = ssHorizontal) and (ScrollWidth > Width-WFactor2); if VBar or ((htShowVScroll in FOptions) and (FScrollBars in [ssBoth, ssVertical])) then Wid := Width - sbWidth else Wid := Width; PaintPanel.Width := Wid - WFactor2; if HBar then begin PaintPanel.Height := Height - WFactor2 - sbWidth; VHeight := Height - sbWidth - WFactor2; end else Begin PaintPanel.Height := Height - WFactor2; VHeight := Height - WFactor2; end; HWidth := IntMax(ScrollWidth, Wid-WFactor2); HScrollBar.Visible := HBar; HScrollBar.LargeChange := IntMax(1, Wid - 20); HScrollBar.SetBounds(WFactor, Height-sbWidth-WFactor, Wid -WFactor, sbWidth); VScrollBar.SetBounds(Width-sbWidth-WFactor, WFactor, sbWidth, VHeight); VScrollBar.LargeChange := IntMax(1, PaintPanel.Height - VScrollBar.SmallChange); // LCL port: Added IntMax per HScrollBar above to avoid range-check error. if htShowVScroll in FOptions then begin VScrollBar.Visible := ( FScrollBars in [ssBoth, ssVertical] ); VScrollBar.Enabled := VBar1; end else VScrollBar.Visible := VBar; {$IFNDEF LCL} HScrollBar.Max := IntMax(0, HWidth); VScrollBar.SetParams(VScrollBar.Position, PaintPanel.Height+1, 0, FMaxVertical); ScrollInfo.cbSize := SizeOf(ScrollInfo); ScrollInfo.fMask := SIF_PAGE; ScrollInfo.nPage := Wid; SetScrollInfo(HScrollBar.Handle,SB_CTL,ScrollInfo,TRUE); {$ELSE} VScrollBar.SetParams(VScrollBar.Position, 0, FMaxVertical, PaintPanel.Height+1); HScrollBar.SetParams(HScrollBar.Position, 0, IntMax(0, HWidth), Wid); {$ENDIF} end; {----------------ThtmlViewer.DoLogic} procedure ThtmlViewer.DoLogic; var Wid, WFactor: integer; function HasVScrollbar: boolean; begin Result := (FMaxVertical > Height-WFactor) or ((FScrollBars in [ssBoth, ssHorizontal]) and (FMaxVertical >= Height-WFactor-sbWidth) and (ScrollWidth > Width-sbWidth-WFactor)); end; function HasVScrollbar1: boolean; begin Result := (FMaxVertical > Height-WFactor) or ((FScrollBars in [ssBoth, ssHorizontal]) and (FMaxVertical >= Height-WFactor-sbWidth) and (ScrollWidth > Width-WFactor)); end; function FSectionListDoLogic(Width: integer): integer; var Curs: integer; begin Curs := 0; ScrollWidth := 0; Result := FSectionList.DoLogic(PaintPanel.Canvas, 0, Width, ClientHeight-WFactor, 0, ScrollWidth, Curs); end; begin HandleNeeded; try DontDraw := True; if FBorderStyle = htNone then WFactor := 0 else WFactor := 2; Wid := Width - WFactor; if FScrollBars in [ssBoth, ssVertical] then begin if not (htShowVScroll in FOptions) and (Length(FDocumentSource) < 10000) then begin {see if there is a vertical scrollbar with full width} FMaxVertical := FSectionListDoLogic(Wid); if HasVScrollBar then {yes, there is vertical scrollbar, allow for it} begin FMaxVertical := FSectionListDoLogic(Wid-sbWidth); if not HasVScrollBar1 then FMaxVertical := FSectionListDoLogic(Wid); end; end else {assume a vertical scrollbar} FMaxVertical := FSectionListDoLogic(Wid-sbWidth); end else {there is no vertical scrollbar} FMaxVertical := FSectionListDoLogic(Wid); DoScrollbars; finally DontDraw := False; end; end; procedure ThtmlViewer.HTMLPaint(Sender: TObject); var ARect: TRect; begin if not DontDraw then begin ARect := Rect(0, 1, PaintPanel.Width, PaintPanel.Height); FSectionList.Draw(PaintPanel.Canvas2, ARect, MaxHScroll, -HScrollBar.Position, 0, 0, 0); end; end; procedure ThtmlViewer.WMSize(var Message: TWMSize); begin inherited; if InCreate then Exit; if not FProcessing then Layout else DoScrollBars; if FMaxVertical < PaintPanel.Height then Position := 0 else ScrollTo(VScrollBar.Position); {keep aligned to limits} with HScrollBar do Position := IntMin(Position, Max - PaintPanel.Width); end; procedure ThtmlViewer.Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); {only the horizontal scrollbar comes here} begin ScrollPos := IntMin(ScrollPos, HScrollBar.Max - PaintPanel.Width); PaintPanel.Invalidate; end; procedure ThtmlViewer.ScrollTo(Y: integer); begin Y := IntMin(Y, FMaxVertical - PaintPanel.Height); Y := IntMax(Y, 0); VScrollBar.Position := Y; FSectionList.SetYOffset(Y); Invalidate; end; procedure ThtmlViewer.Layout; var OldPos: integer; begin if FProcessing then Exit; SetProcessing(True); try OldPos := Position; FSectionList.ProgressStart := 0; htProgressInit; DoLogic; Position := OldPos; {return to old position after width change} finally htProgressEnd; SetProcessing(False); end; end; function ThtmlViewer.HotSpotClickHandled: boolean; var Handled: boolean; begin Handled := False; if Assigned(FOnHotSpotClick) then FOnHotSpotClick(Self, URL, Handled); Result := Handled; end; procedure ThtmlViewer.TriggerUrlAction; begin PostMessage(Handle, wm_UrlAction, 0, 0); end; procedure ThtmlViewer.WMUrlAction(var Message: TMessage); begin UrlAction; end; procedure ThtmlViewer.URLAction; var S, Dest: string; Ext: string[5]; I: integer; OldPos: integer; begin if not HotSpotClickHandled then begin OldPos := Position; S := URL; I := Pos('#', S); {# indicates a position within the document} if I = 1 then begin if PositionTo(S) then {no filename with this one} begin BumpHistory(FCurrentFile, FTitle, OldPos, Nil, FCurrentFileType); AddVisitedLink(FCurrentFile+S); end; end else begin if I >= 1 then begin Dest := System.Copy(S, I, Length(S)-I+1); {local destination} S := System.Copy(S, 1, I-1); {the file name} end else Dest := ''; {no local destination} S := HTMLExpandFileName(S); Ext := Uppercase(ExtractFileExt(S)); if (Ext = '.HTM') or (Ext = '.HTML') then begin {an html file} if S <> FCurrentFile then begin LoadFromFile(S + Dest); AddVisitedLink(S+Dest); end else if PositionTo(Dest) then {file already loaded, change position} begin BumpHistory(FCurrentFile, FTitle, OldPos, Nil, HTMLType); AddVisitedLink(S+Dest); end; end else if (Ext = '.BMP') or (Ext = '.GIF') or (Ext = '.JPG') or (Ext = '.JPEG') or (Ext = '.PNG') then LoadImageFile(S); end; {Note: Self may not be valid here} end; end; {----------------ThtmlViewer.AddVisitedLink} procedure ThtmlViewer.AddVisitedLink(const S: string); var I, J: integer; S1, UrlTmp: string; begin if Assigned(FrameOwner) or (FVisitedMaxCount = 0) then Exit; {TFrameViewer will take care of visited links} I := Visited.IndexOf(S); if I = 0 then Exit else if I < 0 then begin for J := 0 to SectionList.LinkList.Count-1 do with TFontObj(SectionList.LinkList[J]) do begin UrlTmp := Url; if Length(UrlTmp) > 0 then begin if Url[1] = '#' then S1 := FCurrentFile+UrlTmp else S1 := HTMLExpandFilename(UrlTmp); if CompareText(S, S1) = 0 then Visited := True; end; end; end else Visited.Delete(I); {thus moving it to the top} Visited.Insert(0, S); for I := Visited.Count-1 downto FVisitedMaxCount do Visited.Delete(I); end; {----------------ThtmlViewer.CheckVisitedLinks} procedure ThtmlViewer.CheckVisitedLinks; var I, J: integer; S, S1: string; begin if FVisitedMaxCount = 0 then Exit; for I := 0 to Visited.Count-1 do begin S := Visited[I]; for J := 0 to SectionList.LinkList.Count-1 do with TFontObj(SectionList.LinkList[J]) do begin if (Url <> '') and (Url[1] = '#') then S1 := FCurrentFile+Url else S1 := HTMLExpandFilename(Url); if CompareText(S, S1) = 0 then Visited := True; end; end; end; {----------------ThtmlViewer.HTMLMouseDown} procedure ThtmlViewer.HTMLMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var XR, CaretHt: integer; YR: integer; InText: boolean; Dummy : TUrlTarget; DummyFC: TImageFormControlObj; DummyTitle: string; begin inherited MouseDown(Button, Shift, X, Y); SetFocus; HotSpotAction := False; if MiddleScrollOn then begin MiddleScrollOn := False; PaintPanel.Cursor := Cursor; MouseScrolling := False; end else if (Button = mbMiddle) and not (htNoWheelMouse in htOptions) then {comment this out to disable mouse middle button scrolling} begin MiddleScrollOn := True; MiddleY := Y; PaintPanel.Cursor := UpDownCursor; end else if (Button = mbLeft) then begin LeftButtonDown := True; if not (htNoLinkHilite in FOptions) or not (guUrl in GetURL(X, Y, Dummy, DummyFC, DummyTitle)) then HiLiting := True; with FSectionList do begin Sel1 := FindCursor(PaintPanel.Canvas, X, Y+YOff, XR, YR, CaretHt, InText); if Sel1 > -1 then begin if (SelB <> SelE) or (ssShift in Shift) then InvalidateRect(PaintPanel.Handle, Nil, True); if (ssShift in Shift) then if Sel1 < CaretPos then begin SelE := CaretPos; SelB := Sel1; end else begin SelB := CaretPos; SelE := Sel1; end else begin SelB := Sel1; SelE := Sel1; CaretPos := Sel1; end; end; LButtonDown(True); {signal to TSectionList} end; end; end; procedure ThtmlViewer.HTMLTimerTimer(Sender: TObject); var Pt: TPoint; begin if GetCursorPos(Pt) and (WindowFromPoint(Pt) <> PaintPanel.Handle) then begin SectionList.CancelActives; HTMLTimer.Enabled := False; if FURL <> '' then begin FURL := ''; FTarget := ''; if Assigned(FOnHotSpotCovered) then FOnHotSpotCovered(Self, ''); end; end; end; function ThtmlViewer.PtInObject(X, Y: integer; var Obj: TObject): boolean; {X, Y, are client coord} {css} var IX, IY: integer; begin Result := PtInRect(ClientRect, Point(X, Y)) and FSectionList.PtInObject(X, Y+FSectionList.YOff, Obj, IX, IY); end; procedure ThtmlViewer.ControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var Dummy : TUrlTarget; DummyFC: TImageFormControlObj; begin if Sender is TFormControlObj then with TFormControlObj(Sender), TheControl do begin FTitleAttr:= Title; if FTitleAttr = '' then begin Dummy := Nil; GetURL(X+Left, Y+Top, Dummy, DummyFC, FTitleAttr); if Assigned(Dummy) then Dummy.Free; end; Inherited MouseMove(Shift,X,Y); end; end; function ThtmlViewer.GetTextByIndices(AStart, ALast: integer): WideString; var SaveSelB: Integer; SaveSelE: Integer; begin if (AStart >= 0) and (ALast >= 0) and (ALast > AStart) then with FSectionList do begin SaveSelB := SelB; SaveSelE := SelE; SelB := Self.FindDisplayPos(AStart, False); SelE := Self.FindDisplayPos(ALast, False); Result := GetSelText; DisplayPosToXY(SelB, FLinkStart.X, FLinkStart.Y); Dec(FLinkStart.Y, VScrollBar.Position); SelB := SaveSelB; SelE := SaveSelE; end else Result := ''; end; {----------------ThtmlViewer.HTMLMouseMove} procedure ThtmlViewer.HTMLMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); var UrlTarget : TUrlTarget; Url, Target: string; FormControl: TImageFormControlObj; Obj: TObject; IX, IY: integer; XR, CaretHt: integer; YR: integer; InText: boolean; NextCursor: TCursor; guResult: guResultType; begin Inherited MouseMove(Shift,X,Y); if MiddleScrollOn then begin if not MouseScrolling and (Abs(Y-MiddleY) > ScrollGap) then begin MouseScrolling := True; PostMessage(Handle, wm_MouseScroll, 0, 0); end; Exit; end; UrlTarget := Nil; URL := ''; NextCursor := crArrow; FTitleAttr := ''; guResult := GetURL(X, Y, UrlTarget, FormControl, FTitleAttr); if guUrl in guResult then begin NextCursor := HandCursor; Url := UrlTarget.Url; Target := UrlTarget.Target; FLinkAttributes.Text := UrlTarget.Attr; FLinkText := GetTextByIndices(UrlTarget.Start, UrlTarget.Last); UrlTarget.Free; end; if guControl in guResult then NextCursor := HandCursor; if (Assigned(FOnImageClick) or Assigned(FOnImageOver)) and FSectionList.PtInObject(X, Y+FSectionList.YOff, Obj, IX, IY) then begin if NextCursor <> HandCursor then {in case it's also a Link} NextCursor := crArrow; if Assigned(FOnImageOver) then FOnImageOver(Self, Obj, Shift, IX, IY); end else if (FSectionList.FindCursor(PaintPanel.Canvas, X, Y+FSectionList.YOff, XR, YR, CaretHt, InText) >= 0) and InText and (NextCursor <> HandCursor) then NextCursor := Cursor; PaintPanel.Cursor := NextCursor; if ((NextCursor = HandCursor) or (SectionList.ActiveImage <> Nil)) then HTMLTimer.Enabled := True else HTMLTimer.Enabled := False; if (URL <> FURL) or (Target <> FTarget) then begin FURL := URL; FTarget := Target; if Assigned(FOnHotSpotCovered) then FOnHotSpotCovered(Self, URL); end; if (ssLeft in Shift) and not MouseScrolling and ((Y <= 0) or (Y >= Self.Height)) then begin MouseScrolling := True; PostMessage(Handle, wm_MouseScroll, 0, 0); end; if (ssLeft in Shift) and not FNoSelect then DoHilite(X, Y); end; procedure ThtmlViewer.HTMLMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var UrlTarget: TUrlTarget; FormControl: TImageFormControlObj; Obj: TObject; IX, IY: integer; InImage, TmpLeft: boolean; Parameters: TRightClickParameters; AWord: WideString; St, En: integer; guResult: guResultType; I, ThisID: integer; ParentForm: TCustomForm; begin if MiddleScrollOn then begin {cancel unless it's middle button and has moved} if (Button <> mbMiddle) or (Y <> MiddleY) then begin MiddleScrollOn := False; PaintPanel.Cursor := Cursor; end; Exit; end; inherited MouseUp(Button, Shift, X, Y); if Assigned(FOnImageClick) or Assigned(FOnRightClick) then begin InImage := FSectionList.PtInObject(X, Y+FSectionList.YOff, Obj, IX, IY); if Assigned(FOnImageClick) and InImage then FOnImageClick(Self, Obj, Button, Shift, IX, IY); if (Button = mbRight) and Assigned(FOnRightClick) then begin Parameters := TRightClickParameters.Create; try if InImage then begin Parameters.Image := Obj as TImageObj; Parameters.ImageX := IX; Parameters.ImageY := IY; end; if guUrl in GetURL(X, Y, UrlTarget, FormControl, FTitleAttr) then begin Parameters.URL := UrlTarget.Url; Parameters.Target := UrlTarget.Target; UrlTarget.Free; end; if GetWordAtCursor(X, Y, St, En, AWord) then Parameters.ClickWord := AWord; HTMLTimer.Enabled := False; FOnRightClick(Self, Parameters); finally HTMLTimer.Enabled := True; Parameters.Free; end; end; end; if (Button = mbLeft) and not (ssShift in Shift) then begin MouseScrolling := False; DoHilite(X, Y); Hiliting := False; FSectionList.LButtonDown(False); TmpLeft := LeftButtonDown; LeftButtonDown := False; if TmpLeft and (FSectionList.SelE <= FSectionList.SelB) then begin guResult := GetURL(X, Y, UrlTarget, FormControl, FTitleAttr); if guControl in guResult then FormControl.ImageClick(Nil) else if guUrl in guResult then begin FURL := UrlTarget.Url; FTarget := UrlTarget.Target; FLinkAttributes.Text := UrlTarget.Attr; FLinkText := GetTextByIndices(UrlTarget.Start, UrlTarget.Last); ThisID := UrlTarget.ID; for I := 0 to LinkList.Count-1 do with TFontObj(LinkList.Items[I]) do if (ThisID = UrlTarget.ID) and Assigned(TabControl) then begin ParentForm := GetParentForm(TabControl); if Assigned(ParentForm) and TabControl.CanFocus then begin NoJump := True; {keep doc from jumping position on mouse click} try ParentForm.ActiveControl := TabControl; finally NoJump := False; end; end; break; end; UrlTarget.Free; HotSpotAction := True; {prevent double click action} URLAction; {Note: Self pointer may not be valid after URLAction call (TFrameViewer, HistoryMaxCount=0)} end; end; end; end; {----------------ThtmlViewer.HTMLMouseWheel} {$ifdef ver120_plus} procedure ThtmlViewer.HTMLMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint); var Lines: integer; begin Lines := Mouse.WheelScrollLines; if Lines > 0 then if WheelDelta > 0 then VScrollBarPosition := VScrollBarPosition - (Lines * 16) else VScrollBarPosition := VScrollBarPosition + (Lines * 16) else VScrollBarPosition := VScrollBarPosition - WheelDelta div 2; end; function ThtmlViewer.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; begin result:= inherited DoMouseWheel(shift, wheelDelta, mousePos); if not result and not (htNoWheelMouse in htOptions) then begin HTMLMouseWheel(Self, Shift, WheelDelta, MousePos); Result := True; end; end; {$endif} {----------------ThtmlViewer.XYToDisplayPos} function ThtmlViewer.XYToDisplayPos(X, Y: integer): integer; var InText: boolean; XR, YR, CaretHt: integer; begin with SectionList do Result := FindCursor(PaintPanel.Canvas, X, Y+YOff, XR, YR, CaretHt, InText); if not InText then Result := -1; end; {----------------ThtmlViewer.GetCharAtPos} function ThtmlViewer.GetCharAtPos(Pos: integer; var Ch: WideChar; var Font: TFont): boolean; var Obj: TObject; FO: TFontObj; Index: integer; begin Result := FSectionList.GetChAtPos(Pos, Ch, Obj); if Result and (Obj is TSection) then with TSection(Obj) do begin FO := Fonts.GetFontObjAt(Pos-StartCurs, Index); Font := FO.TheFont; end; end; {----------------ThtmlViewer.GetWordAtCursor} function ThtmlViewer.GetWordAtCursor(X, Y: integer; var St, En: integer; var AWord: WideString): boolean; var XR, X1, CaretHt: integer; YR, Y1: integer; Obj: TObject; Ch: WideChar; InText: boolean; Tmp: WideString; function AlphaNum(Ch: WideChar): boolean; begin Result := (Ch in [WideChar('a')..WideChar('z'), WideChar('A')..WideChar('Z'), WideChar('0')..WideChar('9')]) or (Ch >= #192); end; function GetCh(Pos: integer): WideChar; var Ch: WideChar; Obj1: TObject; begin Result := ' '; if not FSectionList.GetChAtPos(Pos, Ch, Obj1) or (Obj1 <> Obj) then Exit; Result := Ch; end; begin Result := False; AWord := ''; with FSectionList do begin InText := False; CaretPos := FindCursor(PaintPanel.Canvas, X, Y+YOff, XR, YR, CaretHt, InText); CursorToXy(PaintPanel.Canvas, CaretPos, X1, Y1); if InText then {else cursor is past end of row} begin en := CaretPos; st := en-1; if GetChAtPos(en, Ch, Obj) and AlphaNum(Ch) then begin AWord := Ch; Result := True; Inc(en); Ch := GetCh(en); while AlphaNum(Ch) do begin Tmp := Ch; {Delphi 3 needs this nonsense} AWord := AWord + Tmp; Inc(en); Ch := GetCh(en); end; if St >= 0 then begin Ch := GetCh(st); while (st >= 0) and AlphaNum(Ch) do begin System.Insert(Ch, AWord, 1); Dec(st); if St >= 0 then Ch := GetCh(St); end; end; end; end; end; end; {----------------ThtmlViewer.HTMLMouseDblClk} procedure ThtmlViewer.HTMLMouseDblClk(Message: TWMMouse); var st, en: integer; AWord: WideString; begin FSectionList.LButtonDown(True); if FProcessing or HotSpotAction then Exit; if not FNoSelect and GetWordAtCursor(Message.XPos, Message.YPos, St, En, AWord) then begin FSectionList.SelB := st+1; FSectionList.SelE := en; FCaretPos := st+1; InvalidateRect(PaintPanel.Handle, Nil, True); end; if Assigned(FOnMouseDouble) then with Message do FOnMouseDouble(Self, mbLeft, KeysToShiftState(Keys), XPos, YPos); end; procedure ThtmlViewer.DoHilite(X, Y: integer); var Curs, YR, YWin: integer; XR, CaretHt: integer; InText: boolean; begin if Hiliting and (Sel1 >= 0) then with FSectionList do begin YWin := IntMin(IntMax(0, Y), Height); Curs := FindCursor(PaintPanel.Canvas, X, YWin+YOff, XR, YR, CaretHt, InText); if (Curs >= 0) and not FNoSelect then begin if Curs > Sel1 then begin SelE := Curs; SelB := Sel1; end else begin SelB := Curs; SelE := Sel1; end; InvalidateRect(PaintPanel.Handle, Nil, True); end; CaretPos := Curs; end; end; {----------------ThtmlViewer.WMMouseScroll} procedure ThtmlViewer.WMMouseScroll(var Message: TMessage); const Ticks: DWord = 0; var Pos: integer; Pt: TPoint; begin GetCursorPos(Pt); Ticks := 0; with VScrollBar do begin Pt := PaintPanel.ScreenToClient(Pt); while MouseScrolling and (LeftButtonDown and((Pt.Y <= 0) or (Pt.Y > Self.Height))) or (MiddleScrollOn and (Abs(Pt.Y - MiddleY) > ScrollGap)) do begin if GetTickCount > Ticks +100 then begin Ticks := GetTickCount; Pos := Position; if LeftButtonDown then begin if Pt.Y < -15 then Pos := Position - SmallChange * 8 else if Pt.Y <= 0 then Pos := Position - SmallChange else if Pt.Y > Self.Height+15 then Pos := Position + SmallChange * 8 else Pos := Position + SmallChange; end else begin {MiddleScrollOn} if Pt.Y-MiddleY < -3*ScrollGap then Pos := Position - 32 else if Pt.Y-MiddleY < -ScrollGap then Pos := Position - 8 else if Pt.Y-MiddleY > 3*ScrollGap then Pos := Position + 32 else if Pt.Y-MiddleY > ScrollGap then Pos := Position + 8; if Pos < Position then PaintPanel.Cursor := UpOnlyCursor else if Pos > Position then PaintPanel.Cursor := DownOnlyCursor; end; Pos := IntMax(0, IntMin(Pos, FMaxVertical - PaintPanel.Height)); FSectionList.SetYOffset(Pos); SetPosition(Pos); DoHilite(Pt.X, Pt.Y); PaintPanel.Invalidate; GetCursorPos(Pt); Pt := PaintPanel.ScreenToClient(Pt); end; Application.ProcessMessages; Application.ProcessMessages; Application.ProcessMessages; Application.ProcessMessages; end; end; MouseScrolling := False; if MiddleScrollOn then PaintPanel.Cursor := UpDownCursor; end; function ThtmlViewer.PositionTo(Dest: string): boolean; var I: integer; Obj: TObject; begin Result := False; If Dest = '' then Exit; if Dest[1] = '#' then System.Delete(Dest, 1, 1); I := FNameList.IndexOf(UpperCase(Dest)); if I > -1 then begin Obj := FNameList.Objects[I]; if (Obj is TIDObject) then ScrollTo(TIDObject(Obj).YPosition); HScrollBar.Position := 0; Result := True; AddVisitedLink(FCurrentFile+'#'+Dest); end; end; function ThtmlViewer.GetURL(X, Y: integer; var UrlTarg: TUrlTarget; var FormControl: TImageFormControlObj; var ATitle: string): guResultType; begin Result := FSectionList.GetURL(PaintPanel.Canvas, X, Y+FSectionList.YOff, UrlTarg, FormControl, ATitle); end; procedure THTMLViewer.SetViewImages(Value: boolean); var OldPos: integer; OldCursor: TCursor; begin if (Value <> FSectionList.ShowImages) and not FProcessing then begin OldCursor := Screen.Cursor; try Screen.Cursor := crHourGlass; SetProcessing(True); FSectionList.ShowImages := Value; if FSectionList.Count > 0 then begin FSectionList.GetBackgroundBitmap; {load any background bitmap} OldPos := Position; DoLogic; Position := OldPos; Invalidate; end; finally Screen.Cursor := OldCursor; SetProcessing(False); end; end; end; {----------------ThtmlViewer.InsertImage} function ThtmlViewer.InsertImage(const Src: string; Stream: TMemoryStream): boolean; var OldPos: integer; ReFormat: boolean; begin Result := False; if FProcessing then Exit; try SetProcessing(True); FSectionList.InsertImage(Src, Stream, Reformat); FSectionList.GetBackgroundBitmap; {in case it's the one placed} if Reformat then if FSectionList.Count > 0 then begin FSectionList.GetBackgroundBitmap; {load any background bitmap} OldPos := Position; DoLogic; Position := OldPos; end; Invalidate; finally SetProcessing(False); Result := True; end; end; function THTMLViewer.GetBase: string; begin Result := FBase; end; procedure THTMLViewer.SetBase(Value: string); begin FBase := Value; FBaseEx := Value; end; function THTMLViewer.GetBaseTarget: string; begin Result := FBaseTarget; end; function THTMLViewer.GetTitle: string; begin Result := FTitle; end; function THTMLViewer.GetCurrentFile: string; begin Result := FCurrentFile; end; function THTMLViewer.GetViewImages: boolean; begin Result := FSectionList.ShowImages; end; procedure THTMLViewer.SetColor(Value: TColor); begin if FProcessing then Exit; FBackground := Value; FSectionList.Background:= Value; PaintPanel.Color := Value; Invalidate; end; procedure THTMLViewer.SetBorderStyle(Value: THTMLBorderStyle); begin if Value <> FBorderStyle then begin FBorderStyle := Value; DrawBorder; end; end; procedure ThtmlViewer.KeyDown(var Key: Word; Shift: TShiftState); var Pos: integer; OrigPos: integer; TheChange: integer; begin inherited KeyDown(Key, Shift); if Shift <> [] then Exit; if MiddleScrollOn then begin MiddleScrollOn := False; PaintPanel.Cursor := Cursor; Exit; end; with VScrollBar do if Key in [VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN, VK_HOME, VK_END] then begin Pos := Position; OrigPos := Pos; case Key of VK_PRIOR : Dec(Pos, LargeChange); VK_NEXT : Inc(Pos, LargeChange); VK_UP : Dec(Pos, SmallChange); VK_DOWN : Inc(Pos, SmallChange); VK_Home : Pos := 0; VK_End : Pos := FMaxVertical; end; if Pos < 0 then Pos := 0; Pos := IntMax(0, IntMin(Pos, FMaxVertical - PaintPanel.Height)); Position := Pos; FSectionList.SetYOffset(Pos); TheChange := OrigPos-Pos; if not BGFixed and (abs(TheChange) = SmallChange) then begin {update only the scrolled part} ScrollWindow(PaintPanel.Handle, 0, TheChange, NIL, NIL); PaintPanel.Update; end else PaintPanel.Invalidate; end; with HScrollBar do if Key in [VK_LEFT, VK_RIGHT] then begin Pos := Position; case Key of VK_LEFT : Dec(Pos, SmallChange); VK_RIGHT : Inc(Pos, SmallChange); end; if Pos < 0 then Pos := 0; Pos := IntMin(Pos, Max - PaintPanel.Width); Position := Pos; PaintPanel.Invalidate; end; end; procedure ThtmlViewer.WMGetDlgCode(var Message: TMessage); begin Message.Result := DLGC_WantArrows; {else don't get the arrow keys} end; function ThtmlViewer.GetPosition: integer; var Index: integer; TopPos, Pos: integer; S: TSectionBase; begin Pos := integer(VScrollBar.Position); S:= FSectionList.FindSectionAtPosition(Pos, TopPos, Index); if Assigned(S) then Result := integer(Index+1) shl 16 + ((Pos - TopPos) and $FFFF) else Result := Pos; {Hiword is section # plus 1, Loword is displacement from top of section HiWord = 0 is top of display} end; procedure ThtmlViewer.SetPosition(Value: integer); var TopPos: integer; begin if HiWord(Value) = 0 then ScrollTo(LoWord(Value)) else if (Hiword(Value)-1 < FSectionList.PositionList.Count) then begin TopPos := TSectionBase(FSectionList.PositionList[HiWord(Value)-1]).YPosition; ScrollTo(TopPos + LoWord(Value)); end; end; function ThtmlViewer.GetScrollPos: integer; begin Result := VScrollBar.Position; end; procedure ThtmlViewer.SetScrollPos(Value: integer); begin if Value < 0 then Value := 0; Value := IntMin(Value, FMaxVertical - PaintPanel.Height); if Value <> GetScrollPos then ScrollTo(Value); end; function ThtmlViewer.GetScrollBarRange: integer; begin Result := FMaxVertical - PaintPanel.Height; end; function ThtmlViewer.GetHScrollPos: integer; begin Result := HScrollBar.Position; end; procedure ThtmlViewer.SetHScrollPos(Value: integer); begin if Value < 0 then Value := 0; Value := IntMin(Value, HScrollBar.Max-PaintPanel.Width); HScrollbar.Position := Value; Invalidate; end; function ThtmlViewer.GetHScrollBarRange: integer; begin Result := HScrollBar.Max - PaintPanel.Width; end; function ThtmlViewer.GetPalette: HPALETTE; begin if ThePalette <> 0 then Result := ThePalette else Result := inherited GetPalette; Invalidate; end; function ThtmlViewer.HTMLExpandFilename(const Filename: string): string; var Tmp: string; begin {pass http: and other protocols except for file:///} if (Pos('://', Filename) > 1) and (Pos('file://', Lowercase(Filename)) = 0) then Result := Filename else begin Result := HTMLServerToDos(Trim(Filename), FServerRoot); {$IFDEF MSWINDOWS} if Pos('\', Result) = 1 then Result := ExpandFilename(Result) else if (Pos(':', Result)<> 2) and (Pos('\\', Result) <> 1) then {$ELSE} if Pos('/', Result) > 1 then Result := ExpandFilename(Result) else if (Pos('/', Result) <> 1) then {$ENDIF} if CompareText(FBase, 'DosPath') = 0 then {let Dos find the path} else if FBase <> '' then begin Tmp := ExtractFilePath(HTMLToDos(FBase)); Result := ExpandFilename(Tmp + Result) end else Result := ExpandFilename(ExtractFilePath(FCurrentFile) + Result); end; end; {----------------ThtmlViewer.BumpHistory} procedure ThtmlViewer.BumpHistory(const FileName, Title: string; OldPos: integer; OldFormData: TFreeList; ft: ThtmlFileType); var I: integer; PO: PositionObj; SameName: boolean; begin SameName := FileName = FCurrentFile; if (FHistoryMaxCount > 0) and (FCurrentFile <> '') and ((not SameName) or (FCurrentFileType <> ft) or (OldPos <> Position)) then with FHistory do begin if (Count > 0) and (Filename <> '') then begin Strings[FHistoryIndex] := Filename; with PositionObj(FPositionHistory[FHistoryIndex]) do begin Pos := OldPos; FileType := ft; if not SameName then {only stored when documents changed} FormData := OldFormData else OldFormData.Free; end; FTitleHistory[FHistoryIndex] := Title; for I := 0 to FHistoryIndex-1 do begin Delete(0); FTitleHistory.Delete(0); PositionObj(FPositionHistory[0]).Free; FPositionHistory.Delete(0); end; end; FHistoryIndex := 0; Insert(0, FCurrentFile); PO := PositionObj.Create; PO.Pos := Position; PO.FileType := FCurrentFileType; FPositionHistory.Insert(0, PO); FTitleHistory.Insert(0, FTitle); if Count > FHistoryMaxCount then begin Delete(FHistoryMaxCount); FTitleHistory.Delete(FHistoryMaxCount); PositionObj(FPositionHistory[FHistoryMaxCount]).Free; FPositionHistory.Delete(FHistoryMaxCount); end; if Assigned(FOnHistoryChange) then FOnHistoryChange(Self); end else OldFormData.Free; end; procedure ThtmlViewer.SetHistoryIndex(Value: integer); var I: integer; function GetLowestSameFileIndex(Start: integer): integer; begin Result := Start; while (Result > 0) and (FHistory[Result-1] = FCurrentFile) do Dec(Result); end; begin with FHistory do if (Value <> FHistoryIndex) and (Value >= 0) and (Value < Count) and not FProcessing then begin if FCurrentFile <> '' then begin {save the current information} Strings[FHistoryIndex] := FCurrentFile; with PositionObj(FPositionHistory[FHistoryIndex]) do begin Pos := Position; FileType := FCurrentFileType; I := GetLowestSameFileIndex(FHistoryIndex); PositionObj(FPositionHistory[I]).FormData := GetFormData; end; FTitleHistory[FHistoryIndex] := FTitle; end; with PositionObj(FPositionHistory[Value]) do begin {reestablish the new desired history position} if (FCurrentFile <> Strings[Value]) or (FCurrentFileType <> FileType) then Self.LoadFile(Strings[Value], FileType); Position := Pos; I := GetLowestSameFileIndex(Value); with PositionObj(FPositionHistory[I]) do begin SetFormData(FormData); {reload the forms if any} FormData.Free; FormData := Nil; end; end; FHistoryIndex := Value; if Assigned(FOnHistoryChange) then FOnHistoryChange(Self); end; end; procedure ThtmlViewer.SetHistoryMaxCount(Value: integer); begin if (Value = FHistoryMaxCount) or (Value < 0) then Exit; if Value < FHistoryMaxCount then ClearHistory; FHistoryMaxCount := Value; end; procedure ThtmlViewer.ClearHistory; var CountWas: integer; begin CountWas := FHistory.Count; FHistory.Clear; FTitleHistory.Clear; FPositionHistory.Clear; FHistoryIndex := 0; FCurrentFile := ''; if (CountWas > 0) and Assigned(FOnHistoryChange) then FOnHistoryChange(Self); end; function ThtmlViewer.GetPreFontName: TFontName; begin Result := FPreFontName; end; procedure ThtmlViewer.SetPreFontName(Value: TFontName); begin if CompareText(Value, FSectionList.PreFontName) <> 0 then begin FPreFontName := Value; FSectionList.PreFontName := Value; end; end; procedure ThtmlViewer.SetFontSize(Value: integer); begin FFontSize := Value; end; procedure ThtmlViewer.SetCharset(Value: TFontCharset); begin FCharset := Value; end; function ThtmlViewer.GetFormControlList: TList; begin Result := FSectionList.FormControlList; end; function ThtmlViewer.GetNameList: TStringList; begin Result := FNameList; end; function ThtmlViewer.GetLinkList: TList; begin Result := FSectionList.LinkList; end; procedure ThtmlViewer.SetHotSpotColor(Value: TColor); begin FHotSpotColor := Value; FSectionList.HotSpotColor := Value; end; procedure ThtmlViewer.SetVisitedColor(Value: TColor); begin FVisitedColor := Value; FSectionList.LinkVisitedColor := Value; end; procedure ThtmlViewer.SetActiveColor(Value: TColor); begin FOverColor := Value; FSectionList.LinkActiveColor := Value; end; procedure ThtmlViewer.SetVisitedMaxCount(Value: integer); var I: integer; begin Value := IntMax(Value, 0); if Value <> FVisitedMaxCount then begin FVisitedMaxCount := Value; if FVisitedMaxCount = 0 then begin Visited.Clear; for I := 0 to SectionList.LinkList.Count-1 do TFontObj(LinkList[I]).Visited := False; Invalidate; end else begin FVisitedMaxCount := Value; for I := Visited.Count-1 downto FVisitedMaxCount do Visited.Delete(I); end; end; end; function ThtmlViewer.GetCursor: TCursor; begin Result := inherited Cursor; end; procedure ThtmlViewer.SetCursor(Value: TCursor); begin if Value = OldThickIBeamCursor then {no longer used} Value := crIBeam; inherited Cursor := Value; end; function ThtmlViewer.FullDisplaySize(FormatWidth: integer): TSize; var Curs: integer; CopyList: TSectionList; begin Result.cx := 0; {error return} Result.cy := 0; if FormatWidth > 0 then begin CopyList := TSectionList.CreateCopy(FSectionList); try Curs := 0; Result.cy := CopyList.DoLogic(PaintPanel.Canvas, 0, FormatWidth, 300, 0, Result.cx, Curs); finally CopyList.Free; end; end; end; {----------------CalcBackgroundLocationAndTiling} procedure CalcBackgroundLocationAndTiling(const PRec: PtPositionRec; ARect: TRect; XOff, YOff, IW, IH, BW, BH: integer; var X, Y, X2, Y2: integer); {PRec has the CSS information on the background image, it's starting location and whether it is tiled in x, y, neither, or both. ARect is the cliprect, no point in drawing tiled images outside it. XOff, YOff are offsets which allow for the fact that the viewable area may not be at 0,0. IW, IH are the total width and height of the document if you could see it all at once. BW, BH are bitmap dimensions used to calc tiling. X, Y are the position (window coordinates) where the first background iamge will be drawn. X2, Y2 are tiling limits. X2 and Y2 may be such that 0, 1, or many images will get drawn. They're calculated so that only images within ARect are drawn. } var I: integer; P: array[1..2] of integer; begin {compute the location of the prime background image. Tiling can go either way from this image} P[1] := 0; P[2] := 0; for I := 1 to 2 do {I = 1 is X info, I = 2 is Y info} with PRec[I] do begin case PosType of pTop: P[I] := - YOff; pCenter: if I = 1 then P[1] := IW div 2 - BW div 2 - XOff else P[2] := IH div 2 - BH div 2 - YOff; pBottom: P[I] := IH - BH - YOff; pLeft: P[I] := -XOff; pRight: P[I] := IW - BW - XOff; PPercent: if I = 1 then P[1] := ((IW-BW) * Value) div 100 - XOff else P[2] := ((IH-BH) * Value div 100) - YOff; pDim: if I = 1 then P[I] := Value-XOff else P[I] := Value-YOff; end; end; {Calculate the tiling keeping it within the cliprect boundaries} X := P[1]; Y := P[2]; if PRec[2].RepeatD then begin {y repeat} {figure a starting point for tiling. This will be less that one image height outside the cliprect} if Y < ARect.Top then Y := Y+ ((ARect.Top-Y)div BH)*BH else if Y > ARect.Top then Y := Y - ((Y-ARect.Top)div BH)*BH - BH; Y2 := ARect.Bottom; end else begin {a single image or row} Y2 := Y; {assume it's not in the cliprect and won't be output} if not((Y > ARect.Bottom) or (Y+BH < ARect.Top)) then Inc(Y2); {it is in the clip rect, show it} end; if PRec[1].RepeatD then begin {x repeat} {figure a starting point for tiling. This will be less that one image width outside the cliprect} if X < ARect.Left then X := X+ ((ARect.Left-X)div BW)*BW else if X > ARect.Left then X := X - ((X-ARect.Left)div BW)*BW - BW; X2 := ARect.Right; end else begin {single image or column} X2 := X; {assume it's not in the cliprect and won't be output} if not((X > ARect.Right) or (X+BW < ARect.Left)) then Inc(X2); {it is in the clip rect, show it} end; end; {----------------DrawBackground} procedure DrawBackground(ACanvas: TCanvas; ARect: TRect; XStart, YStart, XLast, YLast: integer; Image: TGpObject; Mask: TBitmap; AniGif: TGifImage; BW, BH: integer; BGColor: TColor); {draw the background color and any tiled images on it} {ARect, the cliprect, drawing outside this will not show but images may overhang XStart, YStart are first image position already calculated for the cliprect and parameters. XLast, YLast Tiling stops here. BW, BH bitmap dimensions. } var X, Y: integer; OldBrush: HBrush; OldPal: HPalette; DC: HDC; OldBack, OldFore: TColor; Bitmap: TBitmap; graphics: TGpGraphics; begin DC := ACanvas.handle; if DC <> 0 then begin OldPal := SelectPalette(DC, ThePalette, False); RealizePalette(DC); ACanvas.Brush.Color := BGColor or PalRelative; OldBrush := SelectObject(DC, ACanvas.Brush.Handle); OldBack := SetBkColor(DC, clWhite); OldFore := SetTextColor(DC, clBlack); try ACanvas.FillRect(ARect); {background color} if Assigned(AniGif) then {tile the animated gif} begin Y := YStart; while Y < YLast do begin X := XStart; while X < XLast do begin AniGif.Draw(ACanvas,X, Y, BW, BH); Inc(X, BW); end; Inc(Y, BH); end; end else if Assigned(Image) then {tile the bitmap} if Image is TBitmap then begin Bitmap := TBitmap(Image); Y := YStart; while Y < YLast do begin X := XStart; while X < XLast do begin if Mask = Nil then BitBlt(DC, X, Y, BW, BH, Bitmap.Canvas.Handle, 0, 0, SRCCOPY) else begin BitBlt(dc, X, Y, BW, BH, Bitmap.Canvas.Handle, 0, 0, SrcInvert); BitBlt(dc, X, Y, BW, BH, Mask.Canvas.Handle, 0, 0, SrcAnd); BitBlt(dc, X, Y, BW, BH, Bitmap.Canvas.Handle, 0, 0, SrcPaint); end; Inc(X, BW); end; Inc(Y, BH); end; end {$ifndef NoMetafile} else if Image is ThtMetafile then begin Y := YStart; try while Y < YLast do begin X := XStart; while X < XLast do begin ACanvas.Draw(X, Y, ThtMetaFile(Image)); Inc(X, BW); end; Inc(Y, BH); end; except end; end {$endif} else begin Y := YStart; graphics := TGPGraphics.Create(DC); try while Y < YLast do begin X := XStart; while X < XLast do begin graphics.DrawImage(TGpImage(Image), X, Y, BW, BH); Inc(X, BW); end; Inc(Y, BH); end; except end; Graphics.Free; end; finally SelectObject(DC, OldBrush); SelectPalette(DC, OldPal, False); RealizePalette(DC); SetBkColor(DC, OldBack); SetTextColor(DC, OldFore); end; end; end; {----------------ThtmlViewer.DrawBackground2} procedure ThtmlViewer.DrawBackground2(ACanvas: TCanvas; ARect: TRect; XStart, YStart, XLast, YLast: integer; Image: TGpObject; Mask: TBitmap; BW, BH: integer; BGColor: TColor); {Called by DoBackground2 (Print and PrintPreview)} {draw the background color and any tiled images on it} {ARect, the cliprect, drawing outside this will not show but images may overhang XStart, YStart are first image position already calculated for the cliprect and parameters. XLast, YLast Tiling stops here. BW, BH Image dimensions. } var X, Y: integer; OldBrush: HBrush; OldPal: HPalette; DC: HDC; OldBack, OldFore: TColor; Bitmap: TBitmap; begin DC := ACanvas.handle; if DC <> 0 then begin OldPal := SelectPalette(DC, ThePalette, False); RealizePalette(DC); ACanvas.Brush.Color := BGColor or PalRelative; OldBrush := SelectObject(DC, ACanvas.Brush.Handle); OldBack := SetBkColor(DC, clWhite); OldFore := SetTextColor(DC, clBlack); try ACanvas.FillRect(ARect); {background color} if Assigned(Image) then {tile the Image} if Image is TBitmap then begin Bitmap := TBitmap(Image); Y := YStart; while Y < YLast do begin X := XStart; while X < XLast do begin if Mask = Nil then PrintBitmap(ACanvas, X, Y, BW, BH, Bitmap.Handle) else begin PrintTransparentBitmap3(ACanvas, X, Y, BW, BH, Bitmap, Mask, 0, Bitmap.Height); end; Inc(X, BW); end; Inc(Y, BH); end; end {$ifndef NoMetafile} else if Image is ThtMetafile then begin Y := YStart; try while Y < YLast do begin X := XStart; while X < XLast do begin ACanvas.Draw(X, Y, ThtMetaFile(Image)); Inc(X, BW); end; Inc(Y, BH); end; except end; end {$endif} else begin Y := YStart; try while Y < YLast do begin X := XStart; while X < XLast do begin StretchPrintGpImageOnColor(ACanvas, TGPImage(Image), X, Y, BW, BH, BGColor); Inc(X, BW); end; Inc(Y, BH); end; except end; end; finally SelectObject(DC, OldBrush); SelectPalette(DC, OldPal, False); RealizePalette(DC); SetBkColor(DC, OldBack); SetTextColor(DC, OldFore); end; end; end; procedure ThtmlViewer.DoBackground1(ACanvas: TCanvas; ATop, AWidth, AHeight, FullHeight: integer); var ARect: TRect; Image: TGpObject; Mask: TBitmap; PRec: PtPositionRec; BW, BH, X, Y, X2, Y2, IW, IH, XOff, YOff: integer; Fixed: boolean; begin ARect := Rect(0, 0, AWidth, AHeight); Image := FSectionList.BackgroundBitmap; if FSectionList.ShowImages and Assigned(Image) then begin Mask := FSectionList.BackgroundMask; BW := GetImageWidth(Image); BH := GetImageHeight(Image); PRec := FSectionList.BackgroundPRec; Fixed := PRec[1].Fixed; if Fixed then begin {fixed background} XOff := 0; YOff := 0; IW := AWidth; IH := AHeight; end else begin {scrolling background} XOff := 0; YOff := ATop; IW := AWidth; IH := FullHeight; end; {Calculate where the tiled background images go} CalcBackgroundLocationAndTiling(PRec, ARect, XOff, YOff, IW, IH, BW, BH, X, Y, X2, Y2); DrawBackground(ACanvas, ARect, X, Y, X2, Y2, Image, Mask, Nil, BW, BH, PaintPanel.Color); end else begin {no background image, show color only} DrawBackground(ACanvas, ARect, 0,0,0,0, Nil, Nil, Nil, 0, 0, PaintPanel.Color); end; end; procedure ThtmlViewer.DoBackground2(ACanvas: TCanvas; ALeft, ATop, AWidth, AHeight: integer; AColor: TColor); {called by Print and PrintPreview} var ARect: TRect; Image: TGpObject; Mask: TBitmap; PRec: PtPositionRec; BW, BH, X, Y, X2, Y2, IW, IH, XOff, YOff: integer; NewBitmap, NewMask: TBitmap; begin ARect := Rect(ALeft, ATop, ALeft+AWidth, ATop+AHeight); Image := FSectionList.BackgroundBitmap; if FSectionList.ShowImages and Assigned(Image) then begin Mask := FSectionList.BackgroundMask; BW := GetImageWidth(Image); BH := GetImageHeight(Image); PRec := FSectionList.BackgroundPRec; XOff := -ALeft; YOff := -ATop; IW := AWidth; IH := AHeight; {Calculate where the tiled background images go} CalcBackgroundLocationAndTiling(PRec, ARect, XOff, YOff, IW, IH, BW, BH, X, Y, X2, Y2); if (BW = 1) or (BH = 1) then begin {this is for people who try to tile 1 pixel images} NewBitmap := EnlargeImage(Image, X2-X, Y2-Y); try if Assigned(Mask) then NewMask := TBitmap(EnlargeImage(Mask, X2-X, Y2-Y)) else NewMask := Nil; try DrawBackground2(ACanvas, ARect, X, Y, X2, Y2, NewBitmap, NewMask, NewBitmap.Width, NewBitmap.Height, AColor); finally NewMask.Free; end; finally NewBitmap.Free; end; end else DrawBackground2(ACanvas, ARect, X, Y, X2, Y2, Image, Mask, BW, BH, AColor); end else begin {no background image, show color only} DrawBackground2(ACanvas, ARect, 0,0,0,0, Nil, Nil, 0, 0, AColor); end; end; type EExcessiveSizeError = Class(Exception); {$IFNDEF LCL} function ThtmlViewer.MakeMetaFile(YTop, FormatWidth, Width, Height: integer): TMetaFile; var CopyList: TSectionList; Dummy: integer; Curs: integer; Canvas: TMetaFileCanvas; DocHeight: integer; begin Result := Nil; if FProcessing or (FSectionList.Count = 0) then Exit; if Height > 4000 then Raise EExcessiveSizeError.Create('Vertical Height exceeds 4000'); CopyList := TSectionList.CreateCopy(FSectionList); try Result := TMetaFile.Create; Result.Width := Width; Result.Height := Height; Canvas := TMetaFileCanvas.Create(Result, 0); try Curs := 0; DocHeight := CopyList.DoLogic(Canvas, 0, FormatWidth, Height, 0, Dummy, Curs); DoBackground1(Canvas, YTop, Width, Height, DocHeight); CopyList.SetYOffset(IntMax(0, YTop)); CopyList.Draw(Canvas, Rect(0, 0, Width, Height), MaxHScroll, 0, 0, 0,0); except Result.Free; Result := Nil; end; Canvas.Free; finally CopyList.Free; end; end; function ThtmlViewer.MakePagedMetaFiles(Width, Height: integer): TList; var ARect, CRect: TRect; CopyList: TSectionList; HTop, OldTop, Dummy, Curs, I: integer; Done: boolean; VPixels: integer; Canvas: TMetaFileCanvas; MF: TMetaFile; TablePart: TablePartType; SavePageBottom: Integer; hrgnClip1: hRgn; procedure PaintBackground(Canvas: TCanvas; Top, Bot: integer); begin Canvas.Brush.Color := CopyList.Background; Canvas.Brush.Style := bsSolid; Canvas.FillRect(Rect(0, Top, Width+1, Bot)); end; begin Done := False; Result := Nil; TablePartRec := Nil; if FProcessing or (SectionList.Count = 0) then Exit; CopyList := TSectionList.CreateCopy(SectionList); try CopyList.NoOutput := False; CopyList.Printing := True; CopyList.LinkDrawnEvent := FOnLinkDrawn; Result := TList.Create; try HTop := 0; OldTop := 0; Curs := 0; VPixels := 0; ARect := Rect(0, 0, Width, Height); while not Done do begin MF := TMetaFile.Create; try MF.Width := Width; MF.Height := Height; Canvas := TMetaFileCanvas.Create(MF, 0); try if HTop = 0 then {DoLogic the first time only} VPixels := CopyList.DoLogic(Canvas, 0, Width, Height, 0, Dummy, Curs); CopyList.SetYOffset(HTop); PaintBackground(Canvas, 0, Height); repeat if Assigned(TablePartRec) then TablePart := TablePartRec.TablePart else TablePart := Normal; case TablePart of Normal: begin CopyList.Draw(Canvas, ARect, Width, 0, 0, 0,0); PaintBackground(Canvas, CopyList.PageBottom-HTop, Height+1); end; DoHead: begin CopyList.SetYOffset(TablePartRec.PartStart); CRect := ARect; CRect.Bottom := CRect.Top+TablePartRec.PartHeight; hrgnClip1 := CreateRectRgn(0, 0, Width+1, CRect.Bottom); SelectClipRgn(Canvas.Handle, hrgnClip1); DeleteObject(hrgnClip1); CopyList.Draw(Canvas, CRect, Width, 0, 0, 0,0); end; DoBody1, DoBody3: begin CRect := ARect; CRect.Top := CopyList.PageBottom-1-CopyList.YOff; CopyList.SetYOffset(TablePartRec.PartStart-CRect.top); CopyList.Draw(Canvas, CRect, Width, 0+3*Width, 0, 0,0); {off page} TablePartRec.TablePart := DoBody2; CRect.Bottom := CopyList.PageBottom-CopyList.YOff+1; hrgnClip1 := CreateRectRgn(0, CRect.Top, Width+1, CRect.Bottom); SelectClipRgn(Canvas.Handle, hrgnClip1); DeleteObject(hrgnClip1); CopyList.Draw(Canvas, CRect, Width, 0, 0, 0,0); {onpage} if not Assigned(TablePartRec) or not (TablePartRec.TablePart in [Normal]) then PaintBackground(Canvas, CopyList.PageBottom-CopyList.YOff, Height+1); end; DoFoot: begin SavePageBottom := CopyList.PageBottom; CRect := ARect; CRect.Top := CopyList.PageBottom-CopyList.YOff; CRect.Bottom := CRect.Top + TablePartRec.PartHeight; hrgnClip1 := CreateRectRgn(0, CRect.Top, Width+1, CRect.Bottom); SelectClipRgn(Canvas.Handle, hrgnClip1); DeleteObject(hrgnClip1); CopyList.SetYOffset(TablePartRec.PartStart-CRect.top); CopyList.Draw(Canvas, CRect, Width, 0, 0, 0,0); CopyList.PageBottom := SavePageBottom; end; end; until not Assigned(TablePartRec) or (TablePartRec.TablePart in [Normal, DoHead, DoBody3]); finally Canvas.Free; end; except MF.Free; Raise; end; Result.Add(MF); HTop := CopyList.PageBottom; Inc(CopyList.LinkPage); Application.ProcessMessages; if (HTop >= VPixels) or (HTop <= OldTop) then {see if done or endless loop} Done := True; OldTop := HTop; end; except for I := 0 to Result.Count-1 do TMetaFile(Result.Items[I]).Free; FreeAndNil(Result); Raise; end; finally CopyList.Free; end; end; {$ENDIF} function ThtmlViewer.MakeBitmap(YTop, FormatWidth, Width, Height: integer): TBitmap; var CopyList: TSectionList; Dummy: integer; Curs: integer; DocHeight: integer; begin Result := Nil; if FProcessing or (FSectionList.Count = 0) then Exit; if Height > 4000 then Raise EExcessiveSizeError.Create('Vertical Height exceeds 4000'); CopyList := TSectionList.CreateCopy(FSectionList); try Result := TBitmap.Create; try Result.HandleType := bmDIB; Result.PixelFormat := pf24Bit; Result.Width := Width; Result.Height := Height; Curs := 0; DocHeight := CopyList.DoLogic(Result.Canvas, 0, FormatWidth, Height, 300, Dummy, Curs); DoBackground1(Result.Canvas, YTop, Width, Height, DocHeight); CopyList.SetYOffset(IntMax(0, YTop)); CopyList.Draw(Result.Canvas, Rect(0, 0, Width, Height), MaxHScroll, 0, 0, 0,0); except Result.Free; Result := Nil; end; finally CopyList.Free; end; end; function ThtmlViewer.CreateHeaderFooter: ThtmlViewer; begin Result := ThtmlViewer.Create(Nil); Result.Visible := False; Result.Parent := Parent; Result.DefBackground := DefBackground; Result.DefFontName := DefFontName; Result.DefFontSize := DefFontSize; Result.DefFontColor := DefFontColor; Result.CharSet := Charset; Result.MarginHeight := 0; with Result.FSectionList do begin PrintBackground := True; PrintTableBackground := True; end; end; procedure ThtmlViewer.Print(FromPage, ToPage: integer); var ARect, CRect: TRect; PrintList: TSectionList; P1, P2, P3, W, H, HTop, OldTop, Dummy: integer; Curs: integer; Done: boolean; DC : HDC; PrinterOpen: boolean; UpperLeftPagePoint, { these will contain Top/Left and Bottom/Right unprintable area} LowerRightPagePoint: TPoint; MLeft: integer; MLeftPrn: integer; MRightPrn: integer; MTopPrn: integer; MBottomPrn: integer; TopPixels, TopPixelsPrn, HPrn, WPrn: integer; hrgnClip, hrgnClip1: THandle; savedFont : TFont ; savedPen : TPen ; savedBrush : TBrush ; Align, ScaledPgHt, ScaledPgWid, VPixels: integer; FootViewer, HeadViewer: ThtmlViewer; DeltaMarginTop: Double; SavePrintMarginTop: Double; DeltaPixelsPrn: Integer; DeltaPixels: Integer; OrigTopPixels: Integer; OrigTopPixelsPrn: Integer; OrigHprn: Integer; OrigH: Integer; LastPrintMarginTop: Double; MLeftSide: Integer; TablePart: TablePartType; SavePageBottom: Integer; procedure SaveCanvasItems(Canvas: TCanvas); begin { preserve current settings of the Canvas} SavedPen.Assign(Canvas.Pen); SavedFont.Assign(Canvas.Font); SavedBrush.Assign(Canvas.Brush); end; procedure RestoreCanvasItems(Canvas: TCanvas); begin { restore initial Canvas settings } Canvas.Pen.Assign(SavedPen); Canvas.Font.Assign(SavedFont); Canvas.Brush.Assign(SavedBrush); end; procedure WhiteoutArea(Canvas: TCanvas; Y: integer); {White out excess printing. Y is top of the bottom area to be blanked.} begin Canvas.Brush.Color := clWhite; Canvas.Brush.Style := bsSolid; Canvas.Pen.Style := psSolid; Canvas.Pen.Color := clWhite; Canvas.Rectangle(MLeft, 0, W + MLeft+1, TopPixels-1); Canvas.Rectangle(MLeft, Y, W + MLeft+1, TopPixels+H+1); if (htPrintBackground in FOptions) and (Y-TopPixels < H) then begin {need to reprint background in whited out area} hrgnClip1 := CreateRectRgn(MLeftPrn, MulDiv(Y, P3, P2)-2, MLeftPrn+WPrn, TopPixelsPrn+HPrn); SelectClipRgn(Canvas.Handle, hrgnClip1); DeleteObject(hrgnClip1); DoBackground2(Canvas, MLeft, TopPixels, W, H, PaintPanel.Color); end; RestoreCanvasItems(Canvas); end; procedure DoHTMLHeaderFooter(Footer: boolean; Event: ThtmlPagePrinted; HFViewer: ThtmlViewer); var YOrigin, YOff, Ht: integer; HFCopyList: TSectionList; BRect: TRect; DocHeight, XL, XR: integer; begin if not Assigned(Event) then Exit; try XL := MLeft; XR := MLeft + W; Event(Self, HFViewer, FPage, PrintList.PageBottom > VPixels, XL, XR, Done); {call event handler} HFCopyList := TSectionList.CreateCopy(HFViewer.SectionList); try HFCopyList.Printing := True; HFCopyList.ScaleX := fScaleX; HFCopyList.ScaleY := fScaleY; Curs := 0; DocHeight := HFCopyList.DoLogic(vwP.Canvas, 0, XR-XL, 300, 0, Dummy, Curs); if not Footer then begin {Header} YOrigin := 0; Ht := TopPixels; YOff := DocHeight-TopPixels; end else begin {Footer} YOrigin := -(TopPixels+H); Ht := IntMin(ScaledPgHt-(TopPixels+H), DocHeight); YOff := 0; end; SetWindowOrgEx(DC, 0, YOrigin, nil); HFViewer.DoBackground2(vwP.Canvas, XL, -YOff, XR-XL, DocHeight, HFViewer.PaintPanel.Color); HFCopyList.SetYOffset(YOff); BRect := Rect(XL, 0, XR, Ht); HFCopyList.Draw(vwP.Canvas, BRect, XR-XL, XL, 0, 0,0); finally HFCopyList.Free; end; except end; end; begin Done := False; FootViewer := Nil; HeadViewer := Nil; TablePartRec := Nil; if Assigned(FOnPageEvent) then FOnPageEvent(Self, 0, Done); FPage := 0; if FProcessing or (FSectionList.Count = 0) then Exit; PrintList := TSectionList.CreateCopy(FSectionList); PrintList.SetYOffset(0); SavePrintMarginTop := FPrintMarginTop; try savedFont := TFont.Create ; savedPen := TPen.Create ; savedBrush := TBrush.Create ; try PrintList.Printing := True; PrintList.SetBackground(clWhite); if not assigned(vwP) then begin {$IFNDEF LCL} vwP := TvwPrinter.Create; OldPrinter := vwSetPrinter(vwP); {$ELSE} vwP := Printer; {$ENDIF} PrinterOpen := False; end else PrinterOpen := True; FPage := 1; hrgnClip := 0; try with vwP do begin if (DocumentTitle <> '') then vwP.Title := DocumentTitle ; if not Printing then BeginDoc else NewPage; SaveCanvasItems(Canvas); DC := Canvas.Handle; P3 := GetDeviceCaps(DC, LOGPIXELSY); P1 := GetDeviceCaps(DC, LOGPIXELSX); P2 := Round(Screen.PixelsPerInch * FPrintScale); fScaleX := 100.0/P3; fScaleY := 100.0/P1; PrintList.ScaleX := fScaleX; PrintList.ScaleY := fScaleY; SetMapMode(DC, mm_AnIsotropic); SetWindowExtEx(DC, P2, P2, Nil); SetViewPortExtEx(DC, P1,P3, Nil); { calculate the amount of space that is non-printable } { get PHYSICAL page width } {$IFNDEF LCL} LowerRightPagePoint.X := GetDeviceCaps(Printer.Handle, PhysicalWidth); LowerRightPagePoint.Y := GetDeviceCaps(Printer.Handle, PhysicalHeight); {$ELSE} LowerRightPagePoint.X := Printer.PaperSize.PaperRect.PhysicalRect.Right; LowerRightPagePoint.Y := Printer.PaperSize.PaperRect.PhysicalRect.Bottom; {$ENDIF} { now compute a complete unprintable area rectangle (composed of 2*width, 2*height) in pixels...} with LowerRightPagePoint do begin Y := Y - Printer.PageHeight; X := X - Printer.PageWidth; end; { get upper left physical offset for the printer... -> printable area <> paper size } {$IFNDEF LCL} UpperLeftPagePoint.X := GetDeviceCaps(Printer.Handle, PhysicalOffsetX); UpperLeftPagePoint.Y := GetDeviceCaps(Printer.Handle, PhysicalOffsetY); {$ELSE} UpperLeftPagePoint.X := Printer.PaperSize.PaperRect.WorkRect.Left; UpperLeftPagePoint.Y := Printer.PaperSize.PaperRect.WorkRect.Top; {$ENDIF} { now that we know the TOP and LEFT offset we finally can compute the BOTTOM and RIGHT offset: } with LowerRightPagePoint do begin x := x - UpperLeftPagePoint.x; { we don't want to have negative values} if x < 0 then x := 0; { assume no right printing offset } y := y - UpperLeftPagePoint.y; { we don't want to have negative values} if y < 0 then y := 0; { assume no bottom printing offset } end; { which results in LowerRightPoint containing the BOTTOM and RIGHT unprintable area offset; using these we modify the (logical, true) borders...} MLeftPrn := trunc(FPrintMarginLeft/2.54 * P1); MLeftPrn := MLeftPrn - UpperLeftPagePoint.x; { subtract physical offset } MLeft := MulDiv(MLeftPrn, P2, P1); MRightPrn := trunc(FPrintMarginRight/2.54 * P1); MRightPrn := MRightPrn - LowerRightPagePoint.x; { subtract physical offset } WPrn := PageWidth - (MLeftPrn + MRightPrn); W := MulDiv(WPrn, P2, P1); MTopPrn := trunc(FPrintMarginTop/2.54 * P3); MTopPrn := MTopPrn - UpperLeftPagePoint.y; { subtract physical offset } MBottomPrn := trunc(FPrintMarginBottom/2.54 * P3); MBottomPrn := MBottomPrn - LowerRightPagePoint.y; { subtract physical offset } TopPixelsPrn := MTopPrn; TopPixels := MulDiv(TopPixelsPrn, P2, P3); HPrn := PageHeight-(MTopPrn+MBottomPrn); H := MulDiv(HPrn, P2, P3); {scaled pageHeight} Curs := 0; VPixels := PrintList.DoLogic(Canvas, 0, W, H, 0, Dummy, Curs); Done := False; HTop := 0; OldTop := 0; ScaledPgHt := MulDiv(PageHeight, P2, P3); ScaledPgWid := MulDiv(PageWidth, P2, P3); hrgnClip := CreateRectRgn(MLeftPrn, TopPixelsPrn-1, WPrn + MLeftPrn+2, TopPixelsPrn + HPrn+2); Application.ProcessMessages; if Assigned(FOnPageEvent) then FOnPageEvent(Self, FPage, Done); ARect := Rect(MLeft, TopPixels, W + MLeft, TopPixels + H); if Assigned(FOnPrintHTMLHeader) then HeadViewer := CreateHeaderFooter; if Assigned(FOnPrintHTMLFooter) then FootViewer := CreateHeaderFooter; OrigTopPixels := TopPixels; OrigTopPixelsPrn := TopPixelsPrn; OrigHPrn := HPrn; OrigH := H; LastPrintMarginTop := FPrintMarginTop; while (FPage <= ToPage) and not Done do begin PrintList.SetYOffset(HTop-TopPixels); SetMapMode(DC, mm_AnIsotropic); SetWindowExtEx(DC, P2, P2, Nil); SetViewPortExtEx(DC, P1,P3, Nil); SetWindowOrgEx(DC, 0, 0, Nil); SelectClipRgn(DC, hrgnClip); if FPage >= FromPage then begin if (htPrintBackground in FOptions) then DoBackground2(Canvas, MLeft, TopPixels, W, H, PaintPanel.Color); MLeftSide := MLeft; end else MLeftSide := MLeft+3*W; {to print off page} repeat if Assigned(TablePartRec) then TablePart := TablePartRec.TablePart else TablePart := Normal; case TablePart of Normal: begin PrintList.Draw(Canvas, ARect, W, MLeftSide, 0, 0,0); WhiteoutArea(Canvas, PrintList.PageBottom-PrintList.YOff); end; DoHead: begin PrintList.SetYOffset(TablePartRec.PartStart-TopPixels); CRect := ARect; CRect.Bottom := CRect.Top+TablePartRec.PartHeight; hrgnClip1 := CreateRectRgn(MLeftPrn, TopPixelsPrn, WPrn+MLeftPrn+2, MulDiv(CRect.Bottom, P3, P2)); SelectClipRgn(DC, hrgnClip1); DeleteObject(hrgnClip1); PrintList.Draw(Canvas, CRect, W, MLeftSide, 0, 0,0); end; DoBody1, DoBody3: begin CRect := ARect; CRect.Top := PrintList.PageBottom-1-PrintList.YOff; PrintList.SetYOffset(TablePartRec.PartStart-CRect.top); PrintList.Draw(Canvas, CRect, W, MLeftSide+3*W, 0, 0,0); {off page} TablePartRec.TablePart := DoBody2; CRect.Bottom := PrintList.PageBottom-PrintList.YOff+1; hrgnClip1 := CreateRectRgn(MLeftPrn, MulDiv(CRect.Top, P3, P2), WPrn+MLeftPrn+2, MulDiv(CRect.Bottom, P3, P2)); SelectClipRgn(DC, hrgnClip1); DeleteObject(hrgnClip1); PrintList.Draw(Canvas, CRect, W, MLeftSide, 0, 0,0); {onpage} if not Assigned(TablePartRec) or not (TablePartRec.TablePart in [Normal]) then WhiteoutArea(Canvas, PrintList.PageBottom-PrintList.YOff); end; DoFoot: begin SavePageBottom := PrintList.PageBottom; CRect := ARect; CRect.Top := PrintList.PageBottom-PrintList.YOff; CRect.Bottom := CRect.Top + TablePartRec.PartHeight; hrgnClip1 := CreateRectRgn(MLeftPrn, MulDiv(CRect.Top, P3, P2), WPrn+MLeftPrn+2, MulDiv(CRect.Bottom, P3, P2)); SelectClipRgn(DC, hrgnClip1); DeleteObject(hrgnClip1); PrintList.SetYOffset(TablePartRec.PartStart-CRect.top); PrintList.Draw(Canvas, CRect, W, MLeftSide, 0, 0,0); PrintList.PageBottom := SavePageBottom; end; end; until not Assigned(TablePartRec) or (TablePartRec.TablePart in [Normal, DoHead, DoBody3]); {.$Region 'Do HeaderFooter'} SelectClipRgn(DC, 0); if (FPage <= ToPage) then {print header and footer} begin Canvas.Pen.Assign(savedPen); Align := SetTextAlign(DC, TA_Top or TA_Left or TA_NOUPDATECP); if Assigned(FOnPrintHeader) then begin SetWindowOrgEx(DC, 0, 0, Nil); FOnPrintHeader(Self, Canvas, FPage, ScaledPgWid, TopPixels, Done); end; if Assigned(FOnPrintFooter) then begin SetWindowOrgEx(DC, 0, -(TopPixels+H), Nil); FOnPrintFooter(Self, Canvas, FPage, ScaledPgWid, ScaledPgHt-(TopPixels+H), Done); end; DoHTMLHeaderFooter(False, FOnPrintHTMLHeader, HeadViewer); DoHTMLHeaderFooter(True, FOnPrintHTMLFooter, FootViewer); SetTextAlign(DC, Align); RestoreCanvasItems(Canvas); end; if FPrintMarginTop <> LastPrintMarginTop then begin DeltaMarginTop := FPrintMarginTop - SavePrintMarginTop; DeltaPixelsPrn:= Trunc(DeltaMarginTop/2.54 * P3); DeltaPixels := Trunc(DeltaMarginTop/2.54 * P2); TopPixels := OrigTopPixels + DeltaPixels; TopPixelsPrn := OrigTopPixelsPrn +DeltaPixelsPrn; HPrn := OrigHprn - DeltaPixelsPrn; H := OrigH - DeltaPixels; ARect := Rect(MLeft, TopPixels, W + MLeft, TopPixels + H); hrgnClip := CreateRectRgn(MLeftPrn, TopPixelsPrn, WPrn + MLeftPrn+2, TopPixelsPrn + HPrn); LastPrintMarginTop := FPrintMarginTop; end; {.$EndRegion} HTop := PrintList.PageBottom; Application.ProcessMessages; if Assigned(FOnPageEvent) then FOnPageEvent(Self, FPage, Done); if (HTop >= VPixels-MarginHeight) or (HTop <= OldTop) then {see if done or endless loop} Done := True; OldTop := HTop; if not Done and (FPage >= FromPage) and (FPage < ToPage) then NewPage; Inc(FPage); end; end; finally FreeAndNil(HeadViewer); FreeAndNil(FootViewer); if hRgnClip <> 0 then DeleteObject(hrgnClip); {$IFNDEF LCL} if not PrinterOpen then begin if (FromPage > FPage) then vwPrinter.Abort else vwPrinter.EndDoc; vwSetPrinter(OldPrinter); FreeAndNil(vwP); end; {$ELSE} if (FromPage > FPage) then Printer.Abort else Printer.EndDoc; vwP := nil; {$ENDIF} Dec(FPage); end; finally savedFont.Free ; savedPen.Free ; savedBrush.Free ; end; finally FPrintMarginTop := SavePrintMarginTop; PrintList.Free; end; end; procedure ThtmlViewer.OpenPrint; begin if not assigned(vwP) then begin {$IFNDEF LCL} vwP := TvwPrinter.Create; OldPrinter := vwSetPrinter(vwP); {$ELSE} vwP := Printer; {$ENDIF} end; end; procedure ThtmlViewer.ClosePrint; begin if Assigned(vwP) then begin {$IFNDEF LCL} if vwP.Printing then vwPrinter.EndDoc; vwSetPrinter(OldPrinter); FreeAndNil(vwP); {$ELSE} if vwP.Printing then Printer.EndDoc; vwP := nil; {$ENDIF} end; end; procedure ThtmlViewer.AbortPrint; begin if Assigned(vwP) then begin {$IFNDEF LCL} if vwP.Printing then vwPrinter.Abort; vwSetPrinter(OldPrinter); FreeAndNil(vwP); {$ELSE} if vwP.Printing then Printer.Abort; vwP := nil; {$ENDIF} end; end; function ThtmlViewer.NumPrinterPages: integer; var Dummy: double; begin Result := NumPrinterPages(Dummy); end; function ThtmlViewer.NumPrinterPages(var WidthRatio: double): integer; {$IFNDEF LCL} var MFPrinter: TMetaFilePrinter; begin MFPrinter := TMetaFilePrinter.Create(Nil); FOnPageEvent := Nil; try PrintPreview(MFPrinter, True); Result := MFPrinter.LastAvailablePage; WidthRatio := FWidthRatio; finally MFPrinter.Free; end; {$ELSE} begin {$ENDIF} end; {$IFNDEF LCL} function ThtmlViewer.PrintPreview(MFPrinter: TMetaFilePrinter; NoOutput: boolean = False): integer; var ARect, CRect : TRect; PrintList : TSectionList; P1, P2, P3 : integer; W, H : integer; HTop : integer; OldTop : integer; ScrollWidth : integer; Curs : integer; Done : boolean; DC : HDC; PrnDC : HDC; {metafile printer's DC} UpperLeftPagePoint, { these will contain Top/Left and Bottom/Right unprintable area} LowerRightPagePoint: TPoint; MLeft : integer; MLeftPrn : integer; MRightPrn : integer; MTopPrn : integer; MBottomPrn : integer; TopPixels : integer; TopPixelsPrn : integer; HPrn, WPrn : integer; hrgnClip : THandle; hrgnClip1 : THandle; hrgnClip2 : THandle; SavedFont : TFont; SavedPen : TPen; SavedBrush : TBrush; Align : integer; ScaledPgHt : integer; ScaledPgWid : integer; VPixels : integer; FootViewer, HeadViewer: ThtmlViewer; DeltaMarginTop: Double; SavePrintMarginTop: Double; DeltaPixelsPrn: Integer; DeltaPixels: Integer; OrigTopPixels: Integer; OrigTopPixelsPrn: Integer; OrigHprn: Integer; OrigH: Integer; LastPrintMarginTop: Double; SavePageBottom: Integer; TablePart: TablePartType; procedure Fill(Canvas: TCanvas); var BrushColor: TColor; begin BrushColor := Canvas.Brush.Color; Canvas.Brush.Color := $eeeeff; Canvas.Rectangle(MLeft, 0, W + MLeft+200, 4000); Canvas.Brush.Color := BrushColor; end; procedure SaveCanvasItems(Canvas: TCanvas); begin { preserve current settings of the Canvas} SavedPen.Assign(Canvas.Pen); SavedFont.Assign(Canvas.Font); SavedBrush.Assign(Canvas.Brush); end; procedure RestoreCanvasItems(Canvas: TCanvas); begin { restore initial Canvas settings } Canvas.Pen.Assign(SavedPen); Canvas.Font.Assign(SavedFont); Canvas.Brush.Assign(SavedBrush); end; procedure WhiteoutArea(Canvas: TCanvas; Y: integer); {White out excess printing. Y is top of the bottom area to be blanked.} begin Canvas.Brush.Color := clWhite; Canvas.Brush.Style := bsSolid; Canvas.Pen.Style := psSolid; Canvas.Pen.Color := clWhite; Canvas.Rectangle(MLeft, 0, W + MLeft+1, TopPixels-1); Canvas.Rectangle(MLeft, Y, W + MLeft+1, TopPixels+H+1); if (htPrintBackground in FOptions) and (Y-TopPixels < H) then begin {need to reprint background in whited out area} hrgnClip1 := CreateRectRgn(MLeftPrn, MulDiv(Y, P3, P2)+2, MLeftPrn+WPrn, TopPixelsPrn+HPrn); SelectClipRgn(Canvas.Handle, hrgnClip1); DeleteObject(hrgnClip1); DoBackground2(Canvas, MLeft, TopPixels, W, H, PaintPanel.Color); end; RestoreCanvasItems(Canvas); end; procedure DoHTMLHeaderFooter(Footer: boolean; Event: ThtmlPagePrinted; HFViewer: ThtmlViewer); var YOrigin, YOff, Ht: integer; HFCopyList: TSectionList; BRect: TRect; DocHeight, XL, XR: integer; begin if not Assigned(Event) then Exit; try XL := MLeft; XR := MLeft + W; Event(Self, HFViewer, FPage, PrintList.PageBottom > VPixels, XL, XR, Done); {call event handler} HFCopyList := TSectionList.CreateCopy(HFViewer.SectionList); try HFCopyList.Printing := True; HFCopyList.NoOutput := NoOutput; HFCopyList.ScaleX := fScaleX; HFCopyList.ScaleY := fScaleY; Curs := 0; DocHeight := HFCopyList.DoLogic(MFPrinter.Canvas, 0, XR-XL, 300, 0, ScrollWidth, Curs); if not Footer then begin {Header} YOrigin := 0; Ht := TopPixels; YOff := DocHeight-TopPixels; end else begin {Footer} YOrigin := -(TopPixels+H); Ht := IntMin(ScaledPgHt-(TopPixels+H), DocHeight); YOff := 0; end; SetWindowOrgEx(DC, 0, YOrigin, nil); HFViewer.DoBackground2(MFPrinter.Canvas, XL, -YOff, XR-XL, DocHeight, HFViewer.PaintPanel.Color); HFCopyList.SetYOffset(YOff); BRect := Rect(XL, 0, XR, Ht); HFCopyList.Draw(MFPrinter.Canvas, BRect, XR-XL, XL, 0, 0, 0); finally HFCopyList.Free; end; except end; end; begin Done := False; FootViewer := Nil; HeadViewer := Nil; TablePartRec := Nil; if Assigned(FOnPageEvent) then FOnPageEvent(Self, 0, Done); FPage := 0; Result := 0; if FProcessing or (SectionList.Count = 0) then Exit; PrintList := TSectionList.CreateCopy(SectionList); PrintList.SetYOffset(0); SavePrintMarginTop := FPrintMarginTop; try SavedPen := TPen.Create; SavedFont := TFont.Create; SavedBrush := TBrush.Create; try PrintList.Printing := True; PrintList.NoOutput := NoOutput; PrintList.SetBackground(clWhite); FPage := 1; hrgnClip := 0; hrgnClip2 := 0; try with MFPrinter do begin if DocumentTitle <> '' then Title := DocumentTitle; BeginDoc; DC := Canvas.Handle; PrnDC := PrinterDC; P3 := GetDeviceCaps(PrnDC, LOGPIXELSY); P1 := GetDeviceCaps(PrnDC, LOGPIXELSX); P2 := Round(Screen.PixelsPerInch * FPrintScale); fScaleX := 100.0/P3; fScaleY := 100.0/P1; PrintList.ScaleX := fScaleX; PrintList.ScaleY := fScaleY; SetMapMode(DC, mm_AnIsotropic); //P1 := GetDeviceCaps(PrnDC, LOGPIXELSX); SetWindowExtEx(DC, P2, P2, nil); SetViewPortExtEx(DC, P1, P3, nil); { calculate the amount of space that is non-printable } { get PHYSICAL page width } LowerRightPagePoint.X := GetDeviceCaps(PrnDC, PhysicalWidth); LowerRightPagePoint.Y := GetDeviceCaps(PrnDC, PhysicalHeight); { now compute a complete unprintable area rectangle (composed of 2*width, 2*height) in pixels...} with LowerRightPagePoint do begin Y := Y - MFPrinter.PageHeight; X := X - MFPrinter.PageWidth; end; { get upper left physical offset for the printer... -> printable area <> paper size } UpperLeftPagePoint.X := GetDeviceCaps(PrnDC, PhysicalOffsetX); UpperLeftPagePoint.Y := GetDeviceCaps(PrnDC, PhysicalOffsetY); { now that we know the TOP and LEFT offset we finally can compute the BOTTOM and RIGHT offset: } with LowerRightPagePoint do begin X := X - UpperLeftPagePoint.X; { we don't want to have negative values} if X < 0 then X := 0; { assume no right printing offset } Y := Y - UpperLeftPagePoint.Y; { we don't want to have negative values} if Y < 0 then Y := 0; { assume no bottom printing offset } end; { which results in LowerRightPoint containing the BOTTOM and RIGHT unprintable area offset; using these we modify the (logical, true) borders...} MLeftPrn := Trunc(FPrintMarginLeft/2.54 * P1); MLeftPrn := MLeftPrn - UpperLeftPagePoint.X; { subtract physical offset } MLeft := MulDiv(MLeftPrn, P2, P1); MRightPrn := Trunc(FPrintMarginRight/2.54 * P1); MRightPrn := MRightPrn - LowerRightPagePoint.X; { subtract physical offset } WPrn := PageWidth - (MLeftPrn + MRightPrn); W := MulDiv(WPrn, P2, P1); MTopPrn := Trunc(FPrintMarginTop/2.54 * P3); MTopPrn := MTopPrn - UpperLeftPagePoint.Y; { subtract physical offset } MBottomPrn := Trunc(FPrintMarginBottom/2.54 * P3); MBottomPrn := MBottomPrn - LowerRightPagePoint.Y; { subtract physical offset } TopPixelsPrn := MTopPrn; TopPixels := MulDiv(TopPixelsPrn, P2, P3); HPrn := PageHeight-(MTopPrn+MBottomPrn); H := MulDiv(HPrn, P2, P3); {scaled pageHeight} HTop := 0; OldTop := 0; Curs := 0; VPixels := PrintList.DoLogic(Canvas, 0, W, H, 0, ScrollWidth, Curs); FWidthRatio := ScrollWidth/W; if FWidthRatio > 1.0 then FWidthRatio := Round(P2*FWidthRatio +0.5)/P2; ScaledPgHt := MulDiv(PageHeight, P2, P3); ScaledPgWid := MulDiv(PageWidth, P2, P3); {This one clips to the allowable print region so that the preview is limited to that region also} hrgnClip2 := CreateRectRgn(0, 0, MFPrinter.PageWidth, MFPrinter.PageHeight); {This one is primarily used to clip the top and bottom margins to insure nothing is output there. It's also constrained to the print region in case the margins are misadjusted.} hrgnClip := CreateRectRgn(MLeftPrn, IntMax(0, TopPixelsPrn), IntMin(MFPrinter.PageWidth, WPrn+MLeftPrn+2), IntMin(MFPrinter.PageHeight, TopPixelsPrn+HPrn)); Application.ProcessMessages; if Assigned(FOnPageEvent) then FOnPageEvent(Self, FPage, Done); ARect := Rect(MLeft, TopPixels, W + MLeft, TopPixels + H); if Assigned(FOnPrintHTMLHeader) then HeadViewer := CreateHeaderFooter; if Assigned(FOnPrintHTMLFooter) then FootViewer := CreateHeaderFooter; OrigTopPixels := TopPixels; OrigTopPixelsPrn := TopPixelsPrn; OrigHPrn := HPrn; OrigH := H; LastPrintMarginTop := FPrintMarginTop; while not Done do begin PrintList.SetYOffset(HTop-TopPixels); {next line is necessary because the canvas changes with each new page } DC := Canvas.Handle; SaveCanvasItems(Canvas); SetMapMode(DC, mm_AnIsotropic); SetWindowExtEx(DC, P2, P2, nil); SetViewPortExtEx(DC, P1, P3, nil); SetWindowOrgEx(DC, 0, 0, nil); SelectClipRgn(DC, hrgnClip); if (htPrintBackground in FOptions) then DoBackground2(Canvas, MLeft, TopPixels, W, H, PaintPanel.Color); repeat if Assigned(TablePartRec) then TablePart := TablePartRec.TablePart else TablePart := Normal; case TablePart of Normal: begin PrintList.Draw(Canvas, ARect, W, MLeft, 0, 0,0); WhiteoutArea(Canvas, PrintList.PageBottom-PrintList.YOff); end; DoHead: begin PrintList.SetYOffset(TablePartRec.PartStart-TopPixels); CRect := ARect; CRect.Bottom := CRect.Top+TablePartRec.PartHeight; hrgnClip1 := CreateRectRgn(MLeftPrn, TopPixelsPrn, WPrn+MLeftPrn+2, MulDiv(CRect.Bottom, P3, P2)); SelectClipRgn(DC, hrgnClip1); DeleteObject(hrgnClip1); PrintList.Draw(Canvas, CRect, W, MLeft, 0, 0,0); end; DoBody1, DoBody3: begin CRect := ARect; CRect.Top := PrintList.PageBottom-1-PrintList.YOff; PrintList.SetYOffset(TablePartRec.PartStart-CRect.top); PrintList.Draw(Canvas, CRect, W, MLeft+3*W, 0, 0,0); {off page} TablePartRec.TablePart := DoBody2; CRect.Bottom := PrintList.PageBottom-PrintList.YOff+1; hrgnClip1 := CreateRectRgn(MLeftPrn, MulDiv(CRect.Top, P3, P2), WPrn+MLeftPrn+2, MulDiv(CRect.Bottom, P3, P2)); SelectClipRgn(DC, hrgnClip1); DeleteObject(hrgnClip1); PrintList.Draw(Canvas, CRect, W, MLeft, 0, 0,0); {onpage} if not Assigned(TablePartRec) or not (TablePartRec.TablePart in [Normal]) then WhiteoutArea(Canvas, PrintList.PageBottom-PrintList.YOff); end; DoFoot: begin SavePageBottom := PrintList.PageBottom; CRect := ARect; CRect.Top := PrintList.PageBottom-PrintList.YOff; CRect.Bottom := CRect.Top + TablePartRec.PartHeight; hrgnClip1 := CreateRectRgn(MLeftPrn, MulDiv(CRect.Top, P3, P2), WPrn+MLeftPrn+2, MulDiv(CRect.Bottom, P3, P2)); SelectClipRgn(DC, hrgnClip1); DeleteObject(hrgnClip1); PrintList.SetYOffset(TablePartRec.PartStart-CRect.top); PrintList.Draw(Canvas, CRect, W, MLeft, 0, 0,0); PrintList.PageBottom := SavePageBottom; end; end; until not Assigned(TablePartRec) or (TablePartRec.TablePart in [Normal, DoHead, DoBody3]); {.$Region 'HeaderFooter'} SelectClipRgn(DC, 0); Align := SetTextAlign(DC, TA_Top or TA_Left or TA_NOUPDATECP); SelectClipRgn(DC, hrgnClip2); if Assigned(FOnPrintHeader) then begin SetWindowOrgEx(DC, 0, 0, Nil); FOnPrintHeader(Self, Canvas, FPage, ScaledPgWid, TopPixels, Done); end; if Assigned(FOnPrintFooter) then begin SetWindowOrgEx(DC, 0, -(TopPixels+H), nil); FOnPrintFooter(Self, Canvas, FPage, ScaledPgWid, ScaledPgHt-(TopPixels+H), Done); end; DoHTMLHeaderFooter(False, FOnPrintHTMLHeader, HeadViewer); DoHTMLHeaderFooter(True, FOnPrintHTMLFooter, FootViewer); SetTextAlign(DC, Align); SelectClipRgn(DC, 0); if FPrintMarginTop <> LastPrintMarginTop then begin DeltaMarginTop := FPrintMarginTop - SavePrintMarginTop; DeltaPixelsPrn:= Trunc(DeltaMarginTop/2.54 * P3); DeltaPixels := Trunc(DeltaMarginTop/2.54 * P2); TopPixels := OrigTopPixels + DeltaPixels; TopPixelsPrn := OrigTopPixelsPrn +DeltaPixelsPrn; HPrn := OrigHprn - DeltaPixelsPrn; H := OrigH - DeltaPixels; ARect := Rect(MLeft, TopPixels, W + MLeft, TopPixels + H); hrgnClip := CreateRectRgn(MLeftPrn, IntMax(0, TopPixelsPrn), IntMin(MFPrinter.PageWidth, WPrn+MLeftPrn+2), IntMin(MFPrinter.PageHeight, TopPixelsPrn+HPrn)); LastPrintMarginTop := FPrintMarginTop; end; {.$EndRegion} HTop := PrintList.PageBottom; Application.ProcessMessages; if Assigned(FOnPageEvent) then FOnPageEvent(Self, FPage, Done); if (HTop >= VPixels-MarginHeight) or (HTop <= OldTop) then {see if done or endless loop} Done := True; OldTop := HTop; if not Done then NewPage; Inc(FPage); end; EndDoc; end; finally FreeAndNil(HeadViewer); FreeAndNil(FootViewer); if hRgnClip <> 0 then DeleteObject(hrgnClip); if hRgnClip2 <> 0 then DeleteObject(hrgnClip2); Dec(FPage); end; finally SavedPen.Free; SavedFont.Free; SavedBrush.Free; end; finally FPrintMarginTop := SavePrintMarginTop; PrintList.Free; Result := FPage; end; end; {$ENDIF} procedure ThtmlViewer.BackgroundChange(Sender: TObject); begin PaintPanel.Color := (Sender as TSectionList).Background or PalRelative; end; procedure ThtmlViewer.SetOnBitmapRequest(Handler: TGetBitmapEvent); begin FOnBitmapRequest := Handler; FSectionList.GetBitmap := Handler; end; procedure ThtmlViewer.SetOnImageRequest(Handler: TGetImageEvent); begin FOnImageRequest := Handler; FSectionList.GetImage := Handler; end; procedure ThtmlViewer.SetOnExpandName(Handler: TExpandNameEvent); begin FOnExpandName := Handler; FSectionList.ExpandName := Handler; end; procedure ThtmlViewer.SetOnScript(Handler: TScriptEvent); begin FOnScript := Handler; FSectionList.ScriptEvent := Handler; end; procedure ThtmlViewer.SetOnFileBrowse(Handler: TFileBrowseEvent); begin FOnFileBrowse := Handler; FSectionList.FileBrowse := Handler; end; procedure ThtmlViewer.SetOnObjectClick(Handler: TObjectClickEvent); begin FOnObjectClick := Handler; FSectionList.ObjectClick := Handler; end; procedure ThtmlViewer.SetOnObjectFocus(Handler: ThtObjectEvent); begin FOnObjectFocus := Handler; FSectionList.ObjectFocus := Handler; end; procedure ThtmlViewer.SetOnObjectBlur(Handler: ThtObjectEvent); begin FOnObjectBlur := Handler; FSectionList.ObjectBlur := Handler; end; procedure ThtmlViewer.SetOnObjectChange(Handler: ThtObjectEvent); begin FOnObjectChange := Handler; FSectionList.ObjectChange := Handler; end; procedure ThtmlViewer.SetOnPanelCreate(Handler: TPanelCreateEvent); begin FOnPanelCreate := Handler; FSectionList.PanelCreateEvent := Handler; end; procedure ThtmlViewer.SetOnPanelDestroy(Handler: TPanelDestroyEvent); begin FOnPanelDestroy := Handler; FSectionList.PanelDestroyEvent := Handler; end; procedure ThtmlViewer.SetOnPanelPrint(Handler: TPanelPrintEvent); begin FOnPanelPrint := Handler; FSectionList.PanelPrintEvent := Handler; end; procedure ThtmlViewer.SetOnFormSubmit(Handler: TFormSubmitEvent); begin FOnFormSubmit := Handler; if Assigned(Handler) then FSectionList.SubmitForm := SubmitForm else FSectionList.SubmitForm := Nil; end; procedure ThtmlViewer.SubmitForm(Sender: TObject; const Action, Target, EncType, Method: string; Results: TStringList); begin if Assigned(FOnFormSubmit) then begin FAction := Action; FMethod := Method; FFormTarget := Target; FEncType:= EncType; FStringList := Results; PostMessage(Handle, wm_FormSubmit, 0, 0); end; end; procedure ThtmlViewer.WMFormSubmit(var Message: TMessage); begin FOnFormSubmit(Self, FAction, FFormTarget, FEncType, FMethod, FStringList); end; {user disposes of the TStringList} function ThtmlViewer.Find(const S: WideString; MatchCase: boolean): boolean; begin Result := FindEx(S, MatchCase, False); end; function ThtmlViewer.FindEx(const S: WideString; MatchCase, Reverse: boolean): boolean; var Curs: integer; X: integer; Y, Pos: integer; S1: WideString; begin Result := False; if S = '' then Exit; with FSectionList do begin if MatchCase then S1 := S else S1 := WideLowerCase1(S); if Reverse then Curs := FindStringR(CaretPos, S1, MatchCase) else Curs := FindString(CaretPos, S1, MatchCase); if Curs >= 0 then begin Result := True; SelB := Curs; SelE := Curs+Length(S); if Reverse then CaretPos := SelB else CaretPos := SelE; if CursorToXY(PaintPanel.Canvas, Curs, X, Y) then begin Pos := VScrollBarPosition; if (Y < Pos) or (Y > Pos +ClientHeight-20) then VScrollBarPosition := (Y - ClientHeight div 2); Pos := HScrollBarPosition; if (X < Pos) or (X > Pos +ClientWidth-50) then HScrollBarPosition := (X - ClientWidth div 2); Invalidate; end; end; end; end; procedure ThtmlViewer.FormControlEnterEvent(Sender: TObject); var Y, Pos: integer; begin if Sender is TFormControlObj then begin Y := TFormControlObj(Sender).YValue; Pos := VScrollBarPosition; if (Y < Pos) or (Y > Pos +ClientHeight-20) then begin VScrollBarPosition := (Y - ClientHeight div 2); Invalidate; end; end else if Sender is TFontObj and not NoJump then begin Y := TFontObj(Sender).YValue; Pos := VScrollBarPosition; if (Y < Pos) then VScrollBarPosition := Y else if (Y > Pos +ClientHeight-30) then VScrollBarPosition := (Y - ClientHeight div 2); Invalidate; end end; procedure ThtmlViewer.SelectAll; begin with FSectionList do if (Count > 0) and not FNoSelect then begin SelB := 0; with TSectionBase(Items[Count-1]) do SelE := StartCurs + Len; Invalidate; end; end; {----------------ThtmlViewer.InitLoad} procedure ThtmlViewer.InitLoad; begin if not Assigned(FSectionList.BitmapList) then begin FSectionList.BitmapList := TStringBitmapList.Create; FSectionList.BitmapList.Sorted := True; FSectionList.BitmapList.SetCacheCount(FImageCacheCount); LocalBitmapList := True; end; FSectionList.Clear; UpdateImageCache; FSectionList.SetFonts(FFontName, FPreFontName, FFontSize, FFontColor, FHotSpotColor, FVisitedColor, FOverColor, FBackground, htOverLinksActive in FOptions, not (htNoLinkUnderline in FOptions), FCharSet, FMarginHeight, FMarginWidth); end; {----------------ThtmlViewer.Clear} procedure ThtmlViewer.Clear; {Note: because of Frames do not clear history list here} begin if FProcessing then Exit; HTMLTimer.Enabled := False; FSectionList.Clear; if LocalBitmapList then FSectionList.BitmapList.Clear; FSectionList.SetFonts(FFontName, FPreFontName, FFontSize, FFontColor, FHotSpotColor, FVisitedColor, FOverColor, FBackground, htOverLinksActive in FOptions, not (htNoLinkUnderline in FOptions), FCharSet, FMarginHeight, FMarginWidth); FBase := ''; FBaseEx := ''; FBaseTarget := ''; FTitle := ''; VScrollBar.Max := 0; VScrollBar.Visible := False; VScrollBar.Height := PaintPanel.Height; HScrollBar.Visible := False; CaretPos := 0; Sel1 := -1; if Assigned(FOnSoundRequest) then FOnSoundRequest(Self, '', 0, True); Invalidate; end; procedure ThtmlViewer.PaintWindow(DC: HDC); begin PaintPanel.RePaint; {$IFNDEF LCL} BorderPanel.RePaint; VScrollbar.RePaint; //Don't need this anymore (and causes HScrollbar.RePaint; // endless loop with GTK2). {$ENDIF} end; procedure ThtmlViewer.CopyToClipboard; const StartFrag = ''; EndFrag = ''; DocType = ''#13#10; var Leng: integer; StSrc, EnSrc: integer; HTML: string; format : UINT; {$IFNDEF LCL} procedure copyFormatToClipBoard(const source: string; format : UINT); {$ELSE} //changed to var to use with AddFormat below procedure copyFormatToClipBoard(var source: string; format : UINT); {$ENDIF} // Put SOURCE on the clipboard, using FORMAT as the clipboard format // Based on http://www.lorriman.com/programming/cf_html.html var gMem: HGLOBAL; lp: pchar; begin clipboard.Open; try {$IFNDEF LCL} //an extra "1" for the null terminator gMem := globalalloc(GMEM_DDESHARE + GMEM_MOVEABLE, length(source)+1); lp := globallock(gMem); copymemory(lp, pchar(source), length(source)+1); globalunlock(gMem); setClipboarddata(format, gMem); {$ELSE} clipboard.AddFormat(format, source[1], Length(source)); {$ENDIF} finally clipboard.Close; end end; function GetHeader(const HTML: string): string; const Version = 'Version:1.0'#13#10; StartHTML = 'StartHTML:'; EndHTML = 'EndHTML:'; StartFragment = 'StartFragment:'; EndFragment = 'EndFragment:'; SourceURL = 'SourceURL:'; NumberLengthAndCR = 10; // Let the compiler determine the description length. PreliminaryLength = Length(Version) + Length(StartHTML) + Length(EndHTML) + Length(StartFragment) + Length(EndFragment) + 4 * NumberLengthAndCR + 2; {2 for last CRLF} var URLString: string; StartHTMLIndex, EndHTMLIndex, StartFragmentIndex, EndFragmentIndex: integer; begin if CurrentFile = '' then UrlString := SourceURL+'unsaved:///ThtmlViewer.htm' else if Pos('://', CurrentFile) > 0 then URLString := SourceURL+CurrentFile {already has protocol} else URLString := SourceURL+'file://'+CurrentFile; StartHTMLIndex := PreliminaryLength + Length(URLString); EndHTMLIndex := StartHTMLIndex + Length(HTML); StartFragmentIndex := StartHTMLIndex + Pos(StartFrag, HTML) + Length(StartFrag)-1; EndFragmentIndex := StartHTMLIndex + Pos(EndFrag, HTML)-1; Result := Version + SysUtils.Format('%s%.8d', [StartHTML, StartHTMLIndex]) + #13#10 + SysUtils.Format('%s%.8d', [EndHTML, EndHTMLIndex]) + #13#10 + SysUtils.Format('%s%.8d', [StartFragment, StartFragmentIndex]) + #13#10 + SysUtils.Format('%s%.8d', [EndFragment, EndFragmentIndex]) + #13#10 + URLString + #13#10; end; function Truncate(const S: string): string; var I: integer; begin I := Pos(EndFrag, S); Result := S; if I > 0 then Result := Copy(Result, 1, I+Length(EndFrag)-1); end; procedure RemoveTag(const Tag: string); {remove all the tags that look like "" } var I: integer; L: string; C: char; begin L := Lowercase(HTML); I := Pos(Tag, L); while (I > 0) do begin Delete(HTML, I, Length(Tag)); repeat if I <= Length(HTML) then C := HTML[I] else C := #0; Delete(HTML, I, 1); until C in ['>', #0]; L := Lowercase(HTML); I := Pos(Tag, L); end; end; procedure MessUp(const S: string); var I: integer; L: string; begin L := Lowercase(HTML); I := Pos(S, L); while (I > 0) do begin Delete(HTML, I, 1); L := Lowercase(HTML); I := Pos(S, L); end; end; function ConvertToUTF8(const S: string): string; var Len, Len1: integer; WS: WideString; begin {$IFNDEF LCL} if CodePage = CP_UTF8 then begin Result := S; Exit; End; Len := Length(S); SetLength(WS, Len); Len := MultibyteToWideChar(CodePage, 0, PChar(S), Len, PWideChar(WS), Len); Len1 := 4*Len; SetLength(Result, Len1); Len1 := WideCharToMultibyte(CP_UTF8, 0, PWideChar(WS), Len, PChar(Result), Len1, Nil, Nil); SetLength(Result, Len1); {$ELSE} Result := AnsiToUtf8(S); {$ENDIF} end; procedure InsertDefaultFontInfo; var I: integer; S, L: string; HeadFound: boolean; begin L := LowerCase(HTML); I := Pos('', L); HeadFound := I > 0; if not HeadFound then I := Pos('', L); if I <= 0 then I := 1; S := ''; if not HeadFound then S := ''+S+''; Insert(S, HTML, I); end; procedure BackupToContent; var C: char; I: integer; procedure GetC; {reads characters backwards} begin if I-1 > StSrc then begin Dec(I); C := HTML[I]; end else C := #0; end; begin I := EnSrc; repeat repeat {skip past white space} GetC; until C in [#0, '!'..#255]; if C = '>' then repeat {read thru a tag} repeat GetC; until C in [#0, '<']; GetC; until C <> '>'; until C in [#0, '!'..#255]; {until found some content} if C = #0 then Dec(I); HTML := Copy(HTML, 1, I); {truncate the tags} end; begin Leng := FSectionList.GetSelLength; if Leng = 0 then Exit; FSectionList.CopyToClipboardA(Leng+1); HTML := DocumentSource; StSrc := FindSourcePos(FSectionList.SelB)+1; EnSrc := FindSourcePos(FSectionList.SelE); if EnSrc < 0 then {check to see if end selection is at end of document} begin EnSrc := Length(HTML); if HTML[EnSrc] = '>' then begin HTML := HTML + ' '; Inc(EnSrc); end; end else EnSrc := EnSrc + 1; {Truncate beyond EnSrc} HTML := Copy(HTML, 1, EnSrc-1); {Also remove any tags on the end} BackupToContent; {insert the StartFrag string} Insert(StartFrag, HTML, StSrc); {Remove all Meta tags, in particular the ones that specify language, but others seem to cause problems also} RemoveTag(' in preparation to having one added} RemoveTag(' 0 then begin SetString(Result, Nil, Len); FSectionList.GetSelTextBuf(Pointer(Result), Len+1); end else Result := ''; end; function ThtmlViewer.GetSelLength: integer; begin with FSectionList do if FCaretPos = SelB then Result := SelE - SelB else Result := SelB - SelE; end; procedure ThtmlViewer.SetSelLength(Value: integer); begin with FSectionList do begin if Value >= 0 then begin SelB := FCaretPos; SelE := FCaretPos + Value; end else begin SelE := FCaretPos; SelB := FCaretPos + Value; end; Invalidate; end; end; procedure ThtmlViewer.SetSelStart(Value: integer); begin with FSectionList do begin FCaretPos := Value; SelB := Value; SelE := Value; Invalidate; end; end; procedure ThtmlViewer.SetNoSelect(Value: boolean); begin if Value <> FNoSelect then begin FNoSelect := Value; if Value = True then begin FSectionList.SelB := -1; FSectionList.SelE := -1; RePaint; end; end; end; procedure ThtmlViewer.UpdateImageCache; begin FSectionList.BitmapList.BumpAndCheck; end; procedure ThtmlViewer.SetImageCacheCount(Value: integer); begin Value := IntMax(0, Value); Value := IntMin(20, Value); if Value <> FImageCacheCount then begin FImageCacheCount := Value; if Assigned(FSectionList.BitmapList) then FSectionList.BitmapList.SetCacheCount(FImageCacheCount); end; end; procedure ThtmlViewer.SetStringBitmapList(BitmapList: TStringBitmapList); begin FSectionList.BitmapList := BitmapList; LocalBitmapList := False; end; procedure ThtmlViewer.DrawBorder; begin //Focused may not work with control on all widgetsets. if (Focused and (FBorderStyle = htFocused)) or (FBorderStyle = htSingle) or (csDesigning in ComponentState) then {$IFNDEF LCL} BorderPanel.BorderStyle := bsSingle else BorderPanel.BorderStyle := bsNone; {$ELSE} //Setting viewer's BorderStyle currently does not work. // inherited BorderStyle := bsSingle //else // inherited BorderStyle := bsNone; {$ENDIF} end; procedure ThtmlViewer.DoEnter; begin inherited DoEnter; DrawBorder; end; procedure ThtmlViewer.DoExit; begin inherited DoExit; DrawBorder; end; procedure ThtmlViewer.SetScrollBars(Value: TScrollStyle); begin if (Value <> FScrollBars) then begin FScrollBars := Value; if not (csLoading in ComponentState) and HandleAllocated then begin SetProcessing(True); try DoLogic; finally SetProcessing(False); end; Invalidate; end; end; end; {----------------ThtmlViewer.Reload} procedure ThtmlViewer.Reload; {reload the last file} var Pos: integer; begin if FCurrentFile <> '' then begin Pos := Position; if FCurrentFileType = HTMLType then LoadFromFile(FCurrentFile) else if FCurrentFileType = TextType then LoadTextFile(FCurrentFile) else LoadImageFile(FCurrentFile); Position := Pos; end; end; {----------------ThtmlViewer.GetOurPalette:} function ThtmlViewer.GetOurPalette: HPalette; begin if ColorBits = 8 then Result := CopyPalette(ThePalette) else Result := 0; end; {----------------ThtmlViewer.SetOurPalette} procedure ThtmlViewer.SetOurPalette(Value: HPalette); var NewPalette: HPalette; begin if (Value <> 0) and (ColorBits = 8) then begin NewPalette := CopyPalette(Value); if NewPalette <> 0 then begin if ThePalette <> 0 then DeleteObject(ThePalette); ThePalette := NewPalette; if FDither then SetGlobalPalette(ThePalette); end; end; end; {----------------ThtmlViewer.SetDither} procedure ThtmlViewer.SetDither(Value: boolean); begin if (Value <> FDither) and (ColorBits = 8) then begin FDither := Value; if Value then SetGlobalPalette(ThePalette) else SetGLobalPalette(0); end; end; procedure ThtmlViewer.SetCaretPos(Value: integer); begin if Value >= 0 then begin FCaretPos := Value; end; end; function ThtmlViewer.FindSourcePos(DisplayPos: integer): integer; begin Result := FSectionList.FindSourcePos(DisplayPos); end; function ThtmlViewer.FindDisplayPos(SourcePos: integer; Prev: boolean): integer; begin Result := FSectionList.FindDocPos(SourcePos, Prev); end; function ThtmlViewer.DisplayPosToXy(DisplayPos: integer; var X, Y: integer): boolean; begin Result := FSectionList.CursorToXY(PaintPanel.Canvas, DisplayPos, X, integer(Y)); {integer() req'd for delphi 2} end; {----------------ThtmlViewer.SetProcessing} procedure ThtmlViewer.SetProcessing(Value: boolean); begin if FProcessing <> Value then begin FProcessing := Value; if Assigned(FOnProcessing) and not (csLoading in ComponentState) then FOnProcessing(Self, FProcessing); end; end; procedure THTMLViewer.SetServerRoot(Value: string); begin Value := Trim(Value); if (Length(Value) >= 1) and (Value[Length(Value)] = '\') then SetLength(Value, Length(Value)-1); FServerRoot := Value; end; procedure THTMLViewer.HandleMeta(Sender: TObject; const HttpEq, Name, Content: string); var DelTime, I: integer; begin if Assigned(FOnMeta) then FOnMeta(Self, HttpEq, Name, Content); if Assigned(FOnMetaRefresh) then if CompareText(Lowercase(HttpEq), 'refresh') = 0 then begin I := Pos(';', Content); if I > 0 then DelTime := StrToIntDef(copy(Content, 1, I-1), -1) else DelTime := StrToIntDef(Content, -1); if DelTime < 0 then Exit else if DelTime = 0 then DelTime := 1; I := Pos('url=', Lowercase(Content)); if I > 0 then FRefreshURL := Copy(Content, I+4, Length(Content)-I-3) else FRefreshURL := ''; FRefreshDelay := DelTime; end; end; procedure THTMLViewer.SetOptions(Value: ThtmlViewerOptions); begin if Value <> FOptions then begin FOptions := Value; if Assigned(FSectionList) then with FSectionList do begin LinksActive := htOverLinksActive in FOptions; PrintTableBackground := (htPrintTableBackground in FOptions) or (htPrintBackground in FOptions); PrintBackground := htPrintBackground in FOptions; PrintMonoBlack := htPrintMonochromeBlack in FOptions; ShowDummyCaret := htShowDummyCaret in FOptions; end; end; end; procedure ThtmlViewer.Repaint; var I: integer; begin for I := 0 to FormControlList.count-1 do with TFormControlObj(FormControlList.Items[I]) do if Assigned(TheControl) then TheControl.Hide; {$IFNDEF LCL} BorderPanel.BorderStyle := bsNone; {$ELSE} //inherited BorderStyle := bsNone; {$ENDIF} inherited Repaint; end; function THTMLViewer.GetDragDrop: TDragDropEvent; begin Result := FOnDragDrop; end; procedure THTMLViewer.SetDragDrop(const Value: TDragDropEvent); begin FOnDragDrop := Value; if Assigned(Value) then PaintPanel.OnDragDrop := HTMLDragDrop else PaintPanel.OnDragDrop := Nil; end; procedure THTMLViewer.HTMLDragDrop(Sender, Source: TObject; X, Y: Integer); begin if Assigned(FOnDragDrop) then FOnDragDrop(Self, Source, X, Y); end; function THTMLViewer.GetDragOver: TDragOverEvent; begin Result := FOnDragOver; end; procedure THTMLViewer.SetDragOver(const Value: TDragOverEvent); begin FOnDragOver := Value; if Assigned(Value) then PaintPanel.OnDragOver := HTMLDragOver else PaintPanel.OnDragOver := Nil; end; procedure THTMLViewer.HTMLDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin if Assigned(FOnDragOver) then FOnDragOver(Self, Source, X, Y, State, Accept); end; function THTMLViewer.GetFormData: TFreeList; begin if Assigned(SectionList) then Result := SectionList.GetFormControlData else Result := Nil; end; procedure THTMLViewer.SetFormData(T: TFreeList); begin if Assigned(SectionList) and Assigned(T) then with SectionList do begin ObjectClick := Nil; SetFormControlData(T); ObjectClick := FOnObjectClick; end; end; procedure THTMLViewer.ReplaceImage(const NameID: string; NewImage: TStream); var I: integer; OldPos: integer; begin if FNameList.Find(NameID, I) then if FNameList.Objects[I] is TImageObj then begin TImageObj(FNameList.Objects[I]).ReplaceImage(NewImage); if not TImageObj(FNameList.Objects[I]).ImageKnown then if FSectionList.Count > 0 then begin FSectionList.GetBackgroundBitmap; {load any background bitmap} OldPos := Position; DoLogic; Position := OldPos; end; end; end; function THTMLViewer.GetIDControl(const ID: string): TObject; var I: integer; Obj: TObject; begin Result := Nil; with FSectionList.IDNameList do if Find(ID, I) then begin Obj := Objects[I]; if (Obj is TFormControlObj) then begin if (Obj is THiddenFormControlObj) then Result := Obj else Result := TFormControlObj(Obj).TheControl; end else if (Obj is TImageObj) then Result := Obj; end; end; function THTMLViewer.GetIDDisplay(const ID: string): boolean; var I: integer; Obj: TObject; begin Result := False; with FSectionList.IDNameList do if Find(ID, I) then begin Obj := Objects[I]; if (Obj is TBlock) then Result := not TBlock(Obj).DisplayNone; end; end; procedure THTMLViewer.SetIDDisplay(const ID: string; Value: boolean); var I: integer; Obj: TObject; begin with FSectionList.IDNameList do if Find(ID, I) then begin Obj := Objects[I]; if (Obj is TBlock) and (TBlock(Obj).DisplayNone = Value) then begin FSectionList.HideControls; TBlock(Obj).DisplayNone := not Value; end; end; end; procedure THTMLViewer.SetPrintScale(Value: double); begin If Value > 4.0 then FPrintScale := 4.0 else if Value < 0.25 then FPrintScale := 0.25 else FPrintScale := Value; end; procedure THTMLViewer.Reformat; var Pt: TPoint; begin Layout; Update; GetCursorPos(Pt); SetCursorPos(Pt.X, Pt.Y); {trigger a mousemove to keep cursor correct} end; procedure THTMLViewer.htProgressInit; begin if Assigned(FOnProgress) then FOnProgress(Self, psStarting, 0); end; procedure THTMLViewer.htProgress(Percent: Integer); begin if Assigned(FOnProgress) then FOnProgress(Self, psRunning, Percent); end; procedure THTMLViewer.htProgressEnd; begin if Assigned(FOnProgress) then FOnProgress(Self, psEnding, 100); end; {----------------TPaintPanel.CreateIt} constructor TPaintPanel.CreateIt(AOwner: TComponent; Viewer: ThtmlViewer); begin inherited Create(AOwner); FViewer := Viewer; end; {----------------TPaintPanel.Paint} procedure TPaintPanel.Paint; var MemDC: HDC; ABitmap: HBitmap; ARect: TRect; OldPal: HPalette; begin if FViewer.DontDraw or (Canvas2 <> Nil) then Exit; FViewer.DrawBorder; OldPal := 0; Canvas.Font := Font; Canvas.Brush.Color := Color; ARect := Canvas.ClipRect; Canvas2 := TCanvas.Create; {paint on a memory DC} try MemDC := CreateCompatibleDC(Canvas.Handle); ABitmap := 0; try with ARect do begin ABitmap := CreateCompatibleBitmap(Canvas.Handle, Right-Left, Bottom-Top); if (ABitmap = 0) and (Right-Left + Bottom-Top <> 0) then raise EOutOfResources.Create('Out of Resources'); try SelectObject(MemDC, ABitmap); SetWindowOrgEx(memDC, Left, Top, Nil); Canvas2.Handle := MemDC; DoBackground(Canvas2); if Assigned(FOnPaint) then FOnPaint(Self); OldPal := SelectPalette(Canvas.Handle, ThePalette, False); RealizePalette(Canvas.Handle); BitBlt(Canvas.Handle, Left, Top, Right-Left, Bottom-Top, MemDC, Left, Top, SrcCopy); finally if OldPal <> 0 then SelectPalette(MemDC, OldPal, False); Canvas2.Handle := 0; end; end; finally DeleteDC(MemDC); DeleteObject(ABitmap); end; finally FreeAndNil(Canvas2); end; end; procedure TPaintPanel.DoBackground(ACanvas: TCanvas); var ARect: TRect; Image: TGpObject; Mask, NewBitmap, NewMask: TBitmap; PRec: PtPositionRec; BW, BH, X, Y, X2, Y2, IW, IH, XOff, YOff: integer; AniGif: TGifImage; begin with FViewer do begin if FSectionList.Printing then Exit; {no background} // ARect := Canvas.ClipRect; //bug? get invalid DC with Carbon ARect := ACanvas.ClipRect; Image := FSectionList.BackgroundBitmap; if FSectionList.ShowImages and Assigned(Image) then begin Mask := FSectionList.BackgroundMask; BW := GetImageWidth(Image); BH := GetImageHeight(Image); PRec := FSectionList.BackgroundPRec; BGFixed := PRec[1].Fixed; if BGFixed then begin {fixed background} XOff := 0; YOff := 0; IW := Self.ClientRect.Right; IH := Self.ClientRect.Bottom; end else begin {scrolling background} XOff := HScrollbar.Position; YOff := FSectionList.YOff; IW := HScrollbar.Max; IH := IntMax(MaxVertical, Self.ClientRect.Bottom); end; {Calculate where the tiled background images go} CalcBackgroundLocationAndTiling(PRec, ARect, XOff, YOff, IW, IH, BW, BH, X, Y, X2, Y2); if (BW = 1) or (BH = 1) then begin {this is for people who try to tile 1 pixel images} NewBitmap := EnlargeImage(Image, X2-X, Y2-Y);// as TBitmap; try if Assigned(Mask) then NewMask := TBitmap(EnlargeImage(Mask, X2-X, Y2-Y)) else NewMask := Nil; try DrawBackground(ACanvas, ARect, X, Y, X2, Y2, NewBitmap, NewMask, Nil, NewBitmap.Width, NewBitmap.Height, Self.Color); finally NewMask.Free; end; finally NewBitmap.Free; end; end else {normal situation} begin AniGif := FSectionList.BackgroundAniGif; DrawBackground(ACanvas, ARect, X, Y, X2, Y2, Image, Mask, AniGif, BW, BH, Self.Color); end; end else begin {no background image, show color only} BGFixed := False; DrawBackground(ACanvas, ARect, 0,0,0,0, Nil, Nil, Nil, 0, 0, Self.Color); end; end; end; procedure TPaintPanel.WMEraseBkgnd(var Message: TWMEraseBkgnd); begin Message.Result := 1; {it's erased} end; {----------------TPaintPanel.WMLButtonDblClk} procedure TPaintPanel.WMLButtonDblClk(var Message: TWMMouse); begin if Message.Keys and MK_LButton <> 0 then ThtmlViewer(FViewer).HTMLMouseDblClk(Message); end; {$IFNDEF LCL} {----------------T32ScrollBar.SetParams} procedure T32ScrollBar.SetParams(APosition, APage, AMin, AMax: Integer); var ScrollInfo: TScrollInfo; begin if (APosition <> FPosition) or (APage <> FPage) or (AMin <> FMin) or (AMax <> FMax) then with ScrollInfo do begin cbSize := SizeOf(ScrollInfo); fMask := SIF_ALL; if htShowVScroll in (Owner as ThtmlViewer).FOptions then fMask := fMask or SIF_DISABLENOSCROLL; nPos := APosition; nPage := APage; nMin := AMin; nMax := AMax; SetScrollInfo(Handle, SB_CTL, ScrollInfo, True); FPosition := APosition; FPage := APage; FMin := AMin; FMax := AMax; end; end; procedure T32ScrollBar.SetPosition(Value: integer); var SavePos: integer; begin SavePos := FPosition; SetParams(Value, FPage, FMin, FMax); if FPosition <> SavePos then Change; end; procedure T32ScrollBar.SetMin(Value: Integer); begin SetParams(FPosition, FPage, Value, FMax); end; procedure T32ScrollBar.SetMax(Value: Integer); begin SetParams(FPosition, FPage, FMin, Value); end; procedure T32ScrollBar.CNVScroll(var Message: TWMVScroll); var SPos: integer; ScrollInfo: TScrollInfo; OrigPos: integer; TheChange: integer; begin with ThtmlViewer(Parent) do begin ScrollInfo.cbSize := SizeOf(ScrollInfo); ScrollInfo.fMask := SIF_ALL; GetScrollInfo(Self.Handle, SB_CTL, ScrollInfo); if TScrollCode(Message.ScrollCode) = scTrack then begin OrigPos := ScrollInfo.nPos; SPos := ScrollInfo.nTrackPos; end else begin SPos := ScrollInfo.nPos; OrigPos := SPos; case TScrollCode(Message.ScrollCode) of scLineUp: Dec(SPos, SmallChange); scLineDown: Inc(SPos, SmallChange); scPageUp: Dec(SPos, LargeChange); scPageDown: Inc(SPos, LargeChange); scTop: SPos := 0; scBottom: SPos := (FMaxVertical - PaintPanel.Height); end; end; SPos := IntMax(0, IntMin(SPos, (FMaxVertical - PaintPanel.Height))); Self.SetPosition(SPos); FSectionList.SetYOffset(SPos); if BGFixed then PaintPanel.Invalidate else begin {scroll background} TheChange := OrigPos-SPos; ScrollWindow(PaintPanel.Handle,0,TheChange,NIL,NIL); PaintPanel.Update; end; end; end; {$ELSE} procedure T32ScrollBar.DoOnScroll(sender : TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); var OrigPos : Integer; TheChange : Integer; begin with THTMLViewer(Parent) do begin OrigPos := Position; //THTMLViewer.Position ScrollPos := IntMax(0, IntMin(ScrollPos, (FMaxVertical - PaintPanel.Height))); Position := ScrollPos; //THTMLViewer.Position FSectionList.SetYOffset(ScrollPos); if BGFixed then PaintPanel.Invalidate else begin {scroll background} TheChange := OrigPos-ScrollPos; ScrollWindow(PaintPanel.Handle,0,TheChange,NIL,NIL); PaintPanel.Update; end; end; end; {$ENDIF} { PositionObj } destructor PositionObj.Destroy; begin FormData.Free; inherited; end; end.