lazarus-ccr/applications/fpbrowser/viewer_thtmlcomp.pas

unit viewer_thtmlcomp;

{$mode delphi}

interface

uses
  Classes, SysUtils,
  //
  browserviewer,
  //
  HtmlMisc, HTMLsubs, Htmlview, HTMLun2;

type

  { THtmlCompViewer }

  THtmlCompViewer = class(TBrowserViewer)
  private
    Viewer: THTMLViewer;
    FoundObject: TImageObj;
    procedure ViewerMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ViewerProgress(Sender: TObject; Stage: TProgressStage;
      PercentDone: Integer);
    procedure ViewerPrintHTMLFooter(Sender: TObject; HFViewer: THTMLViewer;
      NumPage: Integer; LastPage: Boolean; var XL, XR: Integer;
      var StopPrinting: Boolean);
    procedure ViewerPrintHTMLHeader(Sender: TObject; HFViewer: THTMLViewer;
      NumPage: Integer; LastPage: Boolean; var XL, XR: Integer;
      var StopPrinting: Boolean);
    procedure HotSpotChange(Sender: TObject; const URL: string);
    procedure HotSpotClick(Sender: TObject; const URL: string;
              var Handled: boolean);
    procedure RightClick(Sender: TObject;
      Parameters: TRightClickParameters);
    procedure ViewerImageRequest(Sender: TObject; const SRC: string;
      var Stream: TMemoryStream);
  public
    procedure CreateViewer(AParent, AOwner: TWinControl); override;
    procedure LoadFromFile(AFilename: string); override;
//    procedure LoadFromURL(AURL: string); override;
    function GetDocumentTitle: string; override;
    procedure SetShowImages(AValue: Boolean); override;
    procedure HandlePageLoaderTerminated(Sender: TObject); override;
  end;


implementation

{ THtmlCompViewer }

procedure THtmlCompViewer.ViewerMouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
begin

end;

procedure THtmlCompViewer.ViewerProgress(Sender: TObject;
  Stage: TProgressStage; PercentDone: Integer);
begin

end;

procedure THtmlCompViewer.ViewerPrintHTMLFooter(Sender: TObject;
  HFViewer: THTMLViewer; NumPage: Integer; LastPage: Boolean; var XL,
  XR: Integer; var StopPrinting: Boolean);
begin

end;

procedure THtmlCompViewer.ViewerPrintHTMLHeader(Sender: TObject;
  HFViewer: THTMLViewer; NumPage: Integer; LastPage: Boolean; var XL,
  XR: Integer; var StopPrinting: Boolean);
begin

end;

procedure THtmlCompViewer.HotSpotChange(Sender: TObject; const URL: string);
{mouse moved over or away from a hot spot.  Change the status line}
var
  Caption: string;
begin
  Caption := '';
  if URL <> '' then
    Caption := Caption+'URL: '+URL+'     ';
  if Viewer.TitleAttr <> '' then
    Caption := Caption+'Title: '+Viewer.TitleAttr;
  panelBottom.Caption := Caption;
end;

{This routine handles what happens when a hot spot is clicked.  The assumption
 is made that DOS filenames are being used. .EXE, .WAV, .MID, and .AVI files are
 handled here, but other file types could be easily added.

 If the URL is handled here, set Handled to True.  If not handled here, set it
 to False and ThtmlViewer will handle it.}
procedure THtmlCompViewer.HotSpotClick(Sender: TObject; const URL: string;
  var Handled: boolean);
const
  snd_Async = $0001;  { play asynchronously }
var
  PC: array[0..255] of char;
{$IFDEF LCL}
  PC2: array[0..255] of char;
{$ENDIF}
  S, Params: string[255];
  Ext: string[5];
  ID: string;
  AbsURL: string;
  I, J, K: integer;
begin
  Handled := False;

  {The following looks for a link of the form, "IDExpand_XXX".  This is interpreted
   as meaning a block with an ID="XXXPlus" or ID="XXXMinus" attribute should
   have its Display property toggled.
  }
  I := Pos('IDEXPAND_', Uppercase(URL));
  if I=1 then
  begin
    ID := Copy(URL, 10, Length(URL)-9);
    Viewer.IDDisplay[ID+'Plus'] := not Viewer.IDDisplay[ID+'Plus'];
    Viewer.IDDisplay[ID+'Minus'] := not Viewer.IDDisplay[ID+'Minus'];
    Viewer.Reformat;
    Handled := True;
    Exit;
  end;

  AbsURL := MyPageLoader.URLToAbsoluteURL(URL);
  J := Pos('HTTP:', UpperCase(AbsURL));
  if (J > 0) then
  begin
    LoadURL(AbsURL);
    Handled := True;
    Exit;
  end;

  I := Pos(':', URL);
  J := Pos('FILE:', UpperCase(URL));
  if (I <= 2) or (J > 0) then
  begin                      {apparently the URL is a filename}
    S := URL;
    K := Pos(' ', S);     {look for parameters}
    if K = 0 then K := Pos('?', S);  {could be '?x,y' , etc}
    if K > 0 then
    begin
      Params := Copy(S, K+1, 255); {save any parameters}
      S[0] := chr(K-1);            {truncate S}
    end
    else Params := '';
    S := Viewer.HTMLExpandFileName(S);
    Ext := Uppercase(ExtractFileExt(S));
    if Ext = '.WAV' then
    begin
      Handled := True;
{$IFNDEF LCL}
      sndPlaySound(StrPCopy(PC, S), snd_ASync);
{$ENDIF}
    end
    else if Ext = '.EXE' then
    begin
      Handled := True;
{$IFNDEF LCL}
      WinExec(StrPCopy(PC, S+' '+Params), sw_Show);
{$ELSE}
 {$IFDEF MSWINDOWS}
      ShellExecute(Handle, nil, StrPCopy(PC, S), StrPCopy(PC2, Params),
                 nil, SW_SHOWNORMAL);
 {$ELSE}  //Not sure if this makes any sense since executable won't have .exe.
  {$IFDEF DARWIN}
      Shell('open -n "' + S + '" --args "' + Params + '"');
  {$ELSE}
      Shell('"' + S + '" "' + Params + '"');
  {$ENDIF}
 {$ENDIF}
{$ENDIF}
    end
    else if (Ext = '.MID') or (Ext = '.AVI')  then
    begin
      Handled := True;
{$IFNDEF LCL}
      WinExec(StrPCopy(PC, 'MPlayer.exe /play /close '+S), sw_Show);
{$ELSE}
 {$IFDEF MSWINDOWS}
      ShellExecute(Handle, nil, 'MPlayer.exe', '/play /close',
                 nil, SW_SHOWNORMAL);
 {$ELSE}  //No equivalent to MPlayer?
 {$ENDIF}
{$ENDIF}
    end;
  {else ignore other extensions}
    editURL.Text := URL;
    Exit;
  end;

  I := Pos('MAILTO:', UpperCase(URL));
  if (I > 0) then
  begin
{$IFDEF MSWINDOWS}
    ShellExecute(0, nil, pchar(URL), nil, nil, SW_SHOWNORMAL);
{$ELSE}
 {$IFDEF DARWIN}
    Shell('open "' + URL + '"');
 {$ELSE}
    Shell('"' + URL + '"');  //use LCL's OpenURL?
 {$ENDIF}
{$ENDIF}
    Handled := True;
    Exit;
  end;

  editURL.Text := URL;   {other protocall}
end;

procedure THtmlCompViewer.RightClick(Sender: TObject;
  Parameters: TRightClickParameters);
begin

end;

{ In this event we should provide images for the html component }
procedure THtmlCompViewer.ViewerImageRequest(Sender: TObject;
  const SRC: string; var Stream: TMemoryStream);
var
  J: Integer;
  URL: string;
begin
  URL := MyPageLoader.URLToAbsoluteURL(SRC);

  J := Pos('http:', LowerCase(URL));
  if (J > 0) then
  begin
    MyPageLoader.LoadBinaryResource(URL, Stream);
    Exit;
  end;
end;

procedure THtmlCompViewer.CreateViewer(AParent, AOwner: TWinControl);
begin
  Viewer := THTMLViewer.Create(AOwner);
  Viewer.Left := 1;
  Viewer.Height := 358;
  Viewer.Top := 1;
  Viewer.Width := 611;
  Viewer.OnHotSpotCovered := HotSpotChange;
  Viewer.OnHotSpotClick := HotSpotClick;
  Viewer.OnImageRequest := ViewerImageRequest;
  Viewer.OnFormSubmit := SubmitEvent;
  Viewer.OnHistoryChange := HistoryChange;
  Viewer.OnProgress := ViewerProgress;
  Viewer.TabStop := True;
  Viewer.TabOrder := 0;
  Viewer.Align := alClient;
  Viewer.DefBackground := clWindow;
  Viewer.BorderStyle := htFocused;
  Viewer.HistoryMaxCount := 6;
  Viewer.DefFontName := 'Times New Roman';
  Viewer.DefPreFontName := 'Courier New';
  Viewer.DefFontColor := clWindowText;
  Viewer.DefOverLinkColor := clFuchsia;
  Viewer.ImageCacheCount := 6;
  Viewer.NoSelect := False;
  Viewer.CharSet := DEFAULT_CHARSET;
  Viewer.PrintMarginLeft := 2;
  Viewer.PrintMarginRight := 2;
  Viewer.PrintMarginTop := 2;
  Viewer.PrintMarginBottom := 2;
  Viewer.PrintScale := 1;
  Viewer.OnMouseMove := ViewerMouseMove;
  Viewer.OnProcessing := ProcessingHandler;
  Viewer.OnPrintHTMLHeader := ViewerPrintHTMLHeader;
  Viewer.OnPrintHTMLFooter := ViewerPrintHTMLFooter;
  Viewer.OnInclude := ViewerInclude;
  //Viewer.OnSoundRequest := SoundRequest;
  Viewer.OnMetaRefresh := MetaRefreshEvent;
  Viewer.OnObjectClick := ObjectClick;
  Viewer.OnRightClick := RightClick;
  Viewer.Parent := AParent;

//  ShowImages.Checked := Viewer.ViewImages;
  Viewer.HistoryMaxCount := MaxHistories;  {defines size of history list}
end;

procedure THtmlCompViewer.LoadFromFile(AFilename: string);
begin
  Viewer.LoadFromFile(HtmlToDos(Trim(AFilename)));
end;

function THtmlCompViewer.GetDocumentTitle: string;
begin
  Result := Viewer.DocumentTitle;
end;

procedure THtmlCompViewer.SetShowImages(AValue: Boolean);
begin
  Viewer.ViewImages := AValue;
end;

procedure THtmlCompViewer.HandlePageLoaderTerminated(Sender: TObject);
begin
  inherited HandlePageLoaderTerminated(Sender);

  Viewer.LoadFromString(MyPageLoader.Contents);
  Caption := Viewer.DocumentTitle;
end;

initialization
  SetBrowserViewerClass(THtmlCompViewer);
end.