{Version 9.45} {*********************************************************} {* FRAMVIEW.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 FramView; interface uses SysUtils, Classes, {$IFNDEF LCL} WinTypes, WinProcs, Messages, {$ELSE} LclIntf, LMessages, Types, LclType, FPimage, HtmlMisc, {$ENDIF} Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, Menus, htmlsubs, htmlview, htmlun2, readHTML; type {common to TFrameViewer and TFrameBrowser} THotSpotTargetClickEvent = procedure(Sender: TObject; const Target, URL: string; var Handled: boolean) of Object; THotSpotTargetEvent = procedure(Sender: TObject; const Target, URL: string) of Object; TWindowRequestEvent = procedure(Sender: TObject; const Target, URL: string) of Object; fvOptionEnum = (fvMetaRefresh, fvNoBorder, fvNoLinkUnderline, fvOverLinksActive, fvPrintMonochromeBlack, fvPrintTableBackground, fvPrintBackground, fvShowVScroll, fvNoFocusRect, fvShowDummyCaret, fvNoWheelMouse, fvNoLinkHilite); TFrameViewerOptions = set of fvOptionEnum; {for TFrameViewer} TStreamRequestEvent = procedure(Sender: TObject; const SRC: string; var Stream: TStream) of Object; TBufferRequestEvent = procedure(Sender: TObject; const SRC: string; var Buffer: PChar; var BuffSize: integer) of Object; TStringsRequestEvent = procedure(Sender: TObject; const SRC: string; var Strings: TStrings) of Object; TFileRequestEvent = procedure(Sender: TObject; const SRC: string; var NewName: string) of Object; EfvLoadError = class(Exception); {common base class for TFrameViewer and TFrameBrowser} TFVBase = class(TFrameViewerBase) {TFrameViewerBase is in ReadHTML.pas} protected FURL: string; FTarget: string; FLinkText: string; FLinkAttributes: TStringList; FOnHotSpotTargetClick: THotSpotTargetClickEvent; FOnHotSpotTargetCovered: THotSpotTargetEvent; ProcessList: TList; {list of viewers that are processing} FViewImages: boolean; FImageCacheCount: integer; FBitmapList: TStringBitmapList; FProcessing, FViewerProcessing: boolean; FNoSelect: boolean; FOnHistoryChange: TNotifyEvent; FOnBitmapRequest: TGetBitmapEvent; FOnImageRequest: TGetImageEvent; FOnBlankWindowRequest: TWindowRequestEvent; FOnMeta: TMetaType; FOnScript: TScriptEvent; FOnImageClick: TImageClickEvent; FOnImageOver: TImageOverEvent; FOnFileBrowse: TFileBrowseEvent; FOnObjectClick: TObjectClickEvent; FOnObjectFocus: ThtObjectEvent; FOnObjectBlur: ThtObjectEvent; FOnObjectChange: ThtObjectEvent; FOnRightClick: TRightClickEvent; FOnMouseDouble: TMouseEvent; FServerRoot: string; FOnInclude: TIncludeType; FOnSoundRequest: TSoundType; FPrintMarginLeft, FPrintMarginRight, FPrintMarginTop, FPrintMarginBottom: double; FMarginWidth, FMarginHeight: integer; FOnPrintHeader, FOnPrintFooter: TPagePrinted; FOnPrintHTMLHeader, FOnPrintHTMLFooter: ThtmlPagePrinted; FVisitedMaxCount: integer; FBackground: TColor; FFontName: string; FPreFontName: string; FFontColor: TColor; FHotSpotColor, FVisitedColor, FOverColor: TColor; FFontSize: integer; FCursor: TCursor; FHistoryMaxCount: integer; {$ifdef ver100_plus} {Delphi 3,4,5, C++Builder 3, 4} FCharset: TFontCharset; {$endif} FOnProcessing: TProcessingEvent; FHistory, FTitleHistory: TStrings; FDither: boolean; FOnPanelCreate: TPanelCreateEvent; FOnPanelDestroy: TPanelDestroyEvent; FOnPanelPrint: TPanelPrintEvent; Visited: TStringList; {visited URLs} FOnDragDrop: TDragDropEvent; FOnDragOver: TDragOverEvent; FViewerList: TStrings; FOnParseBegin: TParseEvent; FOnParseEnd: TNotifyEvent; FPrintScale: double; FOnObjectTag: TObjectTagEvent; function GetCurViewerCount: integer; virtual; abstract; function GetCurViewer(I: integer): ThtmlViewer; virtual; abstract; function GetFURL: string; function GetProcessing: boolean; function GetTarget: String; procedure SetViewImages(Value: boolean); procedure SetImageCacheCount(Value: integer); procedure SetNoSelect(Value: boolean); procedure SetOnBitmapRequest(Handler: TGetBitmapEvent); procedure SetOnMeta(Handler: TMetaType); procedure SetOnLink(Handler: TLinkType); procedure SetOnScript(Handler: TScriptEvent); procedure SetImageOver(Handler: TImageOverEvent); procedure SetImageClick(Handler: TImageClickEvent); procedure SetOnFileBrowse(Handler: TFileBrowseEvent); procedure SetOnObjectClick(Handler: TObjectClickEvent); procedure SetOnObjectFocus(Handler: ThtObjectEvent); procedure SetOnObjectBlur(Handler: ThtObjectEvent); procedure SetOnObjectChange(Handler: ThtObjectEvent); procedure SetOnRightClick(Handler: TRightClickEvent); procedure SetMouseDouble(Handler: TMouseEvent); procedure SetServerRoot(Value: string); procedure SetPrintMarginLeft(Value: Double); procedure SetPrintMarginRight(Value: Double); procedure SetPrintMarginTop(Value: Double); procedure SetPrintMarginBottom(Value: Double); procedure SetPrintScale(Value: double); procedure SetPrintHeader(Handler: TPagePrinted); procedure SetPrintFooter(Handler: TPagePrinted); procedure SetPrintHtmlHeader(Handler: THtmlPagePrinted); procedure SetPrintHtmlFooter(Handler: THtmlPagePrinted); procedure SetMarginHeight(Value: integer); procedure SetMarginWidth(Value: integer); procedure SetVisitedMaxCount(Value: integer); procedure SetColor(Value: TColor); function GetFontName: TFontName; procedure SetFontName(Value: TFontName); function GetPreFontName: TFontName; procedure SetPreFontName(Value: TFontName); procedure SetFontSize(Value: integer); procedure SetFontColor(Value: TColor); procedure SetHotSpotColor(Value: TColor); procedure SetActiveColor(Value: TColor); procedure SetVisitedColor(Value: TColor); procedure SetHistoryMaxCount(Value: integer); procedure SetCursor(Value: TCursor); function GetSelLength: integer; procedure SetSelLength(Value: integer); function GetSelStart: integer; procedure SetSelStart(Value: integer); {$ifdef ver100_plus} {Delphi 3,4,5, C++Builder 3, 4} procedure SetCharset(Value: TFontCharset); {$endif} function GetOurPalette: HPalette; procedure SetOurPalette(Value: HPalette); procedure SetDither(Value: boolean); function GetCaretPos: integer; procedure SetCaretPos(Value: integer); function GetSelText: WideString; function GetSelTextBuf(Buffer: PWideChar; BufSize: integer): integer; procedure SetProcessing(Local, Viewer: boolean); procedure CheckProcessing(Sender: TObject; ProcessingOn: boolean); procedure SetOnPanelCreate(Handler: TPanelCreateEvent); procedure SetOnPanelDestroy(Handler: TPanelDestroyEvent); procedure SetOnPanelPrint(Handler: TPanelPrintEvent); procedure SetOnParseBegin(Handler: TParseEvent); procedure SetOnParseEnd(Handler: TNotifyEvent); procedure SetOnObjectTag(Handler: TObjectTagEvent); function GetActiveViewer: ThtmlViewer; virtual; abstract; function GetViewers: TStrings; virtual; abstract; property CurViewer[I: integer]: ThtmlViewer read GetCurViewer; property OnBitmapRequest: TGetBitmapEvent read FOnBitmapRequest write SetOnBitmapRequest; property ServerRoot: string read FServerRoot write SetServerRoot; public procedure ClearHistory; virtual; abstract; procedure SetFocus; override; function InsertImage(Viewer: ThtmlViewer; const Src: string; Stream: TMemoryStream): boolean; function NumPrinterPages: integer; overload; function NumPrinterPages(var WidthRatio: double): integer; overload; procedure Print(FromPage, ToPage: integer); property URL: string read GetFURL; property Target: string read GetTarget; property Processing: boolean read GetProcessing; property ActiveViewer: ThtmlViewer read GetActiveViewer; property History: TStrings read FHistory; property TitleHistory: TStrings read FTitleHistory; property Palette: HPalette read GetOurPalette write SetOurPalette; property Dither: boolean read FDither write SetDither default True; property CaretPos: integer read GetCaretPos write SetCaretPos; property SelLength: integer read GetSelLength write SetSelLength; property SelStart: integer read GetSelStart write SetSelStart; property SelText: WideString read GetSelText; procedure CopyToClipboard; procedure SelectAll; function FindEx(const S: WideString; MatchCase, Reverse: boolean): boolean; function Find(const S: WideString; MatchCase: boolean): boolean; property Viewers: TStrings read GetViewers; property LinkText: string read FLinkText; property LinkAttributes: TStringList read FLinkAttributes; published property OnHotSpotTargetCovered: THotSpotTargetEvent read FOnHotSpotTargetCovered write FOnHotSpotTargetCovered; property OnHotSpotTargetClick: THotSpotTargetClickEvent read FOnHotSpotTargetClick write FOnHotSpotTargetClick; property ViewImages: boolean read FViewImages write SetViewImages default True; property ImageCacheCount: integer read FImageCacheCount write SetImageCacheCount default 5; property OnHistoryChange: TNotifyEvent read FOnHistoryChange write FOnHistoryChange; property NoSelect: boolean read FNoSelect write SetNoSelect; property OnBlankWindowRequest: TWindowRequestEvent read FOnBlankWindowRequest write FOnBlankWindowRequest; property OnScript: TScriptEvent read FOnScript write SetOnScript; property OnImageClick: TImageClickEvent read FOnImageClick write SetImageClick; property OnImageOver: TImageOverEvent read FOnImageOver write SetImageOver; 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 SetOnRightClick; property OnMouseDouble: TMouseEvent read FOnMouseDouble write SetMouseDouble; property OnInclude: TIncludeType read FOnInclude write FOnInclude; property OnSoundRequest: TSoundType read FOnSoundRequest write FOnSoundRequest; property PrintMarginLeft: double read FPrintMarginLeft write SetPrintMarginLeft; property PrintMarginRight: double read FPrintMarginRight write SetPrintMarginRight; property PrintMarginTop: double read FPrintMarginTop write SetPrintMarginTop; property PrintMarginBottom: double read FPrintMarginBottom write SetPrintMarginBottom; property PrintScale: double read FPrintScale write SetPrintScale; property MarginWidth: integer read FMarginWidth write SetMarginWidth default 10; property MarginHeight: integer read FMarginHeight write SetMarginHeight default 5; property OnPrintHeader: TPagePrinted read FOnPrintHeader write SetPrintHeader; property OnPrintFooter: TPagePrinted read FOnPrintFooter write SetPrintFooter; property OnPrintHTMLHeader: ThtmlPagePrinted read FOnPrintHTMLHeader write SetPrintHTMLHeader; property OnPrintHTMLFooter: ThtmlPagePrinted read FOnPrintHTMLFooter write SetPrintHTMLFooter; property OnMeta: TMetaType read FOnMeta write SetOnMeta; property OnLink: TLinkType read FOnLink write SetOnLink; property OnPanelCreate: TPanelCreateEvent read FOnPanelCreate write SetOnPanelCreate; property OnPanelDestroy: TPanelDestroyEvent read FOnPanelDestroy write SetOnPanelDestroy; property OnPanelPrint: TPanelPrintEvent read FOnPanelPrint write SetOnPanelPrint; property OnParseBegin: TParseEvent read FOnParseBegin write SetOnParseBegin; property OnParseEnd: TNotifyEvent read FOnParseEnd write SetOnParseEnd; property DefBackground: TColor read FBackground write SetColor default clBtnFace; property DefFontName: TFontName read GetFontName write SetFontName; property DefPreFontName: TFontName read GetPreFontName write SetPreFontName; property DefFontSize: integer read FFontSize write SetFontSize default 12; property DefFontColor: TColor read FFontColor write SetFontColor 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 HistoryMaxCount: integer read FHistoryMaxCount write SetHistoryMaxCount; property Cursor: TCursor read FCursor write SetCursor default crIBeam; {$ifdef ver100_plus} {Delphi 3,4,5, C++Builder 3, 4} property CharSet: TFontCharset read FCharSet write SetCharset; {$endif} property OnProcessing: TProcessingEvent read FOnProcessing write FOnProcessing; property OnObjectTag: TObjectTagEvent read FOnObjectTag write SetOnObjectTag; property Align; {$ifdef ver120_plus} property Anchors; {$endif} property Enabled; property PopupMenu; property ShowHint; property TabOrder; property TabStop default False; property Visible; property Height default 150; property Width default 150; property OnEnter; property OnExit; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnKeyDown; property OnKeyUp; property OnKeyPress; end; {TFrameViewer Types} PEventRec = ^EventRec; EventRec = record LStyle: LoadStyleType; NewName: string; AString: string; end; TFrameSet = class; TSubFrameSet = class; TFrameBase = class(TCustomPanel) {base class for other classes} MasterSet: TFrameSet; {Points to top (master) TFrameSet} private UnLoaded: boolean; procedure UpdateFrameList; virtual; abstract; protected {$ifdef ver100_plus} {Delphi 3,4,5, C++Builder 3, 4} LocalCharSet: TFontCharset; {$endif} procedure FVMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; abstract; procedure FVMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); virtual; abstract; procedure FVMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; abstract; function CheckNoResize(var Lower, Upper: boolean): boolean; virtual; abstract; procedure LoadFiles(PEV: PEventRec); virtual; abstract; procedure ReLoadFiles(APosition: integer); virtual; abstract; procedure UnloadFiles; virtual; abstract; public LOwner: TSubFrameSet; procedure InitializeDimensions(X, Y, Wid, Ht: integer); virtual; abstract; end; TfvFrame = class(TFrameBase) {TfvFrame holds a ThtmlViewer or TSubFrameSet} protected NoScroll: boolean; frMarginHeight, frMarginWidth: integer; frHistory: TStringList; frPositionHistory: TFreeList; frHistoryIndex: integer; RefreshTimer: TTimer; NextFile: string; procedure CreateViewer; procedure frBumpHistory(const NewName: string; NewPos, OldPos: integer; OldFormData: TFreeList); procedure frBumpHistory1(const NewName: string; Pos: integer); procedure frSetHistoryIndex(Value: integer); procedure UpdateFrameList; override; procedure RefreshEvent(Sender: TObject; Delay: integer; const URL: string); procedure RefreshTimerTimer(Sender: TObject); protected procedure FVMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure FVMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); override; procedure FVMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; function CheckNoResize(var Lower, Upper: boolean): boolean; override; procedure LoadFiles(PEV: PEventRec); override; procedure ReLoadFiles(APosition: integer); override; procedure UnloadFiles; override; procedure frLoadFromFile(const FName, Dest: string; Bump, Reload: boolean); procedure ReloadFile(const FName: string; APosition: integer); public Viewer: ThtmlViewer; {the ThtmlViewer it holds if any} ViewerPosition: integer; ViewerFormData: TFreeList; FrameSet: TSubFrameSet; {or the TSubFrameSet it holds} Source, {Dos filename or URL for this frame} OrigSource, {Original Source name} Destination: string; {Destination offset for this frame} WinName: string; {window name, if any, for this frame} NoReSize: boolean; constructor CreateIt(AOwner: TComponent; L: TAttributeList; Master: TFrameSet; const Path: string); destructor Destroy; override; procedure InitializeDimensions(X, Y, Wid, Ht: integer); override; procedure Repaint; override; procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; end; TSubFrameSet = class(TFrameBase) {can contain one or more TFrames and/or TSubFrameSets} Protected FBase: string; FBaseTarget: string; OuterBorder: integer; BorderSize: integer; FRefreshURL: string; FRefreshDelay: integer; RefreshTimer: TTimer; NextFile: string; procedure ClearFrameNames; procedure AddFrameNames; procedure UpdateFrameList; override; procedure HandleMeta(Sender: TObject; const HttpEq, Name, Content: string); procedure SetRefreshTimer; procedure RefreshTimerTimer(Sender: Tobject); virtual; protected OldRect: TRect; function GetRect: TRect; procedure FVMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure FVMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); override; procedure FVMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure FindLineAndCursor(Sender: TObject; X, Y: integer); function NearBoundary(X, Y: integer): boolean; function CheckNoResize(var Lower, Upper: boolean): boolean; override; procedure Clear; virtual; procedure LoadFromFile(const FName, Dest: string); public First: boolean; {First time thru} Rows: boolean; {set if row frameset, else column frameset} List: TFreeList; {list of TFrames and TSubFrameSets in this TSubFrameSet} Dim, {col width or row height as read. Blanks may have been added} DimF, {col width or row height in pixels as calculated and displayed} Lines {pixel pos of lines, Lines[1]=0, Lines[DimCount]=width|height} : array[0..20] of SmallInt; Fixed {true if line not allowed to be dragged} : array[0..20] of boolean; DimCount: integer; DimFTot: integer; LineIndex: integer; constructor CreateIt(AOwner: TComponent; Master: TFrameSet); destructor Destroy; override; function AddFrame(Attr: TAttributeList; const FName: string): TfvFrame; procedure EndFrameSet; virtual; procedure DoAttributes(L: TAttributeList); procedure LoadFiles(PEV: PEventRec); override; procedure ReLoadFiles(APosition: integer); override; procedure UnloadFiles; override; procedure InitializeDimensions(X, Y, Wid, Ht: integer); override; procedure CalcSizes(Sender: TObject); end; TFrameViewer = class; TFrameSet = class(TSubFrameSet) {only one of these showing, others may be held as History} protected FTitle: string; FCurrentFile: string; FrameNames: TStringList; {list of Window names and their TFrames} Viewers: TList; {list of all ThtmlViewer pointers} Frames: TList; {list of all the Frames contained herein} HotSet: TFrameBase; {owner of line we're moving} OldWidth, OldHeight: integer; NestLevel: integer; FActive: ThtmlViewer; {the most recently active viewer} function RequestEvent: boolean; function TriggerEvent(const Src: string; PEV: PEventRec): boolean; procedure ClearForwards; procedure UpdateFrameList; override; procedure RefreshTimerTimer(Sender: Tobject); override; protected procedure FVMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); override; procedure CheckActive(Sender: TObject); function GetActive: ThtmlViewer; public FrameViewer: TFrameViewer; constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure EndFrameSet; override; procedure LoadFromFile(const FName, Dest: string); procedure Clear; override; procedure CalcSizes(Sender: TObject); procedure Repaint; override; end; TFrameViewer = class(TFVBase) protected FPosition: TList; FHistoryIndex: integer; FOnFormSubmit: TFormSubmitEvent; FOptions: TFrameViewerOptions; UrlRequestStream: TMemoryStream; FOnStreamRequest: TStreamRequestEvent; FOnBufferRequest: TBufferRequestEvent; FOnStringsRequest: TStringsRequestEvent; FOnFileRequest: TFileRequestEvent; FOnProgress: ThtProgressEvent; FBaseEx: string; procedure SetOnImageRequest(Handler: TGetImageEvent); function GetBase: string; procedure SetBase(Value: string); function GetBaseTarget: string; function GetTitle: string; function GetCurrentFile: string; procedure HotSpotCovered(Sender: TObject; const SRC: string); procedure SetHistoryIndex(Value: integer); procedure SetOnFormSubmit(Handler: TFormSubmitEvent); procedure ChkFree(Obj: TObject); function GetActiveBase: string; function GetActiveTarget: string; function GetFwdButtonEnabled: boolean; function GetBackButtonEnabled: boolean; procedure SetOptions(Value: TFrameViewerOptions); procedure fvDragDrop(Sender, Source: TObject; X, Y: Integer); procedure fvDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); procedure SetDragDrop(const Value: TDragDropEvent); procedure SetDragOver(const Value: TDragOverEvent); function GetViewers: TStrings; override; procedure SetOnProgress(Handler: ThtProgressEvent); protected CurFrameSet: TFrameSet; {the TFrameSet being displayed} function GetCurViewerCount: integer; override; function GetCurViewer(I: integer): ThtmlViewer; override; function GetActiveViewer: ThtmlViewer; override; procedure BumpHistory(OldFrameSet: TFrameSet; OldPos: integer); procedure BumpHistory1(const FileName, Title: string; OldPos: integer; ft: ThtmlFileType); procedure BumpHistory2(OldPos: integer); function HotSpotClickHandled: boolean; procedure LoadFromFileInternal(const FName: string); procedure AddFrame(FrameSet: TObject; Attr: TAttributeList; const FName: string); override; function CreateSubFrameSet(FrameSet: TObject): TObject; override; procedure DoAttributes(FrameSet: TObject; Attr: TAttributeList); override; procedure EndFrameSet(FrameSet: TObject); override; procedure AddVisitedLink(const S: string); procedure CheckVisitedLinks; procedure DoURLRequest(Sender: TObject; const SRC: string; var RStream: TMemoryStream); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure LoadFromFile(const FName: string); procedure Load(const SRC: string); procedure LoadTargetFromFile(const Target, FName: string); procedure LoadImageFile(const FName: string); procedure Reload; procedure Clear; procedure HotSpotClick(Sender: TObject; const AnURL: string; var Handled: boolean); function HTMLExpandFilename(const Filename: string): string; virtual; procedure ClearHistory; override; function ViewerFromTarget(const Target: string): ThtmlViewer; procedure GoBack; procedure GoFwd; procedure Repaint; override; property Base: string read GetBase write SetBase; property BaseTarget: string read GetBaseTarget; property DocumentTitle: string read GetTitle; property CurrentFile: string read GetCurrentFile; property HistoryIndex: integer read FHistoryIndex write SetHistoryIndex; published property OnImageRequest: TGetImageEvent read FOnImageRequest write SetOnImageRequest; property OnFormSubmit: TFormSubmitEvent read FOnFormSubmit write SetOnFormSubmit; property FwdButtonEnabled: boolean read GetFwdButtonEnabled; property BackButtonEnabled: boolean read GetBackButtonEnabled; property fvOptions: TFrameViewerOptions read FOptions write SetOptions default [fvPrintTableBackground, fvPrintMonochromeBlack]; property OnStreamRequest: TStreamRequestEvent read FOnStreamRequest write FOnStreamRequest; property OnStringsRequest: TStringsRequestEvent read FOnStringsRequest write FOnStringsRequest; property OnBufferRequest: TBufferRequestEvent read FOnBufferRequest write FOnBufferRequest; property OnFileRequest: TFileRequestEvent read FOnFileRequest write FOnFileRequest; property OnBitmapRequest; property ServerRoot; property OnDragDrop: TDragDropEvent read FOnDragDrop write SetDragDrop; property OnDragOver: TDragOverEvent read FOnDragOver write SetDragOver; property OnProgress: ThtProgressEvent read FOnProgress write SetOnProgress; end; implementation const Sequence: integer = 10; type PositionObj = class(TObject) Pos: integer; Seq: integer; FormData: TFreeList; destructor Destroy; override; end; function ImageFile(Const S: string): boolean; var Ext: string[5]; begin Ext := Lowercase(ExtractFileExt(S)); Result := (Ext = '.gif') or (Ext = '.jpg') or (Ext = '.jpeg') or (Ext = '.bmp') or (Ext = '.png'); end; function TexFile(Const S: string): boolean; var Ext: string[5]; begin Ext := Lowercase(ExtractFileExt(S)); Result := (Ext = '.txt'); end; {----------------FileToString} function FileToString(const Name: String): string; var FS: TFileStream; begin Result := ''; FS := TFileStream.Create(Name, fmOpenRead or fmShareDenyWrite); try SetLength(Result, FS.Size); FS.ReadBuffer(Result[1], FS.Size); finally FS.Free; end; end; {----------------SplitURL} procedure SplitURL(const Src: string; var FName, Dest: string); {Split an URL into filename and Destination} var I: integer; begin I := Pos('#', Src); if I >= 1 then begin Dest := System.Copy(Src, I, Length(Src)-I+1); {local destination} FName := System.Copy(Src, 1, I-1); {the file name} end else begin FName := Src; Dest := ''; {no local destination} end; end; {----------------TfvFrame.CreateIt} constructor TfvFrame.CreateIt(AOwner: TComponent; L: TAttributeList; Master: TFrameSet; const Path: string); var I: integer; S, Dest: string; begin inherited Create(AOwner); {$ifdef ver100_plus} {Delphi 3,4,5, C++Builder 3, 4} if AOwner is TSubFrameSet then LocalCharSet := TSubFrameset(AOwner).LocalCharSet; {$endif} LOwner := AOwner as TSubFrameSet; MasterSet := Master; BevelInner := bvNone; frMarginWidth := MasterSet.FrameViewer.MarginWidth; frMarginHeight := MasterSet.FrameViewer.MarginHeight; if LOwner.BorderSize = 0 then BevelOuter := bvNone else begin BevelOuter := bvLowered; BevelWidth := LOwner.BorderSize; end; ParentColor := True; if Assigned(L) then for I := 0 to L.Count-1 do with TAttribute(L[I]) do case Which of SrcSy: begin SplitUrl(Trim(Name), S, Dest); Destination := Dest; if not Master.RequestEvent then begin S := HTMLServerToDos(S, Master.FrameViewer.ServerRoot); {$IFDEF MSWINDOWS} if Pos(':', S) = 0 then {$ELSE} if Pos('/', S) <> 1 then {$ENDIF} begin if ReadHTML.Base <> '' then {a Base was found} if CompareText(ReadHTML.Base, 'DosPath') = 0 then S := ExpandFilename(S) else S := ExtractFilePath(HTMLToDos(ReadHTML.Base)) + S else S := Path + S; end; end; Source := S; OrigSource := S; end; NameSy: WinName := Name; NoResizeSy: NoResize := True; ScrollingSy: if CompareText(Name, 'NO') = 0 then {auto and yes work the same} NoScroll := True; MarginWidthSy: frMarginWidth := Value; MarginHeightSy: frMarginHeight := Value; end; if WinName <> '' then {add it to the Window name list} (AOwner as TSubFrameSet).MasterSet.FrameNames.AddObject(Uppercase(WinName), Self); OnMouseDown := FVMouseDown; OnMouseMove := FVMouseMove; OnMouseUp := FVMouseUp; frHistory := TStringList.Create; frPositionHistory := TFreeList.Create; end; {----------------TfvFrame.Destroy} destructor TfvFrame.Destroy; var I: integer; begin if Assigned(MasterSet) then begin if (WinName <> '') and Assigned(MasterSet.FrameNames) and MasterSet.FrameNames.Find(WinName, I) and (MasterSet.FrameNames.Objects[I] = Self) then MasterSet.FrameNames.Delete(I); if Assigned(Viewer) then begin if Assigned(MasterSet.Viewers) then MasterSet.Viewers.Remove(Viewer); if Assigned(MasterSet.Frames) then MasterSet.Frames.Remove(Self); if Viewer = MasterSet.FActive then MasterSet.FActive := Nil; end; end; if Assigned(Viewer) then begin Viewer.Free; Viewer := Nil; end else if Assigned(FrameSet) then begin FrameSet.Free; FrameSet := Nil; end; frHistory.Free; frHistory := Nil; frPositionHistory.Free; frPositionHistory := Nil; ViewerFormData.Free; RefreshTimer.Free; inherited Destroy; end; procedure TfvFrame.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); begin inherited; {in most cases, SetBounds results in a call to CalcSizes. However, to make sure for case where there is no actual change in the bounds.... } if Assigned(FrameSet) then FrameSet.CalcSizes(Nil); end; procedure TfvFrame.RefreshEvent(Sender: TObject; Delay: integer; const URL: string); begin if not (fvMetaRefresh in MasterSet.FrameViewer.FOptions) then Exit; if URL = '' then NextFile := Source else NextFile := MasterSet.FrameViewer.HTMLExpandFilename(URL); if not FileExists(NextFile) and not MasterSet.RequestEvent then Exit; if not Assigned(RefreshTimer) then RefreshTimer := TTimer.Create(Self); RefreshTimer.OnTimer := RefreshTimerTimer; RefreshTimer.Interval := Delay*1000; RefreshTimer.Enabled := True; end; procedure TfvFrame.RefreshTimerTimer(Sender: TObject); begin RefreshTimer.Enabled := False; if Unloaded then Exit; if (MasterSet.Viewers.Count = 1) then {load a new FrameSet} begin if CompareText(NextFile, MasterSet.FCurrentFile) = 0 then MasterSet.FrameViewer.Reload else MasterSet.FrameViewer.LoadFromFileInternal(NextFile); end else frLoadFromFile(NextFile, '', True, True); {reload set} end; procedure TfvFrame.RePaint; begin if Assigned(Viewer) then Viewer.RePaint else if Assigned(FrameSet) then FrameSet.RePaint; inherited RePaint; end; {----------------TfvFrame.FVMouseDown} procedure TfvFrame.FVMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin (Parent as TSubFrameSet).FVMouseDown(Sender, Button, Shift, X+Left, Y+Top); end; {----------------TfvFrame.FVMouseMove} procedure TfvFrame.FVMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if not NoResize then (Parent as TSubFrameSet).FVMouseMove(Sender, Shift, X+Left, Y+Top); end; {----------------TfvFrame.FVMouseUp} procedure TfvFrame.FVMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin (Parent as TSubFrameSet).FVMouseUp(Sender, Button, Shift, X+Left, Y+Top); end; {----------------TfvFrame.CheckNoResize} function TfvFrame.CheckNoResize(var Lower, Upper: boolean): boolean; begin Result := NoResize; Lower := NoResize; Upper := NoResize; end; {----------------TfvFrame.InitializeDimensions} procedure TfvFrame.InitializeDimensions(X, Y, Wid, Ht: integer); begin if Assigned(FrameSet) then FrameSet.InitializeDimensions(X, Y, Wid, Ht); end; {----------------TfvFrame.CreateViewer} procedure TfvFrame.CreateViewer; begin Viewer := ThtmlViewer.Create(Self); {the Viewer for the frame} Viewer.FrameOwner := Self; Viewer.Width := ClientWidth; Viewer.Height := ClientHeight; Viewer.Align := alClient; if (MasterSet.BorderSize = 0) or (fvNoFocusRect in MasterSet.FrameViewer.fvOptions) then Viewer.BorderStyle := htNone; Viewer.OnHotspotClick := LOwner.MasterSet.FrameViewer.HotSpotClick; Viewer.OnHotspotCovered := LOwner.MasterSet.FrameViewer.HotSpotCovered; if NoScroll then Viewer.Scrollbars := ssNone; Viewer.DefBackground := MasterSet.FrameViewer.FBackground; Viewer.Visible := False; InsertControl(Viewer); Viewer.SendToBack; Viewer.Visible := True; Viewer.Tabstop := True; {$ifdef ver100_plus} {Delphi 3,4,5, C++Builder 3, 4} Viewer.CharSet := LocalCharset; {$endif} MasterSet.Viewers.Add(Viewer); with MasterSet.FrameViewer do begin Viewer.ViewImages := FViewImages; Viewer.SetStringBitmapList(FBitmapList); Viewer.ImageCacheCount := FImageCacheCount; Viewer.NoSelect := FNoSelect; Viewer.DefFontColor := FFontColor; Viewer.DefHotSpotColor := FHotSpotColor; Viewer.DefVisitedLinkColor := FVisitedColor; Viewer.DefOverLinkColor := FOverColor; Viewer.DefFontSize := FFontSize; Viewer.DefFontName := FFontName; Viewer.DefPreFontName := FPreFontName; Viewer.OnBitmapRequest := FOnBitmapRequest; if fvOverLinksActive in FOptions then Viewer.htOptions := Viewer.htOptions + [htOverLinksActive]; if fvNoLinkUnderline in FOptions then Viewer.htOptions := Viewer.htOptions + [htNoLinkUnderline]; if not (fvPrintTableBackground in FOptions) then Viewer.htOptions := Viewer.htOptions - [htPrintTableBackground]; if (fvPrintBackground in FOptions) then Viewer.htOptions := Viewer.htOptions + [htPrintBackground]; if not (fvPrintMonochromeBlack in FOptions) then Viewer.htOptions := Viewer.htOptions - [htPrintMonochromeBlack]; if fvShowVScroll in FOptions then Viewer.htOptions := Viewer.htOptions + [htShowVScroll]; if fvNoWheelMouse in FOptions then Viewer.htOptions := Viewer.htOptions + [htNoWheelMouse]; if fvShowDummyCaret in FOptions then Viewer.htOptions := Viewer.htOptions + [htShowDummyCaret]; if fvNoLinkHilite in FOptions then Viewer.htOptions := Viewer.htOptions + [htNoLinkHilite]; Viewer.OnImageRequest := FOnImageRequest; Viewer.OnFormSubmit := FOnFormSubmit; Viewer.OnLink := FOnLink; Viewer.OnMeta := FOnMeta; Viewer.OnMetaRefresh := RefreshEvent; Viewer.OnRightClick := FOnRightClick; Viewer.OnProcessing := CheckProcessing; Viewer.OnMouseDown := OnMouseDown; Viewer.OnMouseMove := OnMouseMove; Viewer.OnMouseUp := OnMouseUp; Viewer.OnKeyDown := OnKeyDown; Viewer.OnKeyUp := OnKeyUp; Viewer.OnKeyPress := OnKeyPress; Viewer.Cursor := Cursor; Viewer.HistoryMaxCount := FHistoryMaxCount; Viewer.OnScript := FOnScript; Viewer.PrintMarginLeft := FPrintMarginLeft; Viewer.PrintMarginRight := FPrintMarginRight; Viewer.PrintMarginTop := FPrintMarginTop; Viewer.PrintMarginBottom := FPrintMarginBottom; Viewer.PrintScale := FPrintScale; Viewer.OnPrintHeader := FOnPrintHeader; Viewer.OnPrintFooter := FOnPrintFooter; Viewer.OnPrintHtmlHeader := FOnPrintHtmlHeader; Viewer.OnPrintHtmlFooter := FOnPrintHtmlFooter; Viewer.OnInclude := FOnInclude; Viewer.OnSoundRequest := FOnSoundRequest; Viewer.OnImageOver := FOnImageOver; Viewer.OnImageClick := FOnImageClick; Viewer.OnFileBrowse := FOnFileBrowse; Viewer.OnObjectClick := FOnObjectClick; Viewer.OnObjectFocus := FOnObjectFocus; Viewer.OnObjectBlur := FOnObjectBlur; Viewer.OnObjectChange := FOnObjectChange; Viewer.ServerRoot := ServerRoot; Viewer.OnMouseDouble := FOnMouseDouble; Viewer.OnPanelCreate := FOnPanelCreate; Viewer.OnPanelDestroy := FOnPanelDestroy; Viewer.OnPanelPrint := FOnPanelPrint; Viewer.OnDragDrop := fvDragDrop; Viewer.OnDragOver := fvDragOver; Viewer.OnParseBegin := FOnParseBegin; Viewer.OnParseEnd := FOnParseEnd; Viewer.OnProgress := FOnProgress; Viewer.OnObjectTag := OnObjectTag; if MasterSet.RequestEvent then Viewer.OnhtStreamRequest := DoURLRequest; end; Viewer.MarginWidth := frMarginWidth; Viewer.MarginHeight := frMarginHeight; Viewer.OnEnter := MasterSet.CheckActive; end; {----------------TfvFrame.LoadFiles} procedure TfvFrame.LoadFiles(PEV: PEventRec); var Item: TFrameBase; I: integer; Upper, Lower, Image, Tex: boolean; Msg: string; EV: EventRec; Event: boolean; begin if ((Source <> '') or Assigned(PEV)) and (MasterSet.NestLevel < 4) then begin Image := ImageFile(Source) and not MasterSet.RequestEvent; Tex := TexFile(Source) and not MasterSet.RequestEvent; EV.LStyle := lsFile; if Image or Tex then EV.NewName := MasterSet.FrameViewer.HTMLExpandFilename(Source) else begin if Assigned(PEV) then begin Event := True; EV := PEV^; end else Event := MasterSet.TriggerEvent(Source, @EV); if not Event then EV.NewName := MasterSet.FrameViewer.HTMLExpandFilename(Source); end; Inc(MasterSet.NestLevel); try if not Image and not Tex and IsFrameString(EV.LStyle, EV.NewName, EV.AString, MasterSet.FrameViewer) then begin FrameSet := TSubFrameSet.CreateIt(Self, MasterSet); FrameSet.Align := alClient; FrameSet.Visible := False; InsertControl(FrameSet); FrameSet.SendToBack; FrameSet.Visible := True; FrameParseString(MasterSet.FrameViewer, FrameSet, EV.LStyle, EV.NewName, EV.AString, FrameSet.HandleMeta); Self.BevelOuter := bvNone; frBumpHistory1(Source, 0); with FrameSet do begin for I := 0 to List.Count-1 do Begin Item := TFrameBase(List.Items[I]); Item.LoadFiles(Nil); end; CheckNoresize(Lower, Upper); if FRefreshDelay > 0 then SetRefreshTimer; end; end else begin CreateViewer; Viewer.Base := MasterSet.FBase; if Image then Viewer.LoadImageFile(EV.NewName) else if Tex then Viewer.LoadTextFile(EV.NewName) else begin case EV.LStyle of lsFile: Viewer.LoadFromFile(EV.NewName+Destination); lsString: Viewer.LoadFromString(EV.AString, Source); end; if EV.LStyle <> lsFile then Viewer.PositionTo(Destination); end; frBumpHistory1(Source, Viewer.Position); end; except if not Assigned(Viewer) then CreateViewer; if Assigned(FrameSet) then begin FrameSet.Free; FrameSet := Nil; end; Msg := '

Error Can''t load '+EV.NewName; Viewer.LoadFromBuffer(@Msg[1], Length(Msg), ''); {load an error message} end; Dec(MasterSet.NestLevel); end else begin {so blank area will perform like the TFrameViewer} OnMouseDown := MasterSet.FrameViewer.OnMouseDown; OnMouseMove := MasterSet.FrameViewer.OnMouseMove; OnMouseUp := MasterSet.FrameViewer.OnMouseUp; end; end; {----------------TfvFrame.ReloadFiles} procedure TfvFrame.ReloadFiles(APosition: integer); var Item: TFrameBase; I: integer; Upper, Lower: boolean; EV: EventRec; procedure DoError; var Msg: string; begin Msg := '

Error Can''t load '+Source; Viewer.LoadFromBuffer(@Msg[1], Length(Msg), ''); {load an error message} end; begin if (Source <> '') then if Assigned(FrameSet) then begin with FrameSet do begin for I := 0 to List.Count-1 do Begin Item := TFrameBase(List.Items[I]); Item.ReloadFiles(APosition); end; CheckNoresize(Lower, Upper); end; end else if Assigned(Viewer) then begin Viewer.Base := MasterSet.FBase; if ImageFile(Source) then try Viewer.LoadImageFile(Source) except end {leave blank on error} else if TexFile(Source) then try Viewer.LoadTextFile(Source) except end else begin try if MasterSet.TriggerEvent(Source, @EV) then case EV.LStyle of lsFile: Viewer.LoadFromFile(EV.NewName); lsString: Viewer.LoadFromString(EV.AString, ''); end else Viewer.LoadFromFile(Source); if APosition < 0 then Viewer.Position := ViewerPosition else Viewer.Position := APosition; {its History Position} Viewer.FormData := ViewerFormData; ViewerFormData.Free; ViewerFormData := Nil; except DoError; end; end; end; Unloaded := False; end; {----------------TfvFrame.UnloadFiles} procedure TfvFrame.UnloadFiles; var Item: TFrameBase; I: integer; begin if Assigned(RefreshTimer) then RefreshTimer.Enabled := False; if Assigned(FrameSet) then begin with FrameSet do begin for I := 0 to List.Count-1 do Begin Item := TFrameBase(List.Items[I]); Item.UnloadFiles; end; end; end else if Assigned(Viewer) then begin ViewerPosition := Viewer.Position; ViewerFormData := Viewer.FormData; Viewer.Clear; if MasterSet.FActive = Viewer then MasterSet.FActive := Nil; Viewer.OnSoundRequest := Nil; end; Unloaded := True; end; {----------------TfvFrame.frLoadFromFile} procedure TfvFrame.frLoadFromFile(const FName, Dest: string; Bump, Reload: boolean); {Note: if FName not '' and there is no RequestEvent, it has been HTML expanded and contains the path} var OldPos: integer; HS, OldTitle, OldName: string; OldFormData: TFreeList; SameName, Tex, Img: boolean; OldViewer: ThtmlViewer; OldFrameSet: TSubFrameSet; EV: EventRec; Upper, Lower, FrameFile: boolean; Item: TFrameBase; I: integer; begin if Assigned(RefreshTimer) then RefreshTimer.Enabled := False; OldName := Source; EV.NewName := FName; if EV.NewName = '' then EV.NewName := OldName; Source := EV.NewName; HS := EV.NewName; SameName := CompareText(EV.NewName, OldName)= 0; {if SameName, will not have to reload anything} Img := ImageFile(EV.NewName) and not MasterSet.RequestEvent; Tex := TexFile(EV.NewName) and not MasterSet.RequestEvent; EV.LStyle := lsFile; if not Img and not Tex and not SameName then MasterSet.TriggerEvent(EV.NewName, @EV); try if not SameName then try FrameFile := not Img and not Tex and IsFrameString(EV.LStyle, EV.NewName, EV.AString, MasterSet.FrameViewer); except Raise(EfvLoadError.Create('Can''t load: '+EV.NewName)); end else FrameFile := not Assigned(Viewer); if SameName then if Assigned(Viewer) then begin OldPos := Viewer.Position; if Reload then begin {this for Meta Refresh only} case EV.LStyle of lsFile: Viewer.LoadFromFile(EV.NewName+Dest); lsString: Viewer.LoadFromString(EV.AString, ''); end; Viewer.Position := OldPos; end else begin Viewer.PositionTo(Dest); if Bump and (Viewer.Position <> OldPos) then {Viewer to Viewer} frBumpHistory(HS, Viewer.Position, OldPos, Nil); end; MasterSet.FrameViewer.AddVisitedLink(EV.NewName+Dest); end else begin with FrameSet do begin for I := 0 to List.Count-1 do Begin Item := TFrameBase(List.Items[I]); if (Item is TfvFrame) then with TfvFrame(Item) do if CompareText(Source, OrigSource) <> 0 then begin frLoadFromFile(OrigSource, '', True, False); end; end; end; Exit; end else if Assigned(Viewer) and not FrameFile then {not Same Name} begin {Viewer already assigned and it's not a Frame file} OldPos := Viewer.Position; OldTitle := Viewer.DocumentTitle; OldFormData := Viewer.FormData; try if Img then Viewer.LoadImageFile(EV.NewName) else if Tex then Viewer.LoadTextFile(EV.NewName + Dest) else begin Viewer.Base := MasterSet.FBase; case EV.LStyle of lsFile: Viewer.LoadFromFile(EV.NewName+Dest); lsString: Viewer.LoadFromString(EV.AString, ''); end; if (EV.LStyle <> lsFile) and (Dest <> '') then Viewer.PositionTo(Dest); end; MasterSet.FrameViewer.AddVisitedLink(EV.NewName+Dest); if MasterSet.Viewers.Count > 1 then begin if Bump then {Viewer to Viewer} frBumpHistory(HS, Viewer.Position, OldPos, OldFormData) else OldFormData.Free; end else OldFormData.Free; except OldFormData.Free; Raise; end; if (MasterSet.Viewers.Count = 1) and Bump then {a single viewer situation, bump the history here} with MasterSet do begin FCurrentFile := Viewer.CurrentFile; FTitle := Viewer.DocumentTitle; FBase := Viewer.Base; FBaseTarget := Viewer.BaseTarget; FrameViewer.BumpHistory1(OldName, OldTitle, OldPos, HTMLType); end; end else begin {Viewer is not assigned or it is a Frame File} {not Same Name here either} {keep the old viewer or frameset around (free later) to minimize blink} OldViewer := Viewer; Viewer := Nil; OldFrameSet := FrameSet; FrameSet := Nil; if OldFrameSet <> Nil then OldFrameSet.ClearFrameNames; if not Img and not Tex and FrameFile then begin {it's a frame file} FrameSet := TSubFrameSet.CreateIt(Self, MasterSet); FrameSet.Align := alClient; FrameSet.Visible := False; InsertControl(FrameSet); FrameSet.SendToBack; {to prevent blink} FrameSet.Visible := True; FrameParseString(MasterSet.FrameViewer, FrameSet, EV.LStyle, EV.NewName, EV.AString, FrameSet.HandleMeta); MasterSet.FrameViewer.AddVisitedLink(EV.NewName); Self.BevelOuter := bvNone; with FrameSet do begin for I := 0 to List.Count-1 do Begin Item := TFrameBase(List.Items[I]); Item.LoadFiles(Nil); end; CheckNoresize(Lower, Upper); if FRefreshDelay > 0 then SetRefreshTimer; end; if Assigned(OldViewer) then frBumpHistory(HS, 0, OldViewer.Position, OldViewer.FormData) else frBumpHistory(EV.NewName, 0, 0, Nil); end else begin {not a frame file but needs a viewer} CreateViewer; if Img then Viewer.LoadImageFile(EV.NewName) else if Tex then Viewer.LoadTextFile(EV.NewName) else begin Viewer.Base := MasterSet.FBase; case EV.LStyle of lsFile: Viewer.LoadFromFile(EV.NewName+Dest); lsString: Viewer.LoadFromString(EV.AString, ''); end; if EV.LStyle <> lsFile then Viewer.PositionTo(Dest); end; MasterSet.FrameViewer.AddVisitedLink(EV.NewName+Dest); {FrameSet to Viewer} frBumpHistory(HS, Viewer.Position, 0, Nil); end; if Assigned(FrameSet) then with FrameSet do begin with ClientRect do InitializeDimensions(Left, Top, Right-Left, Bottom-Top); CalcSizes(Nil); end; if Assigned(Viewer) then begin if MasterSet.BorderSize = 0 then BevelOuter := bvNone else begin BevelOuter := bvLowered; BevelWidth := MasterSet.BorderSize; end; if (Dest <> '') then Viewer.PositionTo(Dest); end; if Assigned(OldViewer) then begin MasterSet.Viewers.Remove(OldViewer); if MasterSet.FActive = OldViewer then MasterSet.FActive := Nil; OldViewer.Free; end else if Assigned(OldFrameSet) then begin OldFrameSet.UnloadFiles; OldFrameSet.Visible := False; OldFrameSet.DestroyHandle; end; RePaint; end; except Source := OldName; Raise; end; end; {----------------TfvFrame.ReloadFile} procedure TfvFrame.ReloadFile(const FName: string; APosition: integer); {It's known that there is only a single viewer, the file is not being changed, only the position} begin Viewer.Position := APosition; end; {----------------TfvFrame.frBumpHistory} procedure TfvFrame.frBumpHistory(const NewName: string; NewPos, OldPos: integer; OldFormData: TFreeList); {applies to TFrames which hold a ThtmlViewer}{Viewer to Viewer} var PO: PositionObj; begin with frHistory do begin if (Count > 0) then begin PositionObj(frPositionHistory[frHistoryIndex]).Pos := OldPos; if frHistory[frHistoryIndex] <> NewName then PositionObj(frPositionHistory[frHistoryIndex]).FormData := OldFormData else OldFormData.Free; end else OldFormData.Free; MasterSet.ClearForwards; {clear the history list forwards} frHistoryIndex := 0; InsertObject(0, NewName, FrameSet); {FrameSet may be Nil here} PO := PositionObj.Create; PO.Pos := NewPos; PO.Seq := Sequence; Inc(Sequence); frPositionHistory.Insert(0, PO); MasterSet.UpdateFrameList; with MasterSet.FrameViewer do if Assigned(FOnHistoryChange) then FOnHistoryChange(MasterSet.FrameViewer); end; end; {----------------TfvFrame.frBumpHistory1} procedure TfvFrame.frBumpHistory1(const NewName: string; Pos: integer); {called from a fresh TfvFrame. History list is empty} var PO: PositionObj; begin with frHistory do begin frHistoryIndex := 0; InsertObject(0, NewName, FrameSet); {FrameSet may be Nil here} PO := PositionObj.Create; PO.Pos := Pos; PO.Seq := Sequence; Inc(Sequence); frPositionHistory.Insert(0, PO); MasterSet.UpdateFrameList; with MasterSet.FrameViewer do if Assigned(FOnHistoryChange) then FOnHistoryChange(MasterSet.FrameViewer); end; end; {----------------TfvFrame.frSetHistoryIndex} procedure TfvFrame.frSetHistoryIndex(Value: integer); begin with frHistory do if (Value <> frHistoryIndex) and (Value >= 0) and (Value < Count) then begin if Assigned(RefreshTimer) then RefreshTimer.Enabled := False; {cut off any timing underway} if Assigned(Viewer) then {current is Viewer} with PositionObj(frPositionHistory[frHistoryIndex]) do begin Pos := Viewer.Position; {save the old position} {note that frHistoryIndex can only change by 1} PositionObj(frPositionHistory[frHistoryIndex]).FormData := Viewer.FormData; end else begin {Current is FrameSet} FrameSet.UnloadFiles; FrameSet.DestroyHandle; FrameSet.ClearFrameNames; FrameSet.Visible := False; FrameSet := Nil; {it's not destroyed,though} end; if Objects[Value] is TSubFrameSet then begin FrameSet := TSubFrameSet(Objects[Value]); FrameSet.Visible := True; FrameSet.ReloadFiles(-1); FrameSet.AddFrameNames; if Assigned(Viewer) then begin if Assigned(MasterSet.Viewers) then MasterSet.Viewers.Remove(Viewer); if MasterSet.FActive = Viewer then MasterSet.FActive := Nil; Viewer.Free; Viewer := Nil; end; end else begin if not Assigned(Viewer) then CreateViewer; with PositionObj(frPositionHistory[Value]) do begin if (Source <> Strings[Value]) then begin frLoadFromFile(Strings[Value], '', False, False); Viewer.FormData := FormData; FormData.Free; FormData := Nil; end; Viewer.Position := Pos; end; end; Source := Strings[Value]; frHistoryIndex := Value; MasterSet.UpdateFrameList; with MasterSet.FrameViewer do if Assigned(FOnHistoryChange) then FOnHistoryChange(MasterSet.FrameViewer); MasterSet.FrameViewer.CheckVisitedLinks; end; end; {----------------TfvFrame.UpdateFrameList} procedure TfvFrame.UpdateFrameList; begin MasterSet.Frames.Add(Self); if Assigned(FrameSet) then FrameSet.UpdateFrameList; end; {----------------TSubFrameSet.CreateIt} constructor TSubFrameSet.CreateIt(AOwner: TComponent; Master: TFrameSet); begin inherited Create(AOwner); MasterSet := Master; {$ifdef ver100_plus} {Delphi 3,4,5, C++Builder 3, 4} if AOwner is TFrameBase then LocalCharSet := TSubFrameset(AOwner).LocalCharSet; {$endif} OuterBorder := 0; {no border for subframesets} if Self <> Master then BorderSize := Master.BorderSize; First := True; List := TFreeList.Create; OnResize := CalcSizes; OnMouseDown := FVMouseDown; OnMouseMove := FVMouseMove; OnMouseUp := FVMouseUp; {$ifdef delphi7_plus} {$IFNDEF LCL} ParentBackground := False; {$ENDIF} {$endif} ParentColor := True; end; {----------------TSubFrameSet.ClearFrameNames} procedure TSubFrameSet.ClearFrameNames; var I, J: integer; begin for J := 0 to List.Count-1 do if (TFrameBase(List[J]) is TfvFrame) then begin with TfvFrame(List[J]) do if Assigned(MasterSet) and (WinName <> '') and Assigned(MasterSet.FrameNames) and MasterSet.FrameNames.Find(WinName, I) then MasterSet.FrameNames.Delete(I); end else if (TFrameBase(List[J]) is TSubFrameSet) then TSubFrameSet(List[J]).ClearFrameNames; end; {----------------TSubFrameSet.AddFrameNames} procedure TSubFrameSet.AddFrameNames; var J: integer; Frame: TfvFrame; begin for J := 0 to List.Count-1 do if (TFrameBase(List[J]) is TfvFrame) then begin Frame := TfvFrame(List[J]); with Frame do if Assigned(MasterSet) and (WinName <> '') and Assigned(MasterSet.FrameNames) then begin MasterSet.FrameNames.AddObject(Uppercase(WinName), Frame); end; end else if (TFrameBase(List[J]) is TSubFrameSet) then TSubFrameSet(List[J]).AddFrameNames; end; {----------------TSubFrameSet.Destroy} destructor TSubFrameSet.Destroy; begin List.Free; List := Nil; RefreshTimer.Free; inherited Destroy; end; {----------------TSubFrameSet.AddFrame} function TSubFrameSet.AddFrame(Attr: TAttributeList; const FName: string): TfvFrame; {called by the parser when is encountered within the definition} begin Result := TfvFrame.CreateIt(Self, Attr, MasterSet, ExtractFilePath(FName)); List.Add(Result); Result.SetBounds(OuterBorder, OuterBorder, Width-2*OuterBorder, Height-2*OuterBorder); InsertControl(Result); end; {----------------TSubFrameSet.DoAttributes} procedure TSubFrameSet.DoAttributes(L: TAttributeList); {called by the parser to process the attributes} var T: TAttribute; S: string; Numb: string[20]; procedure GetDims; const EOL = ^M; var Ch: char; I, N: integer; procedure GetCh; begin if I > Length(S) then Ch := EOL else begin Ch := S[I]; Inc(I); end; end; begin if Name = '' then S := T.Name else Exit; I := 1; DimCount := 0; repeat Inc(DimCount); Numb := ''; GetCh; while not (Ch in ['0'..'9', '*', EOL, ',']) do GetCh; if Ch in ['0'..'9'] then begin while Ch in ['0'..'9'] do begin Numb := Numb+Ch; GetCh; end; N := IntMax(1, StrToInt(Numb)); {no zeros} while not (Ch in ['*', '%', ',', EOL]) do GetCh; if ch = '*' then begin Dim[DimCount] := -IntMin(99, N);{store '*' relatives as negative, -1..-99} GetCh; end else if Ch = '%' then begin {%'s stored as -(100 + %), i.e. -110 is 10% } Dim[DimCount] := -IntMin(1000, N+100); {limit to 900%} GetCh; end else Dim[DimCount] := IntMin(N, 5000); {limit absolute to 5000} end else if Ch in ['*', ',', EOL] then begin Dim[DimCount] := -1; if Ch = '*' then GetCh; end; while not (Ch in [',', EOL]) do GetCh; until (Ch = EOL) or (DimCount = 20); end; begin {read the row or column widths into the Dim array} If L.Find(RowsSy, T) then begin Rows := True; GetDims; end; if L.Find(ColsSy, T) and (DimCount <=1) then begin Rows := False; DimCount := 0; GetDims; end; if (Self = MasterSet) and not (fvNoBorder in MasterSet.FrameViewer.FOptions) then {BorderSize already defined as 0} if L.Find(BorderSy, T) or L.Find(FrameBorderSy, T)then begin BorderSize := T.Value; OuterBorder := IntMax(2-BorderSize, 0); if OuterBorder >= 1 then begin BevelWidth := OuterBorder; BevelOuter := bvLowered; end; end else BorderSize := 2; end; {----------------TSubFrameSet.LoadFiles} procedure TSubFrameSet.LoadFiles; var I: integer; Item: TFrameBase; begin for I := 0 to List.Count-1 do begin Item := TFrameBase(List.Items[I]); Item.LoadFiles(Nil); end; end; {----------------TSubFrameSet.ReloadFiles} procedure TSubFrameSet.ReloadFiles(APosition: integer); var I: integer; Item: TFrameBase; begin for I := 0 to List.Count-1 do begin Item := TFrameBase(List.Items[I]); Item.ReloadFiles(APosition); end; if (FRefreshDelay > 0) and Assigned(RefreshTimer) then SetRefreshTimer; Unloaded := False; end; {----------------TSubFrameSet.UnloadFiles} procedure TSubFrameSet.UnloadFiles; var I: integer; Item: TFrameBase; begin if Assigned(RefreshTimer) then RefreshTimer.Enabled := False; for I := 0 to List.Count-1 do begin Item := TFrameBase(List.Items[I]); Item.UnloadFiles; end; if Assigned(MasterSet.FrameViewer.FOnSoundRequest) then MasterSet.FrameViewer.FOnSoundRequest(MasterSet, '', 0, True); Unloaded := True; end; {----------------TSubFrameSet.EndFrameSet} procedure TSubFrameSet.EndFrameSet; {called by the parser when is encountered} var I: integer; begin if List.Count > DimCount then {a value left out} begin {fill in any blanks in Dim array} for I := DimCount+1 to List.Count do begin Dim[I] := -1; {1 relative unit} Inc(DimCount); end; end else while DimCount > List.Count do {or add Frames if more Dims than Count} AddFrame(Nil, ''); if ReadHTML.Base <> '' then FBase := ReadHTML.Base else FBase := MasterSet.FrameViewer.FBaseEx; FBaseTarget := ReadHTML.BaseTarget; end; {----------------TSubFrameSet.InitializeDimensions} procedure TSubFrameSet.InitializeDimensions(X, Y, Wid, Ht: integer); var I, Total, PixTot, PctTot, RelTot, Rel, Sum, Remainder, PixDesired, PixActual: integer; begin if Rows then Total := Ht else Total := Wid; PixTot := 0; RelTot := 0; PctTot := 0; DimFTot := 0; for I := 1 to DimCount do {count up the total pixels, %'s and relatives} if Dim[I] >= 0 then PixTot := PixTot + Dim[I] else if Dim[I] <= -100 then PctTot := PctTot + (-Dim[I]-100) else RelTot := RelTot - Dim[I]; Remainder := Total - PixTot; if Remainder <= 0 then begin {% and Relative are 0, must scale absolutes} for I := 1 to DimCount do begin if Dim[I] >= 0 then DimF[I] := MulDiv(Dim[I], Total, PixTot) {reduce to fit} else DimF[I] := 0; Inc(DimFTot, DimF[I]); end; end else {some remainder left for % and relative} begin PixDesired := MulDiv(Total, PctTot, 100); if PixDesired > Remainder then PixActual := Remainder else PixActual := PixDesired; Dec(Remainder, PixActual); {Remainder will be >= 0} if RelTot > 0 then Rel := Remainder div RelTot {calc each relative unit} else Rel := 0; for I := 1 to DimCount do {calc the actual pixel widths (heights) in DimF} begin if Dim[I] >= 0 then DimF[I] := Dim[I] else if Dim[I] <= -100 then DimF[I] := MulDiv(-Dim[I]-100, PixActual, PctTot) else DimF[I] := -Dim[I] * Rel; Inc(DimFTot, DimF[I]); end; end; Sum := 0; for I := 0 to List.Count-1 do {intialize the dimensions of contained items} begin if Rows then TFrameBase(List.Items[I]).InitializeDimensions(X, Y+Sum, Wid, DimF[I+1]) else TFrameBase(List.Items[I]).InitializeDimensions(X+Sum, Y, DimF[I+1], Ht); Sum := Sum+DimF[I+1]; end; end; {----------------TSubFrameSet.CalcSizes} {OnResize event comes here} procedure TSubFrameSet.CalcSizes(Sender: TObject); var I, Step, Sum, ThisTotal: integer; ARect: TRect; begin {Note: this method gets called during Destroy as it's in the OnResize event. Hence List may be Nil.} if Assigned(List) and (List.Count > 0) then begin ARect := ClientRect; InflateRect(ARect, -OuterBorder, -OuterBorder); Sum := 0; if Rows then ThisTotal := ARect.Bottom - ARect.Top else ThisTotal := ARect.Right-ARect.Left; for I := 0 to List.Count-1 do begin Step := MulDiv(DimF[I+1], ThisTotal, DimFTot); if Rows then TFrameBase(List.Items[I]).SetBounds(ARect.Left, ARect.Top+Sum, ARect.Right-ARect.Left, Step) else TFrameBase(List.Items[I]).SetBounds(ARect.Left+Sum, ARect.Top, Step, ARect.Bottom-Arect.Top); Sum := Sum+Step; Lines[I+1] := Sum; end; end; end; {----------------TSubFrameSet.NearBoundary} function TSubFrameSet.NearBoundary(X, Y: integer): boolean; begin Result := (Abs(X) < 4) or (Abs(X - Width) < 4) or (Abs(Y) < 4) or (Abs(Y-Height) < 4); end; {----------------TSubFrameSet.GetRect} function TSubFrameSet.GetRect: TRect; {finds the FocusRect to draw when draging boundaries} var Pt, Pt1, Pt2: TPoint; begin Pt1 := Point(0, 0); Pt1 := ClientToScreen(Pt1); Pt2 := Point(ClientWidth, ClientHeight); Pt2 := ClientToScreen(Pt2); GetCursorPos(Pt); if Rows then Result := Rect(Pt1.X, Pt.Y-1, Pt2.X, Pt.Y+1) else Result := Rect(Pt.X-1, Pt1.Y, Pt.X+1, Pt2.Y); OldRect := Result; end; {----------------DrawRect} procedure DrawRect(ARect: TRect); {Draws a Focus Rect} var DC: HDC; begin DC := GetDC(0); DrawFocusRect(DC, ARect); ReleaseDC(0, DC); end; {----------------TSubFrameSet.FVMouseDown} procedure TSubFrameSet.FVMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var ACursor: TCursor; RP: record case boolean of True: (P1, P2: TPoint); False:(R: TRect); end; begin if Button <> mbLeft then Exit; if NearBoundary(X, Y) then begin if Parent is TFrameBase then (Parent as TFrameBase).FVMouseDown(Sender, Button, Shift, X+Left, Y+Top) else Exit; end else begin ACursor := (Sender as TFrameBase).Cursor; if (ACursor = crVSplit) or(ACursor = crHSplit) then begin MasterSet.HotSet := Self; with RP do begin {restrict cursor to lines on both sides} if Rows then R := Rect(0, Lines[LineIndex-1]+1, ClientWidth, Lines[LineIndex+1]-1) else R := Rect(Lines[LineIndex-1]+1, 0, Lines[LineIndex+1]-1, ClientHeight); P1 := ClientToScreen(P1); P2 := ClientToScreen(P2); ClipCursor(@R); end; DrawRect(GetRect); end; end; end; {----------------TSubFrameSet.FindLineAndCursor} procedure TSubFrameSet.FindLineAndCursor(Sender: TObject; X, Y: integer); var ACursor: TCursor; Gap, ThisGap, Line, I: integer; begin if not Assigned(MasterSet.HotSet) then begin {here we change the cursor as mouse moves over lines,button up or down} if Rows then Line := Y else Line := X; Gap := 9999; for I := 1 to DimCount-1 do begin ThisGap := Line-Lines[I]; if Abs(ThisGap) < Abs(Gap) then begin Gap := Line - Lines[I]; LineIndex := I; end else if Abs(ThisGap) = Abs(Gap) then {happens if 2 lines in same spot} if ThisGap >= 0 then {if Pos, pick the one on right (bottom)} LineIndex := I; end; if (Abs(Gap) <= 4) and not Fixed[LineIndex] then begin if Rows then ACursor := crVSplit else ACursor := crHSplit; (Sender as TFrameBase).Cursor := ACursor; end else (Sender as TFrameBase).Cursor := MasterSet.FrameViewer.Cursor; end else with TSubFrameSet(MasterSet.HotSet) do begin DrawRect(OldRect); DrawRect(GetRect); end; end; {----------------TSubFrameSet.FVMouseMove} procedure TSubFrameSet.FVMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin if NearBoundary(X, Y) then (Parent as TFrameBase).FVMouseMove(Sender, Shift, X+Left, Y+Top) else FindLineAndCursor(Sender, X, Y); end; {----------------TSubFrameSet.FVMouseUp} procedure TSubFrameSet.FVMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var I: integer; begin if Button <> mbLeft then Exit; if MasterSet.HotSet = Self then begin MasterSet.HotSet := Nil; DrawRect(OldRect); ClipCursor(Nil); if Rows then Lines[LineIndex] := Y else Lines[LineIndex] := X; for I := 1 to DimCount do if I = 1 then DimF[1] := MulDiv(Lines[1], DimFTot, Lines[DimCount]) else DimF[I] := MulDiv((Lines[I] - Lines[I-1]), DimFTot, Lines[DimCount]); CalcSizes(Self); Invalidate; end else if (Parent is TFrameBase) then (Parent as TFrameBase).FVMouseUp(Sender, Button, Shift, X+Left, Y+Top); end; {----------------TSubFrameSet.CheckNoResize} function TSubFrameSet.CheckNoResize(var Lower, Upper: boolean): boolean; var Lw, Up: boolean; I: integer; begin Result := False; Lower := False; Upper := False; for I := 0 to List.Count-1 do with TFrameBase(List[I]) do if CheckNoResize(Lw, Up) then begin Result := True; {sides are fixed} Fixed[I] := True; {these edges are fixed} Fixed[I+1] := True; If Lw and (I = 0) then Lower := True; If Up and (I = List.Count-1) then Upper := True; end; end; {----------------TSubFrameSet.Clear} procedure TSubFrameSet.Clear; var I: integer; X: TFrameBase; begin for I := List.Count-1 downto 0 do begin X := List.Items[I]; List.Delete(I); RemoveControl(X); X.Free; end; DimCount := 0; First := True; Rows := False; FillChar(Fixed, Sizeof(Fixed), 0); FillChar(Lines, Sizeof(Lines), 0); FBase := ''; FBaseTarget := ''; end; {----------------TSubFrameSet.LoadFromFile} procedure TSubFrameSet.LoadFromFile(const FName, Dest: string); var Frame: TfvFrame; begin Clear; Frame := AddFrame(Nil, ''); Frame.Source := FName; Frame.Destination := Dest; EndFrameSet; Frame.LoadFiles(Nil); if Assigned(Frame.FrameSet) then with Frame.FrameSet do begin with ClientRect do InitializeDimensions(Left, Top, Right-Left, Bottom-Top); CalcSizes(Nil); end else if Assigned(Frame.Viewer) then Frame.Viewer.PositionTo(Dest); MasterSet.FrameViewer.AddVisitedLink(FName+Dest); end; {----------------TSubFrameSet.UpdateFrameList} procedure TSubFrameSet.UpdateFrameList; var I: integer; begin for I := 0 to List.Count-1 do TFrameBase(List[I]).UpdateFrameList; end; {----------------TSubFrameSet.HandleMeta} procedure TSubFrameSet.HandleMeta(Sender: TObject; const HttpEq, Name, Content: string); var DelTime, I: integer; begin {$ifdef ver100_plus} {Delphi 3,4,5, C++Builder 3, 4} if CompareText(HttpEq, 'content-type') = 0 then TranslateCharset(Content, LocalCharset); {$endif} with MasterSet.FrameViewer do begin if Assigned(FOnMeta) then FOnMeta(Sender, HttpEq, Name, Content); if not (fvMetaRefresh in FOptions) then Exit; end; 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 if Owner is TfvFrame then FRefreshURL := TfvFrame(Owner).Source else FRefreshURL := ''; FRefreshDelay := DelTime; end; end; {----------------TSubFrameSet.SetRefreshTimer} procedure TSubFrameSet.SetRefreshTimer; begin NextFile := HTMLToDos(FRefreshURL); if not FileExists(NextFile) then Exit; if not Assigned(RefreshTimer) then RefreshTimer := TTimer.Create(Self); RefreshTimer.OnTimer := RefreshTimerTimer; RefreshTimer.Interval := FRefreshDelay*1000; RefreshTimer.Enabled := True; end; {----------------TSubFrameSet.RefreshTimerTimer} procedure TSubFrameSet.RefreshTimerTimer(Sender: Tobject); var S, D: string; begin RefreshTimer.Enabled := False; if Unloaded then Exit; if Owner is TfvFrame then begin SplitURL(NextFile, S, D); TfvFrame(Owner).frLoadFromFile(S, D, True, True); end; end; {----------------TFrameSet.Create} constructor TFrameSet.Create(AOwner: TComponent); begin inherited CreateIt(AOwner, Self); FrameViewer := AOwner as TFrameViewer; {$ifdef ver100_plus} {Delphi 3,4,5, C++Builder 3, 4} LocalCharSet := FrameViewer.FCharset; {$endif} if fvNoBorder in FrameViewer.FOptions then BorderSize := 0 else BorderSize := 2; BevelOuter := bvNone; FTitle := ''; FCurrentFile:= ''; FrameNames := TStringList.Create; FrameNames.Sorted := True; Viewers := TList.Create; Frames := TList.Create; OnResize := CalcSizes; end; {----------------TFrameSet.Destroy} destructor TFrameSet.Destroy; begin FrameNames.Free; FrameNames := Nil; {is tested later} Viewers.Free; Viewers := Nil; Frames.Free; Frames := Nil; inherited Destroy; end; {----------------TFrameSet.Clear} procedure TFrameSet.Clear; begin inherited Clear; FrameNames.Clear; Viewers.Clear; Frames.Clear; HotSet := Nil; FTitle := ''; FCurrentFile := ''; OldHeight := 0; OldWidth := 0; FActive := Nil; end; procedure TFrameSet.RePaint; var I: integer; begin if Assigned(Frames) then for I := 0 to Frames.Count-1 do {$IFNDEF LCL} TWinControl(Frames[I]).RePaint; {$ELSE} TCustomControl(Frames[I]).RePaint; {$ENDIF} inherited; end; {----------------TFrameSet.RequestEvent} function TFrameSet.RequestEvent: boolean; begin with FrameViewer do Result := Assigned(FOnStringsRequest) or Assigned(FOnStreamRequest) or Assigned(FOnBufferRequest) or Assigned(FOnFileRequest); end; {----------------TFrameSet.TriggerEvent} function TFrameSet.TriggerEvent(const Src: string; PEV: PEventRec): boolean; var AName: string; BStream: TMemoryStream; Strings: TStrings; Stream: TStream; Buffer: PChar; BuffSize: integer; begin with PEV^ do begin Result := False; LStyle := lsFile; Buffer := Nil; BuffSize := 0; AName := ''; AString := ''; Stream := Nil; with FrameViewer do if Assigned(FOnStringsRequest) then begin FOnStringsRequest(Self, Src, Strings); Result := Assigned(Strings); if Result then begin LStyle := lsString; AString := Strings.Text; end; end else if Assigned(FOnStreamRequest) then begin FOnStreamRequest(Self, Src, Stream); Result := Assigned(Stream); if Result then begin LStyle := lsString; BStream := TMemoryStream.Create; try BStream.LoadFromStream(Stream); SetLength(AString, BStream.Size); Move(BStream.Memory^, AString[1], BStream.Size); finally BStream.Free; end; end; end else if Assigned(FOnBufferRequest) then begin FOnBufferRequest(Self, Src, Buffer, BuffSize); Result := (BuffSize > 0) and Assigned(Buffer); if Result then begin LStyle := lsString; SetLength(AString, BuffSize); Move(Buffer^, AString[1], BuffSize); end; end else if Assigned(FOnFileRequest) then begin FOnFileRequest(Self, Src, AName); Result := AName <> ''; if Result then begin LStyle := lsFile; NewName := AName; AString := FileToString(NewName); end; end; end; end; {----------------TFrameSet.EndFrameSet} procedure TFrameSet.EndFrameSet; begin FTitle := ReadHTML.Title; inherited EndFrameSet; with ClientRect do InitializeDimensions(Left, Top, Right-Left, Bottom-Top); end; {----------------TFrameSet.CalcSizes} {OnResize event comes here} procedure TFrameSet.CalcSizes(Sender: TObject); var ARect: TRect; begin ARect := ClientRect; InflateRect(ARect, -OuterBorder, -OuterBorder); with ARect do begin if (OldWidth <> Right-Left) or (OldHeight <> Bottom-Top) then begin InitializeDimensions(Left, Top, Right-Left, Bottom-Top); inherited CalcSizes(Sender); end; OldWidth := Right-Left; OldHeight := Bottom-Top; end; end; {----------------TFrameSet.CheckActive} procedure TFrameSet.CheckActive(Sender: TObject); begin if Sender is ThtmlViewer then FActive := ThtmlViewer(Sender); end; {----------------TFrameSet.GetActive} function TFrameSet.GetActive: ThtmlViewer; begin if Viewers.Count = 1 then Result := ThtmlViewer(Viewers[0]) else try if FActive is ThtmlViewer then Result := FActive else Result := Nil; except Result := Nil; end; end; {----------------TFrameSet.FVMouseMove} procedure TFrameSet.FVMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin FindLineAndCursor(Sender, X, Y); if (LineIndex = 0) or (LineIndex = DimCount) then begin {picked up the outer boundary} (Sender as TFrameBase).Cursor := MasterSet.FrameViewer.Cursor; Cursor := MasterSet.FrameViewer.Cursor; end; end; {----------------TFrameSet.LoadFromFile} procedure TFrameSet.LoadFromFile(const FName, Dest: string); var I: integer; Item: TFrameBase; Frame: TfvFrame; Lower, Upper: boolean; EV: EventRec; EventPointer: PEventRec; Img, Tex: boolean; begin Clear; NestLevel := 0; EV.LStyle := lsFile; Img := ImageFile(FName) and not RequestEvent; Tex := TexFile(FName) and not RequestEvent; if Img or Tex or not TriggerEvent(FName, @EV) then begin EV.NewName := ExpandFileName(FName); FCurrentFile := EV.NewName; end else begin {triggerevent} FCurrentFile := FName; end; FRefreshDelay := 0; if not Img and not Tex and IsFrameString(EV.LStyle, EV.NewName, EV.AString, MasterSet.FrameViewer) then begin {it's a Frameset html file} FrameParseString(MasterSet.FrameViewer, Self, EV.LStyle, EV.NewName, EV.AString, HandleMeta); for I := 0 to List.Count-1 do Begin Item := TFrameBase(List.Items[I]); Item.LoadFiles(Nil); end; CalcSizes(Self); CheckNoresize(Lower, Upper); if FRefreshDelay > 0 then SetRefreshTimer; end else begin {it's a non frame file} Frame := AddFrame(Nil, ''); if not Img and not Tex and RequestEvent then begin Frame.Source := FName; EventPointer := @EV; end else begin Frame.Source := EV.NewName; EventPointer := Nil; end; Frame.Destination := Dest; EndFrameSet; CalcSizes(Self); Frame.Loadfiles(EventPointer); FTitle := ReadHTML.Title; FBaseTarget := ReadHTML.BaseTarget; end; end; procedure TFrameSet.RefreshTimerTimer(Sender: Tobject); begin RefreshTimer.Enabled := False; if (Self = MasterSet.FrameViewer.CurFrameSet) then FrameViewer.LoadFromFileInternal(NextFile); end; {----------------TFrameSet.ClearForwards} procedure TFrameSet.ClearForwards; {clear all the forward items in the history lists} var I, J: integer; Frame: TfvFrame; AList: TList; Obj: TObject; begin AList := TList.Create; for J := 0 to Frames.Count-1 do begin Frame := TfvFrame(Frames[J]); with Frame do begin for I := 0 to frHistoryIndex-1 do begin Obj := frHistory.Objects[0]; if Assigned(Obj) and (AList.IndexOf(Obj) < 0) then AList.Add(Obj); frHistory.Delete(0); PositionObj(frPositionHistory[0]).Free; frPositionHistory.Delete(0); end; frHistoryIndex := 0; end; end; for J := 0 to Frames.Count-1 do {now see which Objects are no longer used} begin Frame := TfvFrame(Frames[J]); with Frame do begin for I := 0 to frHistory.Count-1 do begin Obj := frHistory.Objects[I]; if Assigned(Obj) and (AList.IndexOf(Obj) > -1) then AList.Remove(Obj); {remove it if it's there} end; end; end; for I := 0 to AList.Count-1 do {destroy what's left} TObject(AList[I]).Free; AList.Free; end; {----------------TFrameSet.UpdateFrameList} procedure TFrameSet.UpdateFrameList; {Fill Frames with a list of all current TFrames} begin Frames.Clear; inherited UpdateFrameList; end; {----------------TFrameViewer.Create} constructor TFrameViewer.Create(AOwner: TComponent); begin inherited Create(AOwner); Height := 150; Width := 150; ProcessList := TList.Create; FLinkAttributes := TStringList.Create; FViewImages := True; FBitmapList := TStringBitmapList.Create; FImageCacheCount := 5; FHistory := TStringList.Create; FPosition := TList.Create; FTitleHistory := TStringList.Create; FBackground := clBtnFace; FFontColor := clBtnText; FHotSpotColor := clBlue; FVisitedColor := clPurple; FOverColor := clBlue; FVisitedMaxCount := 50; FFontSize := 12; FFontName := 'Times New Roman'; FPreFontName := 'Courier New'; FCursor := crIBeam; FDither := True; TabStop := False; FPrintMarginLeft := 2.0; FPrintMarginRight := 2.0; FPrintMarginTop := 2.0; FPrintMarginBottom := 2.0; FPrintScale := 1.0; FMarginWidth := 10; FMarginHeight := 5; FOptions := [fvPrintTableBackground, fvPrintMonochromeBlack]; {$ifdef ver100_plus} {Delphi 3,4,5, C++Builder 3, 4} FCharset := DEFAULT_CHARSET; {$endif} Visited := TStringList.Create; CurFrameSet := TFrameSet.Create(Self); if fvNoBorder in FOptions then begin CurFrameSet.OuterBorder := 0; CurFrameSet.BevelOuter := bvNone; end else begin CurFrameSet.OuterBorder := 2; CurFrameSet.BevelWidth := 2; CurFrameSet.BevelOuter := bvLowered; end; CurFrameSet.Align := alClient; CurFrameSet.OnDragDrop := FOnDragDrop; CurFrameSet.OnDragOver := FOnDragOver; InsertControl(CurFrameSet); end; {----------------TFrameViewer.Destroy} destructor TFrameViewer.Destroy; begin UrlRequestStream.Free; ProcessList.Free; FLinkAttributes.Free; FHistory.Free; FPosition.Free; FTitleHistory.Free; Visited.Free; FViewerList.Free; inherited Destroy; FBitmapList.Free; end; {----------------TFrameViewer.Clear} procedure TFrameViewer.Clear; var I: integer; Obj: TObject; begin if not Processing then begin for I := 0 to FHistory.Count-1 do with FHistory do begin Obj := Objects[0]; Delete(0); if Obj <> CurFrameset then ChkFree(Obj); end; with CurFrameSet do begin Clear; BevelOuter := bvLowered; BevelWidth := 2; end; FBitmapList.Clear; FURL := ''; FTarget := ''; FBaseEx := ''; FHistoryIndex := 0; FPosition.Clear; FTitleHistory.Clear; if Assigned(FOnHistoryChange) then FOnHistoryChange(Self); Visited.Clear; if Assigned(FViewerList) then FViewerList.Clear; end; end; {----------------TFrameViewer.LoadFromFile} procedure TFrameViewer.LoadFromFile(const FName: string); var S, Dest: string; begin if not Processing then begin SplitURL(FName, S, Dest); if not FileExists(S) then Raise(EfvLoadError.Create('Can''t locate file: '+S)); LoadFromFileInternal(FName); end; end; {----------------TFrameViewer.LoadFromFileInternal} procedure TFrameViewer.LoadFromFileInternal(const FName: string); var OldFrameSet: TFrameSet; OldFile, S, Dest: string; OldPos: integer; Tmp: TObject; SameName: boolean; {$ifdef Windows} Dummy: integer; {$endif} begin FProcessing := True; if Assigned(FOnProcessing) then FOnProcessing(Self, True); {$ifdef windows} Dummy := {$endif} IOResult; {remove any pending file errors} SplitURL(FName, S, Dest); try OldFile := CurFrameSet.FCurrentFile; ProcessList.Clear; if Assigned(FOnSoundRequest) then FOnSoundRequest(Self, '', 0, True); SameName := CompareText(OldFile, S) = 0; if not SameName then begin OldFrameSet := CurFrameSet; CurFrameSet := TFrameSet.Create(Self); CurFrameSet.Align := alClient; CurFrameSet.visible := False; InsertControl(CurFrameSet); CurFrameSet.SendToBack; CurFrameSet.Visible := True; try CurFrameSet.LoadFromFile(S, Dest); except RemoveControl(CurFrameSet); CurFrameSet.Free; CurFrameSet := OldFrameSet; Raise; end; OldPos := 0; if (OldFrameSet.Viewers.Count = 1) then begin Tmp := OldFrameSet.Viewers[0]; if Tmp is ThtmlViewer then OldPos := ThtmlViewer(Tmp).Position; end; OldFrameSet.UnloadFiles; CurFrameSet.Visible := True; if Visible then begin SendMessage(Handle, wm_SetRedraw, 0, 0); try CurFrameSet.BringToFront; finally SendMessage(Handle, wm_SetRedraw, 1, 0); Repaint; end; CurFrameSet.Repaint; end; RemoveControl(OldFrameSet); BumpHistory(OldFrameSet, OldPos); end else begin {Same Name} OldPos := 0; if (CurFrameSet.Viewers.Count = 1) then begin Tmp := CurFrameSet.Viewers[0]; if Tmp is ThtmlViewer then OldPos := ThtmlViewer(Tmp).Position; end; SendMessage(Handle, wm_SetRedraw, 0, 0); try CurFrameSet.LoadFromFile(S, Dest); finally SendMessage(Handle, wm_SetRedraw, 1, 0); Repaint; end; BumpHistory2(OldPos); {not executed if exception occurs} end; AddVisitedLink(S+Dest); CheckVisitedLinks; finally FProcessing := False; if Assigned(FOnProcessing) then FOnProcessing(Self, False); end; end; {----------------TFrameViewer.Load} procedure TFrameViewer.Load(const SRC: string); begin if Assigned(FOnStringsRequest) or Assigned(FOnStreamRequest) or Assigned(FOnBufferRequest) or Assigned(FOnFileRequest) then LoadFromFileInternal(SRC); end; {----------------TFrameViewer.LoadTargetFromFile} procedure TFrameViewer.LoadTargetFromFile(const Target, FName: string); var I: integer; FrameTarget: TFrameBase; S, Dest: string; begin if Processing then Exit; if CurFrameSet.FrameNames.Find(Target, I) then FrameTarget := (CurFrameSet.FrameNames.Objects[I] as TfvFrame) else if (Target = '') or (CompareText(Target, '_top') = 0) or (CompareText(Target, '_parent') = 0) or (CompareText(Target, '_self') = 0)then begin LoadFromFileInternal(Fname); Exit; end else begin {_blank or unknown target} if Assigned(FOnBlankWindowRequest) then FOnBlankWindowRequest(Self, Target, FName); Exit; end; SplitURL(FName, S, Dest); if not FileExists(S) and not Assigned(OnStreamRequest) then Raise(EfvLoadError.Create('Can''t locate file: '+S)); FProcessing := True; if Assigned(FOnProcessing) then FOnProcessing(Self, True); try if FrameTarget is TfvFrame then TfvFrame(FrameTarget).frLoadFromFile(S, Dest, True, False) else if FrameTarget is TSubFrameSet then TSubFrameSet(FrameTarget).LoadFromFile(S, Dest); finally if Assigned(FOnProcessing) then FOnProcessing(Self, False); FProcessing := False; end; end; {----------------TFrameViewer.LoadImageFile} procedure TFrameViewer.LoadImageFile(const FName: string); begin if ImageFile(FName) then LoadFromFile(FName); end; {----------------TFrameViewer.Reload} procedure TFrameViewer.Reload; begin FProcessing := True; if Assigned(FOnProcessing) then FOnProcessing(Self, True); try ProcessList.Clear; CurFrameSet.UnloadFiles; CurFrameSet.ReloadFiles(-1); CheckVisitedLinks; finally FProcessing := False; if Assigned(FOnProcessing) then FOnProcessing(Self, False); end; end; {----------------TFrameViewer.GetFwdButtonEnabled} function TFrameViewer.GetFwdButtonEnabled: boolean; var I: integer; Frame: TfvFrame; begin Result := fHistoryIndex >= 1; if not Result then for I := 0 to CurFrameSet.Frames.Count-1 do begin Frame := TfvFrame(CurFrameSet.Frames[I]); with Frame do if frHistoryIndex >= 1 then begin Result := True; Exit; end; end; end; {----------------TFrameViewer.GetBackButtonEnabled} function TFrameViewer.GetBackButtonEnabled: boolean; var I: integer; Frame: TfvFrame; begin Result := fHistoryIndex <= fHistory.Count-2; if not Result then for I := 0 to CurFrameSet.Frames.Count-1 do begin Frame := TfvFrame(CurFrameSet.Frames[I]); with Frame do if frHistoryIndex <= frHistory.Count-2 then begin Result := True; Exit; end; end; end; procedure TFrameViewer.GoFwd; var I, Smallest, Index: integer; Frame, TheFrame: TfvFrame; begin Smallest := 9999; Index := 0; TheFrame := Nil; {to quiet the warnings} for I := 0 to CurFrameSet.Frames.Count-1 do begin Frame := TfvFrame(CurFrameSet.Frames[I]); with Frame do if frHistoryIndex >= 1 then with PositionObj(frPositionHistory[frHistoryIndex-1]) do if Seq < Smallest then begin Smallest := Seq; TheFrame := Frame; Index := frHistoryIndex; end; end; if Smallest < 9999 then TheFrame.frSetHistoryIndex(Index - 1) else SetHistoryIndex(fHistoryIndex - 1); if Assigned(FOnSoundRequest) then FOnSoundRequest(Self, '', 0, True); end; procedure TFrameViewer.GoBack; var I, Largest, Index: integer; Frame, TheFrame: TfvFrame; begin Largest := -1; Index := 0; TheFrame := Nil; {to quiet the warnings} for I := 0 to CurFrameSet.Frames.Count-1 do begin Frame := TfvFrame(CurFrameSet.Frames[I]); with Frame do if frHistoryIndex <= frHistory.Count-2 then with PositionObj(frPositionHistory[frHistoryIndex]) do if Seq > Largest then begin Largest := Seq; TheFrame := Frame; Index := frHistoryIndex; end; end; if Largest >= 0 then TheFrame.frSetHistoryIndex(Index + 1) else SetHistoryIndex(fHistoryIndex+1); if Assigned(FOnSoundRequest) then FOnSoundRequest(Self, '', 0, True); end; {----------------TFrameViewer.HotSpotClickHandled:} function TFrameViewer.HotSpotClickHandled: boolean; var Handled: boolean; begin Handled := False; if Assigned(FOnHotSpotTargetClick) then FOnHotSpotTargetClick(Self, FTarget, FURL, Handled); Result := Handled; end; {----------------TFrameViewer.HotSpotClick} procedure TFrameViewer.HotSpotClick(Sender: TObject; const AnURL: string; var Handled: boolean); var I: integer; Viewer: ThtmlViewer; FrameTarget: TFrameBase; S, Dest, Query: string; begin if Processing then begin Handled := True; Exit; end; Viewer := (Sender as ThtmlViewer); FURL := AnURL; FTarget := GetActiveTarget; FLinkAttributes.Text := Viewer.LinkAttributes.Text; FLinkText := Viewer.LinkText; Handled := HotSpotClickHandled; if not Handled then begin Handled := True; S := AnURL; I := Pos('#', S); 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} I := Pos('?', S); {remove any query string} if I >= 1 then begin Query := System.Copy(S, I, Length(S)-I+1); S := System.Copy(S, 1, I-1); {the file name} end else Query := ''; if (S <> '') and not CurFrameSet.RequestEvent then S := Viewer.HTMLExpandFileName(S); if (FTarget = '') or (CompareText(FTarget, '_self') = 0) then {no target or _self target} begin FrameTarget := Viewer.FrameOwner as TfvFrame; if not Assigned(FrameTarget) then Exit; end else if CurFrameSet.FrameNames.Find(FTarget, I) then FrameTarget := (CurFrameSet.FrameNames.Objects[I] as TfvFrame) else if CompareText(FTarget, '_top') = 0 then FrameTarget := CurFrameSet else if CompareText(FTarget, '_parent') = 0 then begin FrameTarget := (Viewer.FrameOwner as TfvFrame).Owner as TFrameBase; while Assigned(FrameTarget) and not (FrameTarget is TfvFrame) and not (FrameTarget is TFrameSet) do FrameTarget := FrameTarget.Owner as TFrameBase; end else begin if Assigned(FOnBlankWindowRequest) then begin AddVisitedLink(S+Query+Dest); CheckVisitedLinks; FOnBlankWindowRequest(Self, FTarget, AnURL); Handled := True; end else Handled := FTarget <> ''; {true if can't find target window} Exit; end; FProcessing := True; if Assigned(FOnProcessing) then FOnProcessing(Self, True); if (FrameTarget is TfvFrame) and (CurFrameSet.Viewers.Count = 1) and (S <> '') and (CompareText(S, CurFrameSet.FCurrentFile) <> 0) then FrameTarget := CurFrameSet; {force a new FrameSet on name change} try if FrameTarget is TfvFrame then TfvFrame(FrameTarget).frLoadFromFile(S, Dest, True, False) else if FrameTarget is TFrameSet then Self.LoadFromFileInternal(S + Dest) else if FrameTarget is TSubFrameSet then TSubFrameSet(FrameTarget).LoadFromFile(S, Dest); if Query <> '' then AddVisitedLink(S+Query+Dest); CheckVisitedLinks; finally FProcessing := False; {changed position} if Assigned(FOnProcessing) then FOnProcessing(Self, False); end; end; end; function TFrameViewer.GetCurViewerCount: integer; begin Result := CurFrameSet.Viewers.Count; end; function TFrameViewer.GetCurViewer(I: integer): ThtmlViewer; begin Result := CurFrameSet.Viewers[I]; end; {----------------TFrameViewer.HotSpotCovered} procedure TFrameViewer.HotSpotCovered(Sender: TObject; const SRC: string); begin if Assigned(FOnHotSpotTargetCovered) then with (Sender as ThtmlViewer) do begin FLinkText := LinkText; FLinkAttributes.Text := LinkAttributes.Text; FOnHotSpotTargetCovered(Sender, Target, Src); end; end; {----------------TFrameViewer.GetActiveTarget} function TFrameViewer.GetActiveTarget: string; var Vw: ThtmlViewer; Done: boolean; FSet: TSubFrameSet; begin Result := ''; Vw := GetActiveViewer; if Assigned(Vw) then begin Result := Vw.Target; if Result = '' then Result := Vw.BaseTarget; Done := False; FSet := TfvFrame(Vw.FrameOwner).LOwner; while (Result = '') and Assigned(FSet) and not Done do begin Result := FSet.FBaseTarget; Done := FSet = CurFrameSet; if not Done then FSet := FSet.LOwner; end; end; end; {----------------TFrameViewer.GetActiveBase} function TFrameViewer.GetActiveBase: string; var Vw: ThtmlViewer; Done: boolean; FSet: TSubFrameSet; begin Result := ''; Vw := GetActiveViewer; if Assigned(Vw) then begin Result := Vw.Base; Done := False; FSet := TfvFrame(Vw.FrameOwner).LOwner; while (Result = '') and Assigned(FSet) and not Done do begin Result := FSet.FBase; Done := FSet = CurFrameSet; if not Done then FSet := FSet.LOwner; end; end; end; {----------------TFrameViewer.HTMLExpandFilename} function TFrameViewer.HTMLExpandFilename(const Filename: string): string; var BasePath: string; Viewer: ThtmlViewer; begin Result := HTMLServerToDos(Trim(Filename), FServerRoot); {$IFDEF MSWINDOWS} if (Pos(':', Result)<> 2) and (Pos('\\', Result) <> 1) then {$ELSE} if Pos('/', Result) <> 1 then {$ENDIF} begin BasePath := GetActiveBase; if CompareText(BasePath, 'DosPath') = 0 then {let Dos find the path} else begin if BasePath <> '' then Result := HTMLToDos(BasePath) + Result else begin Viewer := ActiveViewer; if Assigned(Viewer) then Result := Viewer.HTMLExpandFilename(Result) else Result := ExtractFilePath(CurFrameSet.FCurrentFile) + Result; end; end; end; end; function TFrameViewer.GetBase: string; begin Result := CurFrameSet.FBase; end; procedure TFrameViewer.SetBase(Value: string); begin CurFrameSet.FBase := Value; FBaseEx := Value; end; function TFrameViewer.GetBaseTarget: string; begin Result := CurFrameSet.FBaseTarget; end; function TFrameViewer.GetTitle: string; begin Result := CurFrameSet.FTitle; end; function TFrameViewer.GetCurrentFile: string; begin Result := CurFrameSet.FCurrentFile; end; {----------------TFrameViewer.GetActiveViewer} function TFrameViewer.GetActiveViewer: ThtmlViewer; begin Result := CurFrameSet.GetActive; end; {----------------TFrameViewer.BumpHistory} procedure TFrameViewer.BumpHistory(OldFrameSet: TFrameSet; OldPos: integer); {OldFrameSet never equals CurFrameSet when this method called} var I: integer; Obj: TObject; begin if (FHistoryMaxCount > 0) and (CurFrameSet.FCurrentFile <> '') then with FHistory do begin if (Count > 0) then begin Strings[FHistoryIndex] := OldFrameSet.FCurrentFile; Objects[FHistoryIndex] := OldFrameSet; FTitleHistory[FHistoryIndex] := OldFrameSet.FTitle; FPosition[FHistoryIndex] := TObject(OldPos); OldFrameSet.ClearForwards; end else OldFrameSet.Free; for I := 0 to FHistoryIndex-1 do begin Obj := Objects[0]; Delete(0); ChkFree(Obj); FTitleHistory.Delete(0); FPosition.Delete(0); end; FHistoryIndex := 0; Insert(0, CurFrameSet.FCurrentFile); Objects[0] := CurFrameSet; FTitleHistory.Insert(0, CurFrameSet.FTitle); FPosition.Insert(0, Nil); if Count > FHistoryMaxCount then begin Obj := Objects[FHistoryMaxCount]; Delete(FHistoryMaxCount); ChkFree(Obj); FTitleHistory.Delete(FHistoryMaxCount); FPosition.Delete(FHistoryMaxCount); end; if Assigned(FOnHistoryChange) then FOnHistoryChange(Self); end else OldFrameSet.Free; end; {----------------TFrameViewer.BumpHistory1} procedure TFrameViewer.BumpHistory1(const FileName, Title: string; OldPos: integer; ft: ThtmlFileType); {This variation called when CurFrameSet contains only a single viewer before and after the change} var I: integer; Obj: TObject; begin if (FHistoryMaxCount > 0) and (Filename <> '') then with FHistory do begin if (Count > 0) then begin Strings[FHistoryIndex] := Filename; Objects[FHistoryIndex] := CurFrameSet; FTitleHistory[FHistoryIndex] := Title; FPosition[FHistoryIndex] := TObject(OldPos); end; for I := 0 to FHistoryIndex-1 do begin Obj := Objects[0]; Delete(0); ChkFree(Obj); FTitleHistory.Delete(0); FPosition.Delete(0); end; FHistoryIndex := 0; Insert(0, CurFrameSet.FCurrentFile); Objects[0] := CurFrameSet; FTitleHistory.Insert(0, CurFrameSet.FTitle); FPosition.Insert(0, Nil); if Count > FHistoryMaxCount then begin Obj := Objects[FHistoryMaxCount]; Delete(FHistoryMaxCount); ChkFree(Obj); FTitleHistory.Delete(FHistoryMaxCount); FPosition.Delete(FHistoryMaxCount); end; if Assigned(FOnHistoryChange) then FOnHistoryChange(Self); end; end; {----------------TFrameViewer.BumpHistory2} procedure TFrameViewer.BumpHistory2(OldPos: integer); {CurFrameSet has not changed when this method called} var I: integer; Obj: TObject; begin if (FHistoryMaxCount > 0) and (CurFrameSet.FCurrentFile <> '') then with FHistory do begin if (Count > 0) then begin Strings[FHistoryIndex] := CurFrameSet.FCurrentFile; Objects[FHistoryIndex] := CurFrameSet; FTitleHistory[FHistoryIndex] := CurFrameSet.FTitle; FPosition[FHistoryIndex] := TObject(OldPos); end; for I := 0 to FHistoryIndex-1 do begin Obj := Objects[0]; Delete(0); ChkFree(Obj); FTitleHistory.Delete(0); FPosition.Delete(0); end; FHistoryIndex := 0; Insert(0, CurFrameSet.FCurrentFile); Objects[0] := CurFrameSet; FTitleHistory.Insert(0, CurFrameSet.FTitle); FPosition.Insert(0, Nil); if Count > FHistoryMaxCount then begin Obj := Objects[FHistoryMaxCount]; Delete(FHistoryMaxCount); ChkFree(Obj); FTitleHistory.Delete(FHistoryMaxCount); FPosition.Delete(FHistoryMaxCount); end; if Assigned(FOnHistoryChange) then FOnHistoryChange(Self); end; end; {----------------TFrameViewer.SetHistoryIndex} procedure TFrameViewer.SetHistoryIndex(Value: integer); var FrameSet, FrameSet1: TFrameSet; Tmp: TObject; begin with CurFrameSet, FHistory do if (Value <> FHistoryIndex) and (Value >= 0) and (Value < Count) and not Processing then begin if CurFrameSet.Viewers.Count > 0 then Tmp := CurFrameSet.Viewers[0] else Tmp := Nil; if FCurrentFile <> '' then begin {Objects[FHistoryIndex] should have CurFrameSet here} FTitleHistory[FHistoryIndex] := CurFrameSet.FTitle; if (Tmp is ThtmlViewer) then FPosition[FHistoryIndex] := TObject((Tmp as ThtmlViewer).Position) else FPosition[FHistoryIndex] := Nil; end; FrameSet := Objects[Value] as TFrameSet; if FrameSet <> CurFrameSet then begin FrameSet1 := CurFrameSet; {swap framesets} CurFrameSet := FrameSet; CurFrameSet.OldWidth := 0; {encourage recalc of internal layout} CurFrameSet.Visible := False; Self.InsertControl(CurFrameSet); if CurFrameSet.Viewers.Count = 1 then CurFrameSet.ReloadFiles(integer(FPosition[Value])) else CurFrameSet.ReloadFiles(-1); SendMessage(Self.handle, wm_SetRedraw, 0, 0); CurFrameSet.Visible := True; SendMessage(Self.handle, wm_SetRedraw, 1, 0); CurFrameSet.Repaint; FrameSet1.Unloadfiles; Self.RemoveControl(FrameSet1); end else begin if (Tmp is ThtmlViewer) then TfvFrame(ThtmlViewer(Tmp).FrameOwner).ReloadFile(FHistory[Value], integer(FPosition[Value])); end; FHistoryIndex := Value; if Assigned(FOnHistoryChange) then FOnHistoryChange(Self); CheckVisitedLinks; end; end; {----------------TFrameViewer.ChkFree} procedure TFrameViewer.ChkFree(Obj: TObject); {Frees a TFrameSet only if it no longer exists in FHistory} var I: integer; begin for I := 0 to FHistory.Count-1 do if Obj = FHistory.Objects[I] then Exit; (Obj as TFrameSet).Free; end; {----------------TFrameViewer.ClearHistory} procedure TFrameViewer.ClearHistory; var I: integer; Obj: TObject; DidSomething: boolean; begin DidSomething := FHistory.Count > 0; for I := FHistory.Count-1 downto 0 do begin Obj := FHistory.Objects[I]; FHistory.Delete(I); if Obj <> CurFrameSet then ChkFree(Obj); end; if Assigned(CurFrameSet) then for I := 0 to CurFrameSet.Frames.Count-1 do with TfvFrame(CurFrameSet.Frames[I]) do begin DidSomething := DidSomething or (frHistory.Count > 0); frHistoryIndex := 0; frHistory.Clear; frPositionHistory.Clear; end; FHistory.Clear; FTitleHistory.Clear; FPosition.Clear; FHistoryIndex := 0; if DidSomething and Assigned(FOnHistoryChange) then FOnHistoryChange(Self); end; procedure TFrameViewer.SetOnFormSubmit(Handler: TFormSubmitEvent); var I: integer; begin FOnFormSubmit := Handler; with CurFrameSet do for I := 0 to Viewers.Count-1 do with ThtmlViewer(Viewers[I]) do OnFormSubmit := Handler; end; procedure TFrameViewer.SetOnProgress(Handler: ThtProgressEvent); var I: integer; begin FOnProgress := Handler; with CurFrameSet do for I := 0 to Viewers.Count-1 do with ThtmlViewer(Viewers[I]) do OnProgress := Handler; end; procedure TFrameViewer.SetDragDrop(const Value: TDragDropEvent); var I: integer; begin FOnDragDrop := Value; if Assigned(CurFrameSet) then if Assigned(Value) then CurFrameSet.OnDragDrop := fvDragDrop else CurFrameSet.OnDragDrop := Nil; for I := 0 to GetCurViewerCount-1 do if Assigned(Value) then CurViewer[I].OnDragDrop := fvDragDrop else CurViewer[I].OnDragDrop := Nil; end; procedure TFrameViewer.fvDragDrop(Sender, Source: TObject; X, Y: Integer); begin if Assigned(FOnDragDrop) then FOnDragDrop(Self, Source, X, Y); end; procedure TFrameViewer.SetDragOver(const Value: TDragOverEvent); var I: integer; begin FOnDragOver := Value; if Assigned(CurFrameSet) then if Assigned(Value) then CurFrameSet.OnDragOver := fvDragOver else CurFrameSet.OnDragOver := Nil; for I := 0 to GetCurViewerCount-1 do if Assigned(Value) then CurViewer[I].OnDragOver := fvDragOver else CurViewer[I].OnDragOver := Nil; end; procedure TFrameViewer.fvDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin if Assigned(FOnDragOver) then FOnDragOver(Self, Source, X, Y, State, Accept); end; procedure TFrameViewer.SetOnImageRequest(Handler: TGetImageEvent); var I: integer; begin FOnImageRequest := Handler; with CurFrameSet do for I := 0 to Viewers.Count-1 do with ThtmlViewer(Viewers[I]) do OnImageRequest := Handler; end; function TFrameViewer.ViewerFromTarget(const Target: string): ThtmlViewer; var I: integer; begin if Assigned(CurFrameSet) and Assigned(CurFrameSet.FrameNames) and CurFrameSet.FrameNames.Find(Target, I) and (CurFrameSet.FrameNames.Objects[I] <> Nil) and Assigned((CurFrameSet.FrameNames.Objects[I] as TfvFrame).Viewer) then Result := TfvFrame(CurFrameSet.FrameNames.Objects[I]).Viewer as ThtmlViewer else Result := Nil; end; procedure TFrameViewer.RePaint; begin if Assigned(CurFrameSet) then CurFrameSet.RePaint; end; procedure TFrameViewer.SetOptions(Value: TFrameViewerOptions); var I: integer; begin if (fvNoBorder in FOptions) <> (fvNoBorder in Value) then if fvNoBorder in Value then begin CurFrameSet.OuterBorder := 0; CurFrameSet.BevelOuter := bvNone; CurFrameSet.BorderSize := 0; end else begin CurFrameSet.BevelWidth := 2; CurFrameSet.BevelOuter := bvLowered; CurFrameSet.BorderSize := 2; end; for I := 0 to CurFrameSet.Viewers.Count-1 do with ThtmlViewer(CurFrameSet.Viewers[I]) do begin if (fvOverLinksActive in Value) then htOptions := htOptions + [htOverLinksActive] else htOptions := htOptions - [htOverLinksActive]; if (fvNoLinkUnderline in Value) then htOptions := htOptions + [htNoLinkUnderline] else htOptions := htOptions - [htNoLinkUnderline]; if (fvPrintTableBackground in Value) then htOptions := htOptions + [htPrintTableBackground] else htOptions := htOptions - [htPrintTableBackground]; if (fvPrintBackground in Value) then htOptions := htOptions + [htPrintBackground] else htOptions := htOptions - [htPrintBackground]; if (fvPrintMonochromeBlack in Value) then htOptions := htOptions + [htPrintMonochromeBlack] else htOptions := htOptions - [htPrintMonochromeBlack]; if (fvShowVScroll in Value) then htOptions := htOptions + [htShowVScroll] else htOptions := htOptions - [htShowVScroll]; if (fvNoWheelMouse in Value) then htOptions := htOptions + [htNoWheelMouse] else htOptions := htOptions - [htNoWheelMouse]; if (fvShowDummyCaret in Value) then htOptions := htOptions + [htShowDummyCaret] else htOptions := htOptions - [htShowDummyCaret]; if (fvNoLinkHilite in Value) then htOptions := htOptions + [htNoLinkHilite] else htOptions := htOptions - [htNoLinkHilite]; if (fvNoFocusRect in Value) or (fvNoBorder in Value) then BorderStyle := htNone else BorderStyle := htFocused; end; FOptions := Value; end; procedure TFrameViewer.AddFrame(FrameSet: TObject; Attr: TAttributeList; const FName: string); begin (FrameSet as TSubFrameSet).AddFrame(Attr, FName); end; function TFrameViewer.CreateSubFrameSet(FrameSet: TObject): TObject; var NewFrameSet, FS: TSubFrameSet; begin FS := (FrameSet as TSubFrameSet); NewFrameSet := TSubFrameSet.CreateIt(FS, CurFrameSet); FS.List.Add(NewFrameSet); FS.InsertControl(NewFrameSet); Result := NewFrameSet; end; procedure TFrameViewer.DoAttributes(FrameSet: TObject; Attr: TAttributeList); begin (FrameSet as TSubFrameSet).DoAttributes(Attr); end; procedure TFrameViewer.EndFrameSet(FrameSet: TObject); begin (FrameSet as TSubFrameSet).EndFrameSet; end; {----------------TFrameViewer.AddVisitedLink} procedure TFrameViewer.AddVisitedLink(const S: string); var I: integer; begin if (FVisitedMaxCount = 0) then Exit; I := Visited.IndexOf(S); if I = 0 then Exit else if I > 0 then 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; {----------------TFrameViewer.CheckVisitedLinks} procedure TFrameViewer.CheckVisitedLinks; var I, J, K: integer; S, S1, Src: string; Viewer: ThtmlViewer; RequestEvent: boolean; begin if FVisitedMaxCount = 0 then Exit; RequestEvent := CurFrameSet.RequestEvent; for K := 0 to CurFrameSet.Viewers.Count-1 do begin Viewer := ThtmlViewer(CurFrameSet.Viewers[K]); if RequestEvent then Src := TfvFrame(Viewer.FrameOwner).Source; for I := 0 to Visited.Count-1 do begin S := Visited[I]; for J := 0 to Viewer.LinkList.Count-1 do with TFontObj(Viewer.LinkList[J]) do begin if not RequestEvent then begin if (Url <> '') and (Url[1] = '#') then S1 := Viewer.CurrentFile+Url else S1 := Viewer.HTMLExpandFilename(Url); end else if (Url <> '') and (Url[1] = '#') then S1 := Src+Url else S1 := URL; if CompareText(S, S1) = 0 then Visited := True; end; end; Viewer.Invalidate; end; end; {----------------TFrameViewer.DoURLRequest} procedure TFrameViewer.DoURLRequest(Sender: TObject; const SRC: string; var RStream: TMemoryStream); var EV: EventRec; begin if CurFrameSet.TriggerEvent(Src, @EV) then with EV do begin if not Assigned(UrlRequestStream) then UrlRequestStream := TMemoryStream.Create; case LStyle of lsFile: UrlRequestStream.LoadFromFile(NewName); lsString: begin UrlRequestStream.SetSize(Length(AString)); System.Move(AString[1], UrlRequestStream.Memory^, Length(AString)); end; end; RStream := UrlRequestStream; end; end; {----------------TFrameViewer.GetViewers:} function TFrameViewer.GetViewers: TStrings; var I: integer; S: string; AFrame: TfvFrame; Viewer: ThtmlViewer; Pt1, Pt2: TPoint; begin if not Assigned(FViewerList) then FViewerList := TStringList.Create else FViewerList.Clear; for I := 0 to CurFrameSet.Viewers.Count-1 do begin Viewer := CurFrameSet.Viewers[I]; if Viewer.SectionList.Count > 0 then begin S := ''; AFrame := TfvFrame(Viewer.FrameOwner); Pt1 := AFrame.ClientToScreen(Point(0,0)); Pt2 := CurFrameSet.ClientToScreen(Point(0,0)); if Pt1.X <= Pt2.X +2 then S := S+'l'; if Pt1.Y <= Pt2.Y +2 then S := S+'t'; Pt1 := AFrame.ClientToScreen(Point(AFrame.ClientWidth, AFrame.ClientHeight)); Pt2 := CurFrameSet.ClientToScreen(Point(CurFrameSet.ClientWidth, CurFrameSet.ClientHeight)); if Pt1.X >= Pt2.X -2 then S := S+'r'; if Pt1.Y >= Pt2.Y -2 then S := S+'b'; FViewerList.AddObject(S, Viewer); end; end; Result := FViewerList; end; {----------------TFVBase.GetFURL} {base class for TFrameViewer and TFrameBrowser} function TFVBase.GetFURL: string; begin Result := FURL; end; function TFVBase.GetTarget: string; begin Result := FTarget; end; procedure TFVBase.SetViewImages(Value: boolean); var I : integer; begin if (FViewImages <> Value) and not Processing then begin FViewImages := Value; for I := 0 to GetCurViewerCount-1 do CurViewer[I].ViewImages := Value; end; end; procedure TFVBase.SetImageCacheCount(Value: integer); var I : integer; begin if (FImageCacheCount <> Value) and not Processing then begin FImageCacheCount := Value; for I := 0 to GetCurViewerCount-1 do CurViewer[I].ImageCacheCount := Value; end; end; function TFVBase.GetProcessing: boolean; begin Result := FProcessing or FViewerProcessing; end; {----------------TFVBase.SetNoSelect} procedure TFVBase.SetNoSelect(Value: boolean); var I: integer; begin if Value <> FNoSelect then begin FNoSelect := Value; for I := 0 to GetCurViewerCount-1 do CurViewer[I].NoSelect := Value; end; end; procedure TFVBase.SetOnBitmapRequest(Handler: TGetBitmapEvent); var I: integer; begin FOnBitmapRequest := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnBitmapRequest := Handler; end; procedure TFVBase.SetOnMeta(Handler: TMetaType); var I: integer; begin FOnMeta := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnMeta := Handler; end; procedure TFVBase.SetOnLink(Handler: TLinkType); var I: integer; begin FOnLink := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnLink := Handler; end; procedure TFVBase.SetOnScript(Handler: TScriptEvent); var I: integer; begin FOnScript := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnScript := Handler; end; procedure TFVBase.SetImageOver(Handler: TImageOverEvent); var I: integer; begin FOnImageOver := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnImageOver := Handler; end; procedure TFVBase.SetImageClick(Handler: TImageClickEvent); var I: integer; begin FOnImageClick := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnImageClick := Handler; end; procedure TFVBase.SetOnRightClick(Handler: TRightClickEvent); var I: integer; begin FOnRightClick := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnRightClick := Handler; end; procedure TFVBase.SetOnObjectFocus(Handler: ThtObjectEvent); var I: integer; begin FOnObjectFocus := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnObjectFocus := Handler; end; procedure TFVBase.SetOnObjectBlur(Handler: ThtObjectEvent); var I: integer; begin FOnObjectBlur := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnObjectBlur := Handler; end; procedure TFVBase.SetOnObjectChange(Handler: ThtObjectEvent); var I: integer; begin FOnObjectChange := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnObjectChange := Handler; end; procedure TFVBase.SetOnFileBrowse(Handler: TFileBrowseEvent); var I: integer; begin FOnFileBrowse := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnFileBrowse := Handler; end; procedure TFVBase.SetOnObjectClick(Handler: TObjectClickEvent); var I: integer; begin FOnObjectClick := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnObjectClick := Handler; end; procedure TFVBase.SetMouseDouble(Handler: TMouseEvent); var I: integer; begin FOnMouseDouble := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnMouseDouble := Handler; end; procedure TFVBase.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 TFVBase.SetPrintMarginLeft(Value: Double); var I: integer; begin if FPrintMarginLeft <> Value then begin FPrintMarginLeft := Value; for I := 0 to GetCurViewerCount-1 do CurViewer[I].PrintMarginLeft := Value; end; end; procedure TFVBase.SetPrintMarginRight(Value: Double); var I: integer; begin if FPrintMarginRight <> Value then begin FPrintMarginRight := Value; for I := 0 to GetCurViewerCount-1 do CurViewer[I].PrintMarginRight := Value; end; end; procedure TFVBase.SetPrintMarginTop(Value: Double); var I: integer; begin if FPrintMarginTop <> Value then begin FPrintMarginTop := Value; for I := 0 to GetCurViewerCount-1 do CurViewer[I].PrintMarginTop := Value; end; end; procedure TFVBase.SetPrintMarginBottom(Value: Double); var I: integer; begin if FPrintMarginBottom <> Value then begin FPrintMarginBottom := Value; for I := 0 to GetCurViewerCount-1 do CurViewer[I].PrintMarginBottom := Value; end; end; procedure TFVBase.SetPrintScale(Value: Double); var I: integer; begin if FPrintScale <> Value then begin FPrintScale := Value; for I := 0 to GetCurViewerCount-1 do CurViewer[I].PrintScale := Value; end; end; procedure TFVBase.SetMarginWidth(Value: integer); var I: integer; begin if FMarginWidth <> Value then begin FMarginWidth := Value; for I := 0 to GetCurViewerCount-1 do CurViewer[I].MarginWidth := Value; end; end; procedure TFVBase.SetMarginHeight(Value: integer); var I: integer; begin if FMarginHeight <> Value then begin FMarginHeight := Value; for I := 0 to GetCurViewerCount-1 do CurViewer[I].MarginHeight := Value; end; end; procedure TFVBase.SetPrintHeader(Handler: TPagePrinted); var I: integer; begin FOnPrintHeader := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnPrintHeader := Handler; end; procedure TFVBase.SetPrintFooter(Handler: TPagePrinted); var I: integer; begin FOnPrintFooter := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnPrintFooter := Handler; end; procedure TFVBase.SetPrintHtmlHeader(Handler: THtmlPagePrinted); var I: integer; begin FOnPrintHtmlHeader := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnPrintHtmlHeader := Handler; end; procedure TFVBase.SetPrintHtmlFooter(Handler: THtmlPagePrinted); var I: integer; begin FOnPrintHtmlFooter := Handler; for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnPrintHtmlFooter := Handler; end; procedure TFVBase.SetVisitedMaxCount(Value: integer); var I, J: integer; begin Value := IntMax(Value, 0); if Value <> FVisitedMaxCount then begin FVisitedMaxCount := Value; if FVisitedMaxCount = 0 then begin Visited.Clear; for I := 0 to GetCurViewerCount-1 do with CurViewer[I] do for J := 0 to SectionList.LinkList.Count-1 do TFontObj(LinkList[J]).Visited := False; RePaint; end else begin FVisitedMaxCount := Value; for I := Visited.Count-1 downto FVisitedMaxCount do Visited.Delete(I); end; end; end; {----------------TFVBase.SetColor} procedure TFVBase.SetColor(Value: TColor); var I: integer; begin if (FBackground <> Value) then begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].DefBackground := Value; FBackground := Value; Color := Value; end; end; function TFVBase.GetFontName: TFontName; begin Result := FFontName; end; procedure TFVBase.SetFontName(Value: TFontName); var I: integer; begin if CompareText(Value, FFontName) <> 0 then begin FFontName := Value; for I := 0 to GetCurViewerCount-1 do CurViewer[I].DefFontName := Value; end; end; function TFVBase.GetPreFontName: TFontName; begin Result := FPreFontName; end; procedure TFVBase.SetPreFontName(Value: TFontName); var I: integer; begin if CompareText(Value, FPreFontName) <> 0 then begin FPreFontName := Value; for I := 0 to GetCurViewerCount-1 do CurViewer[I].DefPreFontName := Value; end; end; procedure TFVBase.SetFontSize(Value: integer); var I: integer; begin if (FFontSize <> Value) then begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].DefFontSize := Value; FFontSize := Value; end; end; procedure TFVBase.SetFontColor(Value: TColor); var I: integer; begin if (FFontColor <> Value) then begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].DefFontColor := Value; FFontColor := Value; end; end; procedure TFVBase.SetHotSpotColor(Value: TColor); var I: integer; begin if (FHotSpotColor <> Value) then begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].DefHotSpotColor := Value; FHotSpotColor := Value; end; end; procedure TFVBase.SetActiveColor(Value: TColor); var I: integer; begin if (FOverColor <> Value) then begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].DefOverLinkColor := Value; FOverColor := Value; end; end; procedure TFVBase.SetVisitedColor(Value: TColor); var I: integer; begin if (FVisitedColor <> Value) then begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].DefVisitedLinkColor := Value; FVisitedColor := Value; end; end; {----------------TFVBase.SetHistoryMaxCount} procedure TFVBase.SetHistoryMaxCount(Value: integer); var I: integer; begin if (Value = FHistoryMaxCount) or (Value < 0) then Exit; ClearHistory; for I := 0 to GetCurViewerCount-1 do with CurViewer[I] do begin ClearHistory; HistoryMaxCount := Value; end; FHistoryMaxCount := Value; end; procedure TFVBase.SetCursor(Value: TCursor); var I: integer; begin if Value = OldThickIBeamCursor then Value := crIBeam; if (FCursor <> Value) then begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].Cursor := Value; FCursor := Value; end; end; procedure TFVBase.SetOnPanelCreate(Handler: TPanelCreateEvent); var I: integer; begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnPanelCreate := Handler; FOnPanelCreate := Handler; end; procedure TFVBase.SetOnPanelDestroy(Handler: TPanelDestroyEvent); var I: integer; begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnPanelDestroy := Handler; FOnPanelDestroy := Handler; end; procedure TFVBase.SetOnPanelPrint(Handler: TPanelPrintEvent); var I: integer; begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnPanelPrint := Handler; FOnPanelPrint := Handler; end; procedure TFVBase.SetOnParseBegin(Handler: TParseEvent); var I: integer; begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnParseBegin:= Handler; FOnParseBegin := Handler; end; procedure TFVBase.SetOnParseEnd(Handler: TNotifyEvent); var I: integer; begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnParseEnd:= Handler; FOnParseEnd := Handler; end; Function TFVBase.GetSelLength: integer; var AViewer: ThtmlViewer; begin AViewer := GetActiveViewer; if Assigned(AViewer) then Result := AViewer.SelLength else Result := 0; end; procedure TFVBase.SetSelLength(Value: integer); var AViewer: ThtmlViewer; begin AViewer := GetActiveViewer; if Assigned(AViewer) then AViewer.SelLength := Value; end; Function TFVBase.GetSelStart: integer; var AViewer: ThtmlViewer; begin AViewer := GetActiveViewer; if Assigned(AViewer) then Result := AViewer.SelStart else Result := 0; end; procedure TFVBase.SetSelStart(Value: integer); var AViewer: ThtmlViewer; begin AViewer := GetActiveViewer; if Assigned(AViewer) then AViewer.SelStart := Value; end; {$ifdef ver100_plus} {Delphi 3,4,5, C++Builder 3, 4} procedure TFVBase.SetCharset(Value: TFontCharset); var I: integer; begin if (FCharset <> Value) then begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].Charset := Value; FCharset := Value; end; end; {$endif} procedure TFVBase.SetOnObjectTag(Handler: TObjectTagEvent); var I: integer; begin for I := 0 to GetCurViewerCount-1 do CurViewer[I].OnObjectTag := Handler; FOnObjectTag := Handler; end; {----------------TFVBase.GetOurPalette:} function TFVBase.GetOurPalette: HPalette; begin if ColorBits = 8 then Result := CopyPalette(ThePalette) else Result := 0; end; {----------------TFVBase.SetOurPalette} procedure TFVBase.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; {----------------TFVBase.SetDither} procedure TFVBase.SetDither(Value: boolean); begin if (Value <> FDither) and (ColorBits = 8) then begin FDither := Value; if Value then SetGlobalPalette(ThePalette) else SetGLobalPalette(0); end; end; function TFVBase.GetCaretPos: integer; var Vw: ThtmlViewer; begin Vw := GetActiveViewer; if Assigned(Vw) then Result := Vw.CaretPos else Result := 0; end; procedure TFVBase.SetCaretPos(Value: integer); var Vw: ThtmlViewer; begin Vw := GetActiveViewer; if Assigned(Vw) then Vw.CaretPos := Value; end; function TFVBase.GetSelText: WideString; var AViewer: ThtmlViewer; begin AViewer := GetActiveViewer; if Assigned(AViewer) then Result := AViewer.SelText else Result := ''; end; function TFVBase.GetSelTextBuf(Buffer: PWideChar; BufSize: integer): integer; var AViewer: ThtmlViewer; begin if BufSize <= 0 then Result := 0 else begin AViewer := GetActiveViewer; if Assigned(AViewer) then Result := AViewer.GetSelTextBuf(Buffer, BufSize) else begin Buffer[0] := #0; Result := 1; end; end; end; {----------------TFVBase.InsertImage} function TFVBase.InsertImage(Viewer: ThtmlViewer; const Src: string; Stream: TMemoryStream): boolean; begin try Result := (Viewer as ThtmlViewer).InsertImage(Src, Stream); except Result := True; {consider exceptions done} end; end; procedure TFVBase.SetFocus; var AViewer: ThtmlViewer; begin AViewer := GetActiveViewer; if Assigned(AViewer) and AViewer.CanFocus then try AViewer.SetFocus; except {just in case} inherited SetFocus; end else inherited SetFocus; end; {----------------TFVBase.SetProcessing} procedure TFVBase.SetProcessing(Local, Viewer: boolean); var Change: boolean; begin Change := (Local or Viewer <> FProcessing or FViewerProcessing); FProcessing := Local; FViewerProcessing := Viewer; if Change and Assigned(FOnProcessing) then FOnProcessing(Self, Local or Viewer); end; procedure TFVBase.CheckProcessing(Sender: TObject; ProcessingOn: boolean); begin with ProcessList do begin if ProcessingOn then begin if IndexOf(Sender) = -1 then Add(Sender); end else Remove(Sender); SetProcessing(FProcessing, Count > 0); end; end; {----------------TFVBase.Print} procedure TFVBase.Print(FromPage, ToPage: integer); var AViewer: ThtmlViewer; begin AViewer := GetActiveViewer; if Assigned(AViewer) then AViewer.Print(FromPage, ToPage); end; {----------------TFVBase.NumPrinterPages} function TFVBase.NumPrinterPages(var WidthRatio: double): integer; var AViewer: ThtmlViewer; begin AViewer := GetActiveViewer; if Assigned(AViewer) then Result := AViewer.NumPrinterPages(WidthRatio) else Result := 0; end; function TFVBase.NumPrinterPages: integer; var Dummy: double; begin Result := NumPrinterPages(Dummy); end; {----------------TFVBase.CopyToClipboard} procedure TFVBase.CopyToClipboard; var AViewer: ThtmlViewer; begin AViewer := GetActiveViewer; if Assigned(AViewer) and (AViewer.SelLength <> 0) then AViewer.CopyToClipboard; end; procedure TFVBase.SelectAll; var AViewer: ThtmlViewer; begin AViewer := GetActiveViewer; if Assigned(AViewer) then AViewer.SelectAll; end; {----------------TFVBase.Find} function TFVBase.Find(const S: WideString; MatchCase: boolean): boolean; begin Result := FindEx(S, MatchCase, False); end; {----------------TFVBase.FindEx} function TFVBase.FindEx(const S: WideString; MatchCase, Reverse: boolean): boolean; var AViewer: ThtmlViewer; begin AViewer := GetActiveViewer; if Assigned(AViewer) then Result := AViewer.FindEx(S, MatchCase, Reverse) else Result := False; end; {----------------PositionObj} destructor PositionObj.Destroy; begin FormData.Free; inherited; end; end.