htmlview.pas

查看html文件的控件

{Version 9.4}
{*********************************************************}
{*                     HTMLVIEW.PAS                      *}
{*              Copyright (c) 1995-2006 by               *}
{*                   L. David Baldwin                    *}
{*                 All rights reserved.                  *}
{*********************************************************}

{$i htmlcons.inc}

unit Htmlview;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, StdCtrls,
  vwPrint, MetafilePrinter, mmSystem,
  HTMLUn2, Forms, Dialogs, ExtCtrls, ReadHTML, HTMLSubs, StyleUn, Printers, Menus,
  GDIPL2A;

const
  wm_FormSubmit = wm_User+100;
  wm_MouseScroll = wm_User+102;
  wm_UrlAction = wm_User+103;   

type
  THTMLViewer = class;

  THTMLBorderStyle = (htFocused, htNone, htSingle);
  TRightClickParameters = Class(TObject)
    URL, Target: string;
    Image: TImageObj;
    ImageX, ImageY: integer;
    ClickWord: WideString;   
    end;
  TRightClickEvent = procedure(Sender: TObject; Parameters: TRightClickParameters) of Object;
  THotSpotEvent = procedure(Sender: TObject; const SRC: string) of Object;
  THotSpotClickEvent = procedure(Sender: TObject; const SRC: string;    
                     var Handled: boolean) of Object;
  TProcessingEvent = procedure(Sender: TObject; ProcessingOn: boolean) of Object;
  TPagePrinted = procedure( Sender: TObject;
                              Canvas : TCanvas ;
                              NumPage, W, H: Integer ;
                              var StopPrinting : Boolean) of Object;
  ThtmlPagePrinted = procedure(Sender: TObject; HFViewer: ThtmlViewer;   
                              NumPage: Integer; LastPage: boolean;
                              var XL, XR: integer;
                              var StopPrinting: Boolean) of Object;
  TImageClickEvent = procedure(Sender, Obj: TObject; Button: TMouseButton;
                       Shift: TShiftState; X, Y: Integer) of Object;   
  TImageOverEvent = procedure(Sender, Obj: TObject; Shift: TShiftState;
                       X, Y: Integer) of Object;
  TMetaRefreshType = procedure(Sender: TObject; Delay: integer; const URL: string) of Object;
  TParseEvent = procedure(Sender: TObject; var Source: string) of Object;    

  htOptionEnum = (htOverLinksActive,htNoLinkUnderline,htPrintTableBackground,
                  htPrintBackground, htPrintMonochromeBlack, htShowDummyCaret,
                  htShowVScroll, htNoWheelMouse);  
  ThtmlViewerOptions = set of htOptionEnum;
  ThtProgressEvent = procedure(Sender: TObject; Stage: TProgressStage;
                   PercentDone: integer) of Object;  

  TPaintPanel = class(TCustomPanel)
  private
    FOnPaint: TNotifyEvent;
    FViewer: ThtmlViewer;
    Canvas2: TCanvas;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_EraseBkgnd;
    procedure WMLButtonDblClk(var Message: TWMMouse); message WM_LButtonDblClk;
    procedure DoBackground(ACanvas: TCanvas);
    constructor CreateIt(AOwner: TComponent; Viewer: ThtmlViewer);
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
  public
    procedure Paint; override;
  end;

  T32ScrollBar = Class(TScrollBar)   {a 32 bit scrollbar}
  private
    FPosition: integer;
    FMin, FMax, FPage: integer;
    procedure SetPosition(Value: integer);
    procedure SetMin(Value: Integer);
    procedure SetMax(Value: Integer);
    procedure CNVScroll(var Message: TWMVScroll); message CN_VSCROLL;
  public
    property Position: integer read FPosition write SetPosition;
    property Min: integer read FMin write SetMin;
    property Max: integer read FMax write SetMax;
    procedure SetParams(APosition, APage, AMin, AMax: Integer);
  end;

  ThtmlFileType = (HTMLType, TextType, ImgType, OtherType);

  THTMLViewer = class(TWinControl)
  private
    vwP, OldPrinter: TvwPrinter;       
    fScaleX, fScaleY: single;      
  protected
    InCreate: boolean;
    FOnDragDrop: TDragDropEvent;
    FOnDragOver: TDragOverEvent;
    DontDraw: boolean;
    FTitle: String;
    FURL: String;
    FTarget: String;
    FBase, FBaseEx: String;
    FBaseTarget: String;
    FCurrentFile: String;
    FNameList: TStringList;
    FCurrentFileType: ThtmlFileType;
    FOnHotSpotCovered: THotSpotEvent;
    FOnHotSpotClick: THotSpotClickEvent;
    FOnBitmapRequest: TGetBitmapEvent;
    FOnImageRequest: TGetImageEvent;
    FOnScript: TScriptEvent;
    FOnFormSubmit: TFormSubmitEvent;
    FOnHistoryChange: TNotifyEvent;
    FOnProcessing: TProcessingEvent;
    FOnInclude: TIncludeType;
    FOnSoundRequest: TSoundType;
    FOnLink: TLinkType;
    FOnMeta: TMetaType;
    FOnMetaRefresh: TMetaRefreshType;
    FOnPanelCreate: TPanelCreateEvent;
    FOnPanelDestroy: TPanelDestroyEvent;
    FOnPanelPrint: TPanelPrintEvent;
    FRefreshURL: string;
    FRefreshDelay: Integer;
    FOnRightClick: TRightClickEvent;
    FOnImageClick: TImageClickEvent;
    FOnImageOver: TImageOverEvent;
    FOnObjectClick: TObjectClickEvent;
    FOnFileBrowse: TFileBrowseEvent;
    FOnObjectFocus: ThtObjectEvent;
    FOnObjectBlur: ThtObjectEvent;
    FOnObjectChange: ThtObjectEvent;
    FOnProgress: ThtProgressEvent;
    FHistory, FTitleHistory: TStrings;
    FPositionHistory: TFreeList;
    FHistoryIndex: integer;
    FHistoryMaxCount: integer;
    FFontName: TFontName;
    FPreFontName: String;
    FFontColor: TColor;
    FHotSpotColor, FVisitedColor, FOverColor: TColor;
    FVisitedMaxCount: integer;
    FBackGround: TColor;
    FFontSize: integer;
    FProcessing: boolean;
    FAction, FFormTarget, FEncType, FMethod: String;
    FStringList: TStringList;
    FImageCacheCount: integer;
    FNoSelect: boolean;
    FScrollBars: TScrollStyle;
    FBorderStyle: THTMLBorderStyle;
    FDither: boolean;
    FCaretPos: integer;
    FOptions: ThtmlViewerOptions;
    sbWidth: integer;
    ScrollWidth: integer;
    FMaxVertical: integer;
    MouseScrolling: boolean;
    LeftButtonDown: boolean;
    MiddleScrollOn: boolean;
    MiddleY: integer;
    Hiliting: boolean;
    FPrintMarginLeft,
    FPrintMarginRight,
    FPrintMarginTop,
    FPrintMarginBottom: double;
    FCharset: TFontCharset;   {see htmlun2.pas for Delphi 2 TFontCharSet definition}
    FOnPrintHeader, FOnPrintFooter: TPagePrinted;
    FOnPrintHTMLHeader, FOnPrintHTMLFooter: ThtmlPagePrinted;
    FPage: integer;
    FOnPageEvent: TPageEvent;
    FOnMouseDouble: TMouseEvent;
    HotSpotAction: boolean;
    FMarginHeight, FMarginWidth: integer;
    FServerRoot: string;
    FSectionList: TSectionList;
    FImageStream: TMemoryStream;
    FOnExpandName: TExpandNameEvent;
    HTMLTimer: TTimer;
    FOnhtStreamRequest: TGetStreamEvent;
    LocalBitmapList: boolean;
    FDocumentSource: string;
    FOnParseBegin: TParseEvent;
    FOnParseEnd: TNotifyEvent;
    FTitleAttr: string;
    BGFixed: boolean;
    FPrintScale: double;
    NoJump: boolean;
    FOnLinkDrawn: TLinkDrawnEvent;
    FLinkAttributes: TStringList;     
    FLinkText: WideString;     
    FWidthRatio: double;
    FOnObjectTag: TObjectTagEvent; 

    function CreateHeaderFooter: ThtmlViewer;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure ScrollTo(Y: integer);
    procedure Scroll(Sender: TObject; ScrollCode: TScrollCode;
           var ScrollPos: Integer);
    procedure Layout;
    procedure SetViewImages(Value: boolean);
    function GetViewImages: boolean;
    procedure SetColor(Value: TColor);
    function GetBase: string;
    procedure SetBase(Value: string);
    function GetBaseTarget: string;
    function GetTitle: string;
    function GetCurrentFile: string;
    procedure SetBorderStyle(Value: THTMLBorderStyle);
    function GetPosition: integer;
    procedure SetPosition(Value: integer);
    function GetScrollPos: integer;
    procedure SetScrollPos(Value: integer);
    function GetScrollBarRange: integer;
    function GetHScrollPos: integer;      
    procedure SetHScrollPos(Value: integer);  
    function GetHScrollBarRange: integer;   
    procedure SetHistoryIndex(Value: integer);
    function GetPreFontName: TFontName;
    procedure SetPreFontName(Value: TFontName);
    procedure SetFontSize(Value: integer);
    procedure SetHotSpotColor(Value: TColor);
    procedure SetActiveColor(Value: TColor);
    procedure SetVisitedColor(Value: TColor);   
    procedure SetVisitedMaxCount(Value: integer);  
    procedure SetOnBitmapRequest(Handler: TGetBitmapEvent);
    procedure SetOnImageRequest(Handler: TGetImageEvent);
    procedure SetOnScript(Handler: TScriptEvent);
    procedure SetOnFormSubmit(Handler: TFormSubmitEvent);
    function GetOurPalette: HPalette;
    procedure SetOurPalette(Value: HPalette);
    procedure SetDither(Value: boolean);
    procedure SetCaretPos(Value: integer);
    procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
    procedure BackgroundChange(Sender: TObject);
    procedure SubmitForm(Sender: TObject; const Action, Target, EncType, Method: string;
                Results: TStringList);
    procedure SetImageCacheCount(Value: integer);
    procedure WMFormSubmit(var Message: TMessage); message WM_FormSubmit;
    procedure WMMouseScroll(var Message: TMessage); message WM_MouseScroll;
    procedure WMUrlAction(var Message: TMessage); message WM_UrlAction; 
    procedure SetSelLength(Value: integer);
    procedure SetSelStart(Value: integer);  
    function GetSelLength: integer;   
    function GetSelText: WideString;  
    procedure SetNoSelect(Value: boolean);
    procedure SetHistoryMaxCount(Value: integer);
    procedure DrawBorder;
    procedure DoHilite(X, Y: integer); virtual;    
    procedure SetScrollBars(Value: TScrollStyle);
    procedure SetProcessing(Value: boolean);
    procedure SetCharset(Value: TFontCharset);
    function GetFormControlList: TList;
    function GetNameList: TStringList;
    function GetLinkList: TList;
    procedure SetServerRoot(Value: string);
    procedure SetOnFileBrowse(Handler: TFileBrowseEvent);   
    procedure SetOnObjectClick(Handler: TObjectClickEvent);
    procedure SetOnObjectFocus(Handler: ThtObjectEvent);
    procedure SetOnObjectBlur(Handler: ThtObjectEvent);
    procedure SetOnObjectChange(Handler: ThtObjectEvent);  
    procedure FormControlEnterEvent(Sender: TObject);
    procedure HandleMeta(Sender: TObject; const HttpEq, Name, Content: string);
    procedure SetOptions(Value: ThtmlViewerOptions);
    procedure DoImage(Sender: TObject; const SRC: string; var Stream: TMemoryStream);
    procedure SetOnExpandName(Handler: TExpandNameEvent); 
    function GetWordAtCursor(X, Y: integer; var St, En: integer; var AWord: WideString): boolean;
    procedure SetOnPanelCreate(Handler: TPanelCreateEvent);
    procedure SetOnPanelDestroy(Handler: TPanelDestroyEvent);
    procedure SetOnPanelPrint(Handler: TPanelPrintEvent);
    procedure HTMLTimerTimer(Sender: TObject);
    function GetDragDrop: TDragDropEvent;
    function GetDragOver: TDragOverEvent;
    procedure SetDragDrop(const Value: TDragDropEvent);
    procedure SetDragOver(const Value: TDragOverEvent);
    procedure HTMLDragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure HTMLDragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure InitLoad;
    function GetFormData: TFreeList;
    procedure SetFormData(T: TFreeList);
    function GetIDControl(const ID: string): TObject;    
    function GetIDDisplay(const ID: string): boolean;    
    procedure SetIDDisplay(const ID: string; Value: boolean);
    procedure SetPrintScale(Value: double);

  protected
    { Protected declarations }
    PaintPanel: TPaintPanel;
    BorderPanel: TPanel;
    Sel1: integer;

    procedure DoLogic;
    procedure DoScrollBars;
    procedure SetupAndLogic;
    function GetURL(X, Y: integer; var UrlTarg: TUrlTarget;
             var FormControl: TImageFormControlObj; var ATitle: string): guResultType;
    function GetPalette: HPALETTE; override;
    procedure HTMLPaint(Sender: TObject); virtual;
    procedure HTMLMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); virtual;
{$ifdef ver120_plus}
    procedure HTMLMouseWheel(Sender: TObject; Shift: TShiftState;
      WheelDelta: Integer; MousePos: TPoint);
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override;
{$endif}
    procedure HTMLMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer); virtual;
    procedure HTMLMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); virtual;
    procedure HTMLMouseDblClk(Message: TWMMouse);
    function HotSpotClickHandled: boolean; dynamic;
    procedure LoadFile(const FileName: string; ft: ThtmlFileType); virtual;
    procedure PaintWindow(DC: HDC); override;
    procedure UpdateImageCache;
    procedure DrawBackground2(ACanvas: TCanvas; ARect: TRect; XStart, YStart, XLast, YLast: integer;
              Image: TGpObject; Mask: TBitmap; BW, BH: integer; BGColor: TColor);
    procedure DoBackground1(ACanvas: TCanvas; ATop, AWidth, AHeight, FullHeight: integer);
    procedure DoBackground2(ACanvas: TCanvas; ALeft, ATop, AWidth, AHeight: integer; AColor: TColor);
    procedure LoadString(const Source, Reference: string; ft: ThtmlFileType);

  public
    { Public declarations }
    FrameOwner: TObject;
    VScrollBar: T32ScrollBar;
    HScrollBar: TScrollBar;
    TablePartRec: TTablePartRec;
    Visited: TStringList;     {visited URLs}

    procedure AddVisitedLink(const S: string);  
    procedure CheckVisitedLinks;
    procedure UrlAction;
    procedure TriggerUrlAction;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function HTMLExpandFilename(const Filename: string): string; virtual;
    procedure LoadFromFile(const FileName: string);
    procedure LoadTextFromString(const S: string);
    {$ifdef ver120_plus}  {Delphi 4 and higher}
    procedure LoadFromString(const S: string; const Reference: string = ''); overload;
    {$ifdef Delphi6_Plus}
    procedure LoadFromString(const WS: WideString; const Reference: string = ''); overload;
    {$endif}
    procedure LoadFromStream(const AStream: TStream; const Reference: string = '');
    procedure LoadStrings(const Strings: TStrings; const Reference: string = '');
    procedure LoadFromBuffer(Buffer: PChar; BufSize: integer; const Reference: string = '');
    {$else}
    procedure LoadFromString(const S: string; const Reference: string);
    procedure LoadFromStream(const AStream: TStream; const Reference: string);
    procedure LoadStrings(const Strings: TStrings; const Reference: string);
    procedure LoadFromBuffer(Buffer: PChar; BufSize: integer; const Reference: string);
    {$endif}
    procedure LoadTextFile(const FileName: string);
    procedure LoadImageFile(const FileName: string);
    procedure LoadTextStrings(Strings: TStrings);
    procedure LoadStream(const URL: string; AStream: TMemoryStream; ft: ThtmlFileType);
    procedure Print(FromPage, ToPage: integer);
    function NumPrinterPages: integer; overload;
    function NumPrinterPages(var WidthRatio: double): integer; overload;
    function PrintPreview(MFPrinter: TMetaFilePrinter; NoOutput: boolean = False): integer; 
    function PositionTo(Dest: string): boolean;
    function Find(const S: WideString; MatchCase: boolean): boolean;
    function FindEx(const S: WideString; MatchCase, Reverse: boolean): boolean;
    procedure Clear; virtual;
    procedure CopyToClipboard;
    procedure SelectAll;
    procedure ClearHistory;
    procedure Reload;
    procedure BumpHistory(const FileName, Title: string;
                 OldPos: integer; OldFormData: TFreeList; ft: ThtmlFileType);
    function GetSelTextBuf(Buffer: PWideChar; BufSize: integer): integer;
    function InsertImage(const Src: string; Stream: TMemoryStream): boolean;
    procedure DoEnter; override;
    procedure DoExit; override;
    procedure Repaint; override;
    function FindSourcePos(DisplayPos: integer): integer;
    function FindDisplayPos(SourcePos: integer; Prev: boolean): integer;
    function DisplayPosToXy(DisplayPos: integer; var X, Y: integer): boolean;
    function PtInObject(X, Y: integer; var Obj: TObject): boolean;  {X, Y, are client coord}
    procedure SetStringBitmapList(BitmapList: TStringBitmapList);
    function XYToDisplayPos(X, Y: integer): integer;
    procedure ReplaceImage(const NameID: string; NewImage: TStream);
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure Reformat;
    procedure htProgress(Percent: Integer);
    procedure htProgressEnd;
    procedure htProgressInit;
    function FullDisplaySize(FormatWidth: integer): TSize;
    function MakeBitmap(YTop, FormatWidth, Width, Height: integer): TBitmap;
    function MakeMetaFile(YTop, FormatWidth, Width, Height: integer): TMetaFile;