htmlview.pas

来自「查看html文件的控件」· PAS 代码 · 共 1,969 行 · 第 1/5 页

    function MakePagedMetaFiles(Width, Height: integer): TList;   
    procedure ControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    function GetCharAtPos(Pos: integer; var Ch: WideChar;
                 var Font: TFont): boolean;
    function GetTextByIndices(AStart, ALast: integer): WideString; 
    procedure OpenPrint;     
    procedure ClosePrint;
    procedure AbortPrint;

    property DocumentTitle: string read GetTitle;
    property URL: string read FURL write FURL;
    property Base: string read GetBase write SetBase;
    property BaseTarget: string read GetBaseTarget;
    property Position: integer read GetPosition write SetPosition;
    property VScrollBarPosition: integer read GetScrollPos write SetScrollPos;
    property VScrollBarRange: integer read GetScrollBarRange;
    property HScrollBarPosition: integer read GetHScrollPos write SetHScrollPos;  
    property HScrollBarRange: integer read GetHScrollBarRange;
    property CurrentFile: string read GetCurrentFile;
    property History: TStrings read FHistory;
    property TitleHistory: TStrings read FTitleHistory;
    property HistoryIndex: integer read FHistoryIndex write SetHistoryIndex;
    property Processing: boolean read FProcessing;
    property SelStart: integer read FCaretPos write SetSelStart;
    property SelLength: integer read GetSelLength write SetSelLength;
    property SelText: WideString read GetSelText;   
    property Target: string read FTarget write FTarget;   
    property Palette: HPalette read GetOurPalette write SetOurPalette;
    property Dither: boolean read FDither write SetDither default True;
    property CaretPos: integer read FCaretPos write SetCaretPos;
    property FormControlList: TList read GetFormControlList;
    property NameList: TStringList read GetNameList;
    property LinkList: TList read GetLinkList;
    property SectionList: TSectionList read FSectionList;
    property OnPageEvent: TPageEvent read FOnPageEvent write FOnPageEvent;
    property OnExpandName: TExpandNameEvent read FOnExpandName write SetOnExpandName;
    property FormData: TFreeList read GetFormData write SetFormData;
    property DocumentSource: string read FDocumentSource;
    property MaxVertical: integer read FMaxVertical;
    property TitleAttr: string read FTitleAttr;
    property IDDisplay[const ID: string]: boolean read GetIDDisplay write SetIDDisplay;
    property IDControl[const ID: string]: TObject read GetIDControl;
    property OnLinkDrawn: TLinkDrawnEvent read FOnLinkDrawn write FOnLinkDrawn;
    property LinkAttributes: TStringList read FLinkAttributes;     
    Property LinkText: WideString read FLinkText write FLinkText;     

  published
    { Published declarations }
    property OnHotSpotCovered: THotSpotEvent read FOnHotSpotCovered
             write FOnHotSpotCovered;
    property OnHotSpotClick: THotSpotClickEvent read FOnHotSpotClick
             write FOnHotSpotClick;
    property OnBitmapRequest: TGetBitmapEvent read FOnBitmapRequest
             write SetOnBitmapRequest;
    property OnImageRequest: TGetImageEvent read FOnImageRequest
             write SetOnImageRequest;
    property OnScript: TScriptEvent read FOnScript
             write SetOnScript;
    property OnFormSubmit: TFormSubmitEvent read FOnFormSubmit
             write SetOnFormSubmit;
    property OnHistoryChange: TNotifyEvent read FOnHistoryChange
             write FOnHistoryChange;
    property OnProgress: ThtProgressEvent read FOnProgress write FOnProgress;
    property ViewImages: boolean read GetViewImages write SetViewImages default True;
    property Enabled;
    property TabStop;
    property TabOrder;
    property Align;
    property Name;
    property Tag;
    property PopupMenu;
    property ShowHint;
    {$ifdef ver120_plus}
    property Anchors;       
    {$endif}
    property Height default 150;
    property Width default 150;
    property DefBackground: TColor read FBackground write SetColor default clBtnFace;
    property BorderStyle: THTMLBorderStyle read FBorderStyle write SetBorderStyle;
    property Visible;
    property HistoryMaxCount: integer read FHistoryMaxCount write SetHistoryMaxCount;
    property DefFontName: TFontName read FFontName write FFontName;
    property DefPreFontName: TFontName read GetPreFontName write SetPreFontName;
    property DefFontSize: integer read FFontSize write SetFontSize default 12;
    property DefFontColor: TColor read FFontColor write FFontColor
             default clBtnText;
    property DefHotSpotColor: TColor read FHotSpotColor write SetHotSpotColor
             default clBlue;
    property DefVisitedLinkColor: TColor read FVisitedColor write SetVisitedColor
             default clPurple;
    property DefOverLinkColor: TColor read FOverColor write SetActiveColor
             default clBlue;
    property VisitedMaxCount: integer read FVisitedMaxCount write SetVisitedMaxCount default 50;
    property ImageCacheCount: integer read FImageCacheCount
                write SetImageCacheCount default 5;
    property NoSelect: boolean read FNoSelect write SetNoSelect;
    property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars default ssBoth;
    property CharSet: TFontCharset read FCharSet write SetCharset;
    property MarginHeight: integer read FMarginHeight write FMarginHeight default 5;
    property MarginWidth: integer read FMarginWidth write FMarginWidth default 10;   
    property ServerRoot: string read FServerRoot write SetServerRoot;
    property PrintMarginLeft: double read FPrintMarginLeft write FPrintMarginLeft;
    property PrintMarginRight: double read FPrintMarginRight write FPrintMarginRight;
    property PrintMarginTop: double read FPrintMarginTop write FPrintMarginTop;
    property PrintMarginBottom: double read FPrintMarginBottom write FPrintMarginBottom;
    property PrintScale: double read FPrintScale write SetPrintScale;
    property htOptions: ThtmlViewerOptions read FOptions write SetOptions
                 default [htPrintTableBackground, htPrintMonochromeBlack];

    property OnMouseMove;
    property OnMouseUp;
    property OnMouseDown;
    {$ifdef ver120_plus}
    property OnMouseWheel;    
    {$endif}
    property OnKeyDown;
    property OnKeyUp;
    property OnKeyPress;
    property OnEnter;
    property OnExit;     
    property OnProcessing: TProcessingEvent read FOnProcessing write FOnProcessing;
    property OnPrintHeader: TPagePrinted read FOnPrintHeader write FOnPrintHeader;
    property OnPrintFooter: TPagePrinted read FOnPrintFooter write FOnPrintFooter;
    property OnPrintHTMLHeader: ThtmlPagePrinted read FOnPrintHTMLHeader write FOnPrintHTMLHeader;
    property OnPrintHTMLFooter: ThtmlPagePrinted read FOnPrintHTMLFooter write FOnPrintHTMLFooter;
    property OnInclude: TIncludeType read FOnInclude write FOnInclude;
    property OnSoundRequest: TSoundType read FOnSoundRequest write FOnSoundRequest;
    property OnMeta: TMetaType read FOnMeta write FOnMeta;
    property OnLink: TLinkType read FOnLink write FOnLink;
    property OnMetaRefresh: TMetaRefreshType read FOnMetaRefresh write FOnMetaRefresh;
    property OnImageClick: TImageClickEvent read FOnImageClick write FOnImageClick;
    property OnImageOver: TImageOverEvent read FOnImageOver write FOnImageOver;
    property OnFileBrowse: TFileBrowseEvent read FOnFileBrowse write SetOnFileBrowse;    
    property OnObjectClick: TObjectClickEvent read FOnObjectClick write SetOnObjectClick;
    property OnObjectFocus: ThtObjectEvent read FOnObjectFocus write SetOnObjectFocus;
    property OnObjectBlur: ThtObjectEvent read FOnObjectBlur write SetOnObjectBlur;
    property OnObjectChange: ThtObjectEvent read FOnObjectChange write SetOnObjectChange;  
    property OnRightClick:  TRightClickEvent read FOnRightClick write FOnRightClick;
    property OnMouseDouble: TMouseEvent read FOnMouseDouble write FOnMouseDouble;
    property OnPanelCreate: TPanelCreateEvent read FOnPanelCreate write SetOnPanelCreate;
    property OnPanelDestroy: TPanelDestroyEvent read FOnPanelDestroy write SetOnPanelDestroy;
    property OnPanelPrint: TPanelPrintEvent read FOnPanelPrint write SetOnPanelPrint;   
    property OnDragDrop: TDragDropEvent read GetDragDrop write SetDragDrop;
    property OnDragOver: TDragOverEvent read GetDragOver write SetDragOver;
    property OnhtStreamRequest: TGetStreamEvent read FOnhtStreamRequest
                  write FOnhtStreamRequest;
    property OnParseBegin: TParseEvent read FOnParseBegin write FOnParseBegin;
    property OnParseEnd: TNotifyEvent read FOnParseEnd write FOnParseEnd;
    property OnObjectTag: TObjectTagEvent read FOnObjectTag write FOnObjectTag;  
    end;

implementation

uses
  Clipbrd, htmlgif2;    

const
  MaxHScroll = 6000;  {max horizontal display in pixels}
  ScrollGap = 20;

type
  PositionObj = class(TObject)
    Pos: integer;
    FileType: ThtmlFileType;
    FormData: TFreeList;       
    destructor Destroy; override;
    end;

constructor THTMLViewer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
InCreate := True;
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  csSetCaption, csDoubleClicks]; 
Height := 150;
Width := 150;
FPrintMarginLeft := 2.0;
FPrintMarginRight := 2.0;
FPrintMarginTop := 2.0;
FPrintMarginBottom := 2.0;
FPrintScale := 1.0;
FCharset := DEFAULT_CHARSET;
FMarginHeight := 5;
FMarginWidth := 10;

BorderPanel := TPanel.Create(Self);  
BorderPanel.BevelInner := bvNone;
BorderPanel.BevelOuter := bvNone;
BorderPanel.Ctl3D := False;
BorderPanel.Align := alClient;
BorderPanel.ParentCtl3D := False;
{$ifdef delphi7_plus}
BorderPanel.ParentBackground := False;
{$endif}

BorderPanel.Parent := Self;

PaintPanel := TPaintPanel.CreateIt(Self, Self);
PaintPanel.ParentFont := False;
PaintPanel.Parent := Self;
PaintPanel.Top := 1;
PaintPanel.Left := 1;
PaintPanel.BevelOuter := bvNone;
PaintPanel.BevelInner := bvNone;
PaintPanel.ctl3D := False;

PaintPanel.OnPaint := HTMLPaint;
PaintPanel.OnMouseDown := HTMLMouseDown;
PaintPanel.OnMouseMove := HTMLMouseMove;
PaintPanel.OnMouseUp := HTMLMouseUp;

VScrollBar := T32ScrollBar.Create(Self);
VScrollBar.Kind := sbVertical;
VScrollBar.SmallChange := 16;
VScrollBar.Visible := False;
VScrollBar.TabStop := False;
sbWidth := VScrollBar.Width;
VScrollBar.Parent := Self;

HScrollBar := TScrollBar.Create(Self);
HScrollBar.Kind := sbHorizontal;
HScrollBar.SmallChange := 15;
HScrollBar.OnScroll := Scroll;
HScrollBar.Visible := False;
HScrollBar.TabStop := False;
HScrollBar.Parent := Self;
HScrollBar.Width := sbWidth;  

FScrollBars := ssBoth;

FSectionList := TSectionList.Create(Self, PaintPanel);
FSectionList.ControlEnterEvent := FormControlEnterEvent;
FSectionList.OnBackgroundChange := BackgroundChange;
FSectionList.ShowImages := True;    
FNameList := FSectionList.IDNameList;

DefBackground := clBtnFace;
DefFontColor                                                                                             := clBtnText;
DefHotSpotColor := clBlue;
DefOverLinkColor := clBlue;
DefVisitedLinkColor := clPurple;
FVisitedMaxCount := 50;
DefFontSize := 12;
DefFontName := 'Times New Roman';
DefPreFontName := 'Courier New';
SetImageCacheCount(5);
SetOptions([htPrintTableBackground, htPrintMonochromeBlack]);

FHistory := TStringList.Create;
FPositionHistory := TFreeList.Create;
FTitleHistory := TStringList.Create;
FDither := True;

Visited := TStringList.Create;
HTMLTimer := TTimer.Create(Self);   
HTMLTimer.Enabled := False;
HTMLTimer.Interval := 200;
HTMLTimer.OnTimer := HTMLTimerTimer;
FLinkAttributes := TStringList.Create;   
InCreate := False;
end;

destructor ThtmlViewer.Destroy;
begin
if LocalBitmapList then
  begin
  FSectionList.Clear;
  FSectionList.BitmapList.Free;
  end;
FSectionList.Free;
FHistory.Free;
FPositionHistory.Free;
FTitleHistory.Free;
Visited.Free;
HTMLTimer.Free;
FLinkAttributes.Free;   
AbortPrint;    
inherited Destroy;
end;

procedure THtmlViewer.SetupAndLogic;
begin
FTitle := ReadHTML.Title;
if ReadHTML.Base <> '' then
  FBase := ReadHTML.Base
else FBase := FBaseEx;
FBaseTarget := ReadHTML.BaseTarget;
if Assigned(FOnParseEnd) then   
  FOnParseEnd(Self);
try
  DontDraw := True;
  {Load the background bitmap if any and if ViewImages set}
  FSectionList.GetBackgroundBitmap;

DoLogic;

finally
  DontDraw := False;
  end;
end;

procedure ThtmlViewer.LoadFile(const FileName: string; ft: ThtmlFileType);
var
  I: integer;
  Dest, FName, OldFile: string;
  SBuffer: string;
  OldCursor: TCursor;
  FS: TFileStream;       
begin
with Screen do
  begin
  OldCursor := Cursor;
  Cursor := crHourGlass;
  end;
IOResult;   {eat up any pending errors}
FName := FileName;
I := Pos('#', FName);
if I > 0 then
  begin
  Dest := Copy(FName, I+1, Length(FName)-I);  {positioning information} 
  FName := Copy(FName, 1, I-1);
  end
else Dest := '';
FRefreshDelay := 0;
try
  SetProcessing(True);
  if not FileExists(FName) then
    Raise(EInOutError.Create('Can''t locate file: '+FName));
  FSectionList.ProgressStart := 75;  
  htProgressInit;    
  DontDraw := True;  
  InitLoad;
  CaretPos := 0;
  Sel1 := -1;
  try
    OldFile := FCurrentFile;
    FCurrentFile := ExpandFileName(FName);
    FCurrentFileType := ft;
    if ft in [HTMLType, TextType] then
      begin
      FS := TFileStream.Create(FName, fmOpenRead or fmShareDenyWrite);   
      try
        SetLength(FDocumentSource, FS.Size);
        FS.ReadBuffer(FDocumentSource[1], FS.Size);
      finally
        FS.Free;
        end;
      end
    else FDocumentSource := '';
    if Assigned(FOnParseBegin) then   
      FOnParseBegin(Self, FDocumentSource);
    if ft = HTMLType then
      begin
      if Assigned(FOnSoundRequest) then
        FOnSoundRequest(Self, '', 0, True);
      ParseHTMLString(FDocumentSource, FSectionList, FOnInclude, FOnSoundRequest, HandleMeta, FOnLink);
      end
    else if ft = TextType then
      ParseTextString(FDocumentSource, FSectionList)
    else
      begin
      SBuffer := '<img src="'+FName+'">';
      ParseHTMLString(SBuffer, FSectionList, Nil, Nil, Nil, Nil);
      end;
  finally
    SetupAndLogic;
    CheckVisitedLinks;
    if (Dest <> '') and PositionTo(Dest) then  {change position, if applicable}
    else if FCurrentFile <> OldFile then
       begin
       ScrollTo(0);
       HScrollBar.Position := 0;
       end;
    {else if same file leave position alone}
    DontDraw := False;      
    PaintPanel.Invalidate;
  end;
finally
  Screen.Cursor := OldCursor;
  htProgressEnd;    
  SetProcessing(False);
  end;
if (FRefreshDelay > 0) and Assigned(FOnMetaRefresh) then
  FOnMetaRefresh(Self, FRefreshDelay, FRefreshURL);
end;

procedure ThtmlViewer.LoadFromFile(const FileName: string);
var
  OldFile, OldTitle: string;
  OldPos: integer;
  OldType: ThtmlFileType;
  OldFormData: TFreeList;
  (*Stream: TMemoryStream;  //debugging aid
  Indent, Tree: string; *)