{ *****************************************************************************
  WARNING: This component file was generated using the EventSinkImp utility.
           The contents of this file will be overwritten everytime EventSinkImp
           is asked to regenerate this sink component.

  NOTE:    When using this component at the same time with the XXX_TLB.pas in
           your Delphi projects, make sure you always put the XXX_TLB unit name
           AFTER this component unit name in the USES clause of the interface
           section of your unit; otherwise you may get interface conflict
           errors from the Delphi compiler.

           EventSinkImp is written by Binh Ly (bly@techvanguards.com)
  *****************************************************************************
  //Sink Classes//
  TMSHTMLHTMLElementEvents
  TMSHTMLHTMLElementEvents2
  TMSHTMLHTMLLinkElementEvents
  TMSHTMLHTMLLinkElementEvents2
  TMSHTMLHTMLFormElementEvents
  TMSHTMLHTMLFormElementEvents2
  TMSHTMLHTMLImgEvents
  TMSHTMLHTMLImgEvents2
  TMSHTMLHTMLTextContainerEvents
  TMSHTMLHTMLTextContainerEvents2
  TMSHTMLHTMLAnchorEvents
  TMSHTMLHTMLAnchorEvents2
  TMSHTMLHTMLLabelEvents
  TMSHTMLHTMLLabelEvents2
  TMSHTMLHTMLSelectElementEvents
  TMSHTMLHTMLSelectElementEvents2
  TMSHTMLHTMLInputTextElementEvents
  TMSHTMLHTMLInputTextElementEvents2
  TMSHTMLHTMLOptionButtonElementEvents
  TMSHTMLHTMLButtonElementEvents
  TMSHTMLHTMLButtonElementEvents2
  TMSHTMLHTMLMarqueeElementEvents
  TMSHTMLHTMLMarqueeElementEvents2
  TMSHTMLHTMLWindowEvents
  TMSHTMLHTMLWindowEvents2
  TMSHTMLHTMLDocumentEvents
  TMSHTMLHTMLDocumentEvents2
  TMSHTMLDWebBridgeEvents
  TMSHTMLHTMLControlElementEvents
  TMSHTMLHTMLControlElementEvents2
  TMSHTMLHTMLMapEvents
  TMSHTMLHTMLMapEvents2
  TMSHTMLHTMLAreaEvents
  TMSHTMLHTMLAreaEvents2
  TMSHTMLHTMLTableEvents
  TMSHTMLHTMLTableEvents2
  TMSHTMLHTMLScriptEvents
  TMSHTMLHTMLScriptEvents2
  TMSHTMLHTMLObjectElementEvents
  TMSHTMLHTMLObjectElementEvents2
  TMSHTMLHTMLFrameSiteEvents
  TMSHTMLHTMLFrameSiteEvents2
  TMSHTMLHTMLStyleElementEvents
  TMSHTMLHTMLStyleElementEvents2
  TMSHTMLHTMLNamespaceEvents
  TMSHTMLHTMLInputFileElementEvents
  TMSHTMLHTMLInputImageEvents
}

{$IFDEF VER100}
{$DEFINE D3}
{$ENDIF}

{$IFDEF CONDITIONALEXPRESSIONS}
{$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}

//SinkUnitName//
unit MSHTMLEvents;

interface

uses
  Windows, ActiveX, Classes, ComObj, OleCtrls
  //SinkUses//
  , StdVCL
  , MSHTML_EWB
  ;

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Buttons, MSHTMLEvents, MSHTML_EWB, SHDocVw_EWB,
  OleServer, Shell32_TLB;

type
  TForm1 = class(TForm)
    Shell1: TShell;
    Button1: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    Memo2: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    FSinkComponent : TMSHTMLHTMLDocumentEvents;
  public
    { Public 宣言 }
    function DocOnClick(Sender: TObject): WordBool;
    function DocSelectStart(Sender: TObject): WordBool;
  end;

var
  Form1: TForm1;

implementation

uses ShellAPI, ActiveX;

{$R *.dfm}

//=============================================================================
//  [IE起動]ボタン
//  ウェブページを表示して，イベントシンク用コンポーネント生成
//  IEは新規起動
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  AppStr    : String;
  AppCmd    : String;
  ShWindows : ShellWindows;
  IECount   : Integer;
  IEObj     : InternetExplorer;
  iDoc2     : IHTMLDocument2;
begin
  //シェルウインドウのオブジェクトを取得したら，現在のウィンドウ数を取得しておく
  //この数が1つ増加したら，新規起動完了とみなすため
  ShWindows := Shell1.Windows as ShellWindows;
  IECount   := ShWindows.Count;

  //IE起動．IEは関連付けのあるアプリなのでフルパスでなくても起動可能
  AppStr := 'IEXPLORE.EXE';
  AppCmd := 'http://mrxray.on.coocan.jp/';
  ShellExecute(Handle, 'open', PChar(AppStr), PChar(AppCmd), nil, SW_SHOW);

  //起動中のシェルウィンドウの数が増加したら新規起動完了とみなす
  while ShWindows.Count <= IECount do begin
    Application.ProcessMessages;
  end;

  //そのウィンドウの内，最後に起動したIEのオブジェクトを取得
  IEObj := ShWindows.Item(ShWindows.Count - 1) as InternetExplorer;
  //表示完了まで待つ
  while IEObj.ReadyState < READYSTATE_INTERACTIVE do begin
    Application.ProcessMessages;
  end;

  //------ IE 起動終了 --------------------------------------------------------

  //イベントシンクコンポーネントを生成
  //ここでは，TMSHTMLHTMLDocumentEventsをテストする
  FSinkComponent := TMSHTMLHTMLDocumentEvents.Create(Self);

  //OnSelectStartとOnClickイベントを定義
  FSinkComponent.onselectstart := DocSelectStart;
  FSinkComponent.OnClick       := DocOnClick;

  //イベントシンク接続
  //一応QueryInterfaceでチェック
  iDoc2 := IEObj.Document as IHTMLDocument2;
  if Succeeded(IEObj.Document.QueryInterface(IID_IHTMLDocument2, iDoc2)) then begin
    FSinkComponent.Connect(iDoc2);
  end;
end;

//=============================================================================
//  OnClickイベント処理用の関数
//=============================================================================
function TForm1.DocOnClick(Sender: TObject): WordBool;
var
  iElement : IHTMLElement;
  iDoc2    : IHTMLDocument2;
begin
  Result := False;

  LabeledEdit1.Text := '';
  LabeledEdit2.Text := '';
  Memo2.Lines.Text  := '';

  //SenderはTMSHTMLHTMLDocumentEventsコンポ
  iDoc2 := TMSHTMLHTMLDocumentEvents(Sender).Source as IHTMLDocument2;

  if iDoc2 <> nil then begin
    iElement := iDoc2.activeElement;

    //リンクを設定してあるエレメントはそのリンクも検出するために親とする
    if iElement.parentElement.tagName = 'A' then begin
      iElement := iElement.parentElement;
    end;

    //tag属性を表示
    LabeledEdit1.Text := iElement.tagName;

    //href属性を表示
    if iElement.getAttribute( 'href', 0) <> null then begin
      LabeledEdit2.Text := iElement.getAttribute( 'href', 0);
    end;

    //エレメントのソースを表示
    Memo2.Text := iElement.innerText;
    Result := True;
  end;
end;

//=============================================================================
//  OnSelectStartイベント処理用の関数
//=============================================================================
function TForm1.DocSelectStart(Sender: TObject): WordBool;
var
  iDoc2 : IHTMLDocument2;
begin
  Result := True;

  //SenderはTMSHTMLHTMLDocumentEventsコンポ
  iDoc2 :=  TMSHTMLHTMLDocumentEvents(Sender).Source as IHTMLDocument2;

  if iDoc2 <> nil then begin
    Result := False;
    Memo2.Lines.Text := '選択操作を禁止しています．';
  end;
end;


end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, OleCtrls, Buttons, EwbEvents, MSHTML_EWB,
  SHDocVw_EWB, OleServer, Shell32_TLB, EwbEventsComp;

type
  TForm1 = class(TForm)
    HtmlListener1: THtmlListener;
    Shell1: TShell;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    Memo2: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure HtmlListener1HandlersOnMouseMoveHandle(Sender: TObject;
      Event: IHTMLEventObj);
    procedure HtmlListener1HandlersOnClickHandle(Sender: TObject;
      Event: IHTMLEventObj);
  private
    { Private 宣言 }
    HubLinksList : TInterfaceList;
    HubLink      : IHubLink;
    IEObj        : InternetExplorer;
    procedure ConnectHtmlListeners;
    procedure ConnectHtmlListener(ASender: TObject; Doc: IHTMLDocument2);
    procedure DisconnectHtmlListeners;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses ShellAPI, ActiveX;

{$R *.dfm}

//-----------------------------------------------------------------------------
//  TEmbededdWBコンポのGetFrameメソッドの代用関数
//  元のIHTMLDocument2からIWebbrowser2オブジェクトを取得
//
//  usesにMSHTML_EWB, SHDocVw_EWB, ActiveXが必要
//  TEmbededdWBコンポを使用しない場合は，MSHTML, SHDocVw, ActiveXでもよい
//-----------------------------------------------------------------------------
function GetFrameFromID(ADoc2: IHTMLDocument2; FrameNo: Word): IWebbrowser2;
var
  OleContainer : IOleContainer;
  Enum         : ActiveX.IEnumUnknown;
  Unk          : IUnknown;
  Fetched      : PLongint;
begin
  Result := nil;
  if Assigned(ADoc2) then begin
    Fetched := nil;
    OleContainer := ADoc2 as IOleContainer;
    OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
    Enum.Skip(FrameNo);
    Enum.Next(1, Unk, Fetched);
    if Supports(Unk, IWebBrowser2, Result) then begin
      Result := Unk as IWebbrowser2;
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  TEmbededdWBコンポのGetActiveFrameメソッドの代用関数
//  アクティブなフレームのIHTMLDocument2オブジェクトを求める
//
//  usesにMSHTML_EWB, SHDocVw_EWB, ActiveXが必要
//  TEmbededdWBコンポを使用しない場合は，MSHTML, SHDocVw, ActiveXでもよい
//-----------------------------------------------------------------------------
function GetActiveFrameDoc2(Doc: IHTMLDocument2): IHTMLDocument2;

  //---------------------------------------------------------------------------
  //  実際の処理
  //  フレームはネストしている場合がほとんどなので再帰処理
  //---------------------------------------------------------------------------
  function GetActiveFrame(Doc: IHTMLDocument2): IHTMLDocument2;
  var
    Element      : IHTMLElement;
    Frame        : IHTMLFrameElement;
    WB           : IWebBrowser2;
    HTMLDocument : IHTMLDocument2;
    HtmlDoc2     : IHTMLDocument2;
  begin
    Result := nil;
    if Supports(Doc, IHTMLDocument2, HtmlDoc2) then begin
      Element := Doc.activeElement;
      if Assigned(Element) then begin
        if Element.QueryInterface(IHTMLFrameElement, Frame) = S_OK then begin
          if Frame.QueryInterface(IID_IWebBrowser2, WB) = S_OK then begin
            if Assigned(WB.Document) then begin
              if WB.Document.QueryInterface(IID_IHTMLDocument2,
                                            HTMLDocument) = S_OK then begin
                Result := GetActiveFrame(HTMLDocument);
              end;
            end;
          end;
        end;
      end;
    end;
    if Result = nil then Result := doc;
  end;
  //---------------------------------------------------------------------------

var
  HtmlDoc2: IHTMLDocument2;
begin
  if Supports(Doc, IHTMLDocument2, HtmlDoc2) then
    Result := GetActiveFrame(HtmlDoc2);
end;

//=============================================================================
//  フォームを生成したら，リスナー管理用のリストを作成しておく
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  HubLinksList := TInterfaceList.Create;
end;

//=============================================================================
//  リスナーの解放処理
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  DisconnectHtmlListeners;
  HubLinksList.Free;
end;

//=============================================================================
//  [IE起動]ボタン
//  ウェブページを表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  AppStr    : String;
  AppCmd    : String;
  ShWindows : ShellWindows;
  IECount   : Integer;
begin
  //シェルウインドウのオブジェクトを取得したら，現在のウィンドウ数を取得しておく
  //この数が1つ増加したら，新規起動完了とみなすため
  ShWindows := Shell1.Windows as ShellWindows;
  IECount   := ShWindows.Count;

  //IE起動．IEは関連付けのあるアプリなのでフルパスでなくても起動可能
  AppStr := 'IEXPLORE.EXE';
  AppCmd := 'http://ht-deko.com/Delphi/';
  ShellExecute(Handle, 'open', PChar(AppStr), PChar(AppCmd), nil, SW_SHOW);

  //起動中のシェルウィンドウの数が増加したら新規起動完了とみなす
  while ShWindows.Count <= IECount do begin
    Application.ProcessMessages;
  end;

  //そのウィンドウの内，最後に起動したIEのオブジェクトを取得
  IEObj := ShWindows.Item(ShWindows.Count - 1) as InternetExplorer;
end;

//=============================================================================
//  [選択テキスト]ボタン
//  クリックすると，現在選択中のテキストの文字列を表示
//  このコードはイベントシンク(リスナー)を登録しなくても動作する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  iDoc2   : IHTMLDocument2;
  HTMLDoc : IHTMLDocument2;
  StrText : String;
begin
  iDoc2   := IEObj.Document as IHTMLDocument2;
  HTMLDoc := GetActiveFrameDoc2(iDoc2);

  if iDoc2 <> nil then begin
    StrText := (HTMLDoc.selection.createRange as IHTMLTxtRange).Text;
    MessageBox(Handle, PChar(StrText), '選択テキスト', MB_OK);
 end;
end;

//=============================================================================
//  [リスナー接続]ボタン
//  表示ウェブページを変更したらこのボタンをクリックして，リスナーを再登録する
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
begin
  DisconnectHtmlListeners;
  ConnectHtmlListeners;
end;

//=============================================================================
//  THtmlListener(リスナー)の接続用関数
//  表示フレーム分の接続処理をしてリスト(TInterfaceList)に追加しておく
//  フレームはネストしている場合がほとんどなので再帰処理としている
//
//  表示ページを変更した時はこの関数を実行してリスナーを再登録する
//
//  HubLink(IHubLink)の使用にはusesにEwbEventsが必要
//=============================================================================
procedure TForm1.ConnectHtmlListeners;

  //---------------------------------------------------------------------------
  //  フレームの接続の実際の処理(再帰処理)
  //---------------------------------------------------------------------------
  procedure SetHTMListnerAllFrames(ADoc: IHTMLDocument2);
  var
    i    : Integer;
    WB   : IWebbrowser2;
    iDoc : IHTMLDocument2;
  begin
    for i := 0 to ADoc.frames.length - 1 do  begin
      WB := GetFrameFromID(ADoc, i);
      if Assigned(WB) then begin
        if Succeeded(WB.Document.QueryInterface(IHTMLDocument2, iDoc)) then begin
          //このiDoc(IHTMLDocument2オブジェクト)が実際のフレームのドキュメント
          //リスナーの接続処理．このフレームで発生したイベントが取得可能となる
          //iDoc.body.innerHTML;でこのフレームのinnerHTMLのソースが取得できる
          ConnectHtmlListener(nil, iDoc);
          //ネストしたフレーム用に再帰処理
          SetHTMListnerAllFrames(iDoc);
        end;
      end;
    end;
  end;
  //---------------------------------------------------------------------------

var
  iDoc2 : IHTMLDocument2;
begin
  if not Assigned(IEObj) then exit;

  iDoc2 := IEObj.Document as IHTMLDocument2;
  //フレームページではないメインのページの接続
  ConnectHtmlListener(nil, iDoc2);
  //フレームの接続処理
  SetHTMListnerAllFrames(iDoc2);
end;

//=============================================================================
//  THtmlListener(リスナー)の接続用関数
//  イベントシンクは，フレームページ(IHTMLDocument2オブジェクト)ごとに必要なの
//  で，表示フレーム数の分だけこの関数を実行して，リスト(TInterfaceList)に追加
//  しておく
//
//  TEmbeddedWBコンポであれば，フレーム表示のたびにOnDocumentCompleteイベント
//  が発生するので，そのイベント内で処理可能
//=============================================================================
procedure TForm1.ConnectHtmlListener(ASender: TObject; Doc: IHTMLDocument2);
var
  CPC : IConnectionPointContainer;
begin
  if not Assigned(Doc) then exit;

  Doc.QueryInterface(IConnectionPointContainer, CPC);
  if Assigned(CPC) then begin
    HubLink := HtmlListener1.Connect2(CPC);
    HubLinksList.Add(HubLink);
  end;
end;

//=============================================================================
//  THtmlListener(リスナー)の切断処理用の関数
//=============================================================================
procedure TForm1.DisconnectHtmlListeners;
var
  i: Integer;
begin
  for i := HubLinksList.Count - 1 downto 0 do begin
    (HubLinksList[i] as IHubLink).Disconnect;
    HubLinksList.Remove(HubLinksList[i]);
  end;
end;

//=============================================================================
//  OnMouseMoveイベント処理
//  マウスカーソル下のエレメント(要素)の情報を表示
//
//  THtmlListnerのHandlesプロパティのEventID=eiOnMouseMoveのOnHadleイベント
//  THtmlListnerのSinkKindプロパティはskDocument
//=============================================================================
procedure TForm1.HtmlListener1HandlersOnMouseMoveHandle(Sender: TObject;
  Event: IHTMLEventObj);
var
  iElement : IHTMLElement;
begin
  iElement := Event.srcElement;

  LabeledEdit1.Text := '';
  LabeledEdit2.Text := '';
  Memo2.Lines.Text  := '';

  Memo2.Lines.Text := iElement.innerHTML;

  if iElement.getAttribute( 'src', 0) <> null then begin
    LabeledEdit1.Text := iElement.getAttribute( 'src', 0);
  end;

  //リンクを設定してあるエレメントはそのリンクも検出するために親とする
  if iElement.parentElement.tagName = 'A' then begin
    iElement := iElement.parentElement;
  end;

  if iElement.getAttribute( 'href', 0) <> null then begin
    LabeledEdit2.Text := iElement.getAttribute( 'href', 0);
  end;
end;

//=============================================================================
//  OnClickイベント処理
//  マウスクリックしたクライアント座標値を表示
//
//  THtmlListnerのHandlesプロパティのEventID=eiOnClickのOnHadleイベント
//  THtmlListnerのSinkKindプロパティはskDocument
//=============================================================================
procedure TForm1.HtmlListener1HandlersOnClickHandle(Sender: TObject;
  Event: IHTMLEventObj);
begin
  LabeledEdit3.Text := 'X: '  + IntToStr(Event.x) + '  ' +
                       'Y: '  + IntToStr(Event.y);
end;

end.

procedure TForm1.Button2Click(Sender: TObject);
var
  StrText : String;
begin
  StrText := EmbeddedWB1.GetSelectedText;
  MessageBox(Handle, PChar(StrText), '選択テキスト', MB_OK);
end;

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, OleCtrls, Buttons, EwbEvents, MSHTML_EWB,
  SHDocVw_EWB, EwbCore, EmbeddedWB, EwbEventsComp;

type

  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    LabeledEdit1: TLabeledEdit;
    LabeledEdit2: TLabeledEdit;
    LabeledEdit3: TLabeledEdit;
    Memo2: TMemo;
    EmbeddedWB1: TEmbeddedWB;
    HtmlListener1: THtmlListener;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure HtmlListener1HandlersOnMouseMoveHandle(Sender: TObject;
      Event: IHTMLEventObj);
    procedure EmbeddedWB1BeforeNavigate2(ASender: TObject;
      const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
      Headers: OleVariant; var Cancel: WordBool);
    procedure EmbeddedWB1DocumentComplete(ASender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
    procedure HtmlListener1HandlersOnClickHandle(Sender: TObject;
      Event: IHTMLEventObj);
    procedure EmbeddedWB1NewWindow3(ASender: TObject; var ppDisp: IDispatch;
      var Cancel: WordBool; dwFlags: Cardinal; const bstrUrlContext,
      bstrUrl: WideString);
  private
    { Private 宣言 }
    HubLinksList: TInterfaceList; //イベントのトラップに必要
    HubLink: IHubLink;
    procedure ConnectHtmlListener(ASender: TObject; Doc: IHTMLDocument2);
    procedure DisconnectHtmlListeners;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses ActiveX;

{$R *.dfm}

//=============================================================================
//  フォームを生成したら，リスナー管理用のリストを作成しておく
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  HubLinksList := TInterfaceList.Create;
end;

//=============================================================================
//  リスナーの解放処理
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  DisconnectHtmlListeners;
  HubLinksList.Free;
end;

//=============================================================================
//  [ページ表示]ボタン
//  ウェブページを表示
//
//  [注意]
//  TEmbeddedWBでMSHtMLの機能を使用する場合は，MSHTML_EWBを利用する(usesに追加)
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  AURL : String;
begin
  //指定のURLを表示
  AURL := 'http://ht-deko.com/Delphi/';
  EmbeddedWB1.Navigate(AURL);
end;

//=============================================================================
//  [選択テキスト]ボタン
//  クリックすると，現在選択中のテキストの文字列を表示
//  このコードはイベントシンク(リスナー)を登録しなくても動作する
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  StrText : String;
begin
  StrText := EmbeddedWB1.GetSelectedText;
  MessageBox(Handle, PChar(StrText), '選択テキスト', MB_OK);
end;

//=============================================================================
//  TEmbeddedWBコンポのOnBeforeNavigate2イベント
//  THtmlListener(リスナー)の接続を切断
//=============================================================================
procedure TForm1.EmbeddedWB1BeforeNavigate2(ASender: TObject;
  const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
begin
  if pDisp = EmbeddedWB1.DefaultInterface then begin
    DisconnectHtmlListeners;
  end;
end;

//=============================================================================
//  TEmbeddedWBコンポのOnDocumentCompleteイベント
//  表示フレーム数だけここを通過するのでリスナーの接続処理をその分実行
//=============================================================================
procedure TForm1.EmbeddedWB1DocumentComplete(ASender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  WB      : IWebbrowser;
  HTMLDoc : IHTMLDocument2;
begin
  WB := (pDisp as IWebBrowser);
  if Assigned(WB) then begin
    if Succeeded(WB.Document.QueryInterface(IHTMLDocument2, HTMLDoc)) then begin
      ConnectHtmlListener(ASender, HTMLDoc);
    end;
  end;
end;

//=============================================================================
//  TEmbeddedWBコンポのOnNewWindow3イベント
//  テストなので，リンク先のページは別ウィンドウで開かずに，EmbeddedWB1で表示
//=============================================================================
procedure TForm1.EmbeddedWB1NewWindow3(ASender: TObject; var ppDisp: IDispatch;
  var Cancel: WordBool; dwFlags: Cardinal; const bstrUrlContext,
  bstrUrl: WideString);
begin
  Cancel := True;
  EmbeddedWB1.Navigate(bstrUrl);
end;

//=============================================================================
//  THtmlListener(リスナー)の接続用関数
//=============================================================================
procedure TForm1.ConnectHtmlListener(ASender: TObject; Doc: IHTMLDocument2);
var
  CPC : IConnectionPointContainer;
begin
  if Assigned(Doc) then begin
    Doc.QueryInterface(IConnectionPointContainer, CPC);
    if Assigned(CPC) then begin
      HubLink := HtmlListener1.Connect2(CPC);
      HubLinksList.Add(HubLink);
    end;
  end;
end;

//=============================================================================
//  THtmlListener(リスナー)の切断処理用の関数
//=============================================================================
procedure TForm1.DisconnectHtmlListeners;
var
  i : Integer;
begin
  for i := HubLinksList.Count - 1 downto 0 do begin
    (HubLinksList[i] as IHubLink).Disconnect;
    HubLinksList.Remove(HubLinksList[i]);
  end;
end;

//=============================================================================
//  OnMouseMoveイベント処理
//  マウスカーソル下のエレメント(要素)の情報を表示
//
//  THtmlListnerのHandlesプロパティのEventID=eiOnMouseMoveのOnHadleイベント
//  THtmlListnerのSinkKindプロパティはskDocument
//=============================================================================
procedure TForm1.HtmlListener1HandlersOnMouseMoveHandle(Sender: TObject;
  Event: IHTMLEventObj);
var
  iElement : IHTMLElement;
begin
  iElement := Event.srcElement;

  LabeledEdit1.Text := '';
  LabeledEdit2.Text := '';
  Memo2.Lines.Text  := '';

  Memo2.Lines.Text := iElement.innerHTML;

  if iElement.getAttribute( 'src', 0) <> null then begin
    LabeledEdit1.Text := iElement.getAttribute( 'src', 0);
  end;

  //リンクを設定してあるエレメントはそのリンクも検出するために親とする
  if iElement.parentElement.tagName = 'A' then begin
    iElement := iElement.parentElement;
  end;

  if iElement.getAttribute( 'href', 0) <> null then begin
    LabeledEdit2.Text := iElement.getAttribute( 'href', 0);
  end;
end;

//=============================================================================
//  OnClickイベント処理
//  マウスクリックしたクライアント座標値を表示
//
//  THtmlListnerのHandlesプロパティのEventID=eiOnClickのOnHadleイベント
//  THtmlListnerのSinkKindプロパティはskDocument
//=============================================================================
procedure TForm1.HtmlListener1HandlersOnClickHandle(Sender: TObject;
  Event: IHTMLEventObj);
begin
  LabeledEdit3.Text := 'X: '  + IntToStr(Event.x) + '  ' +
                       'Y: '  + IntToStr(Event.y);
end;

end.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, OleCtrls, Buttons, SHDocVw_EWB, EwbCore,
  EmbeddedWB;

type

  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    Memo2: TMemo;
    EmbeddedWB1: TEmbeddedWB;
    procedure Button1Click(Sender: TObject);
    procedure EmbeddedWB1NewWindow3(ASender: TObject; var ppDisp: IDispatch;
      var Cancel: WordBool; dwFlags: Cardinal; const bstrUrlContext,
      bstrUrl: WideString);
    procedure EmbeddedWB1Click(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses MSHTML_EWB;

{$R *.dfm}

//=============================================================================
//  ウェブページを表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  AURL : String;
begin
  //指定のURLを表示
  AURL := 'http://mrxray.on.coocan.jp/';
  EmbeddedWB1.Navigate(AURL);
end;

//=============================================================================
//  TEmbeddedWBコンポのOnNewWindow3イベント
//  テストなので，リンク先のページは別ウィンドウで開かずに，EmbeddedWB1で表示
//=============================================================================
procedure TForm1.EmbeddedWB1NewWindow3(ASender: TObject; var ppDisp: IDispatch;
  var Cancel: WordBool; dwFlags: Cardinal; const bstrUrlContext,
  bstrUrl: WideString);
begin
  Cancel := True;
  EmbeddedWB1.Navigate(bstrUrl);
end;

//=============================================================================
//  OnClickイベント
//  TEmbeddedWBコンポのOnClickイベントハンドラ
//=============================================================================
procedure TForm1.EmbeddedWB1Click(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  iElement : IHTMLElement;
begin
  //マウス位置のエレメントを取得
  iElement  := EmbeddedWB1.Doc2.elementFromPoint(X, Y);

  //エレメントのソースを表示
  if iElement <> nil then begin
    Memo2.Lines.Text := iElement.innerHTML;
  end else begin
    Memo2.Lines.Text := '';
  end;
end;

end.

<!DOCTYPE html>
<html>
<head>
<script>
  function testScript(msg) {
    IntVal = 1230;
    window.external.GetResult(msg, IntVal);
  }
</script>
</head>

<body
<form action="" method="post" enctype="" name="delact">
  <input type="button" name="test1" value="Script 実行" onclick="testScript('TEST')">
</form>
</body>
</html>

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, OleCtrls, Buttons, SHDocVw_EWB, EwbCore, EmbeddedWB;

type
{$METHODINFO ON}
  TJavascriptReceiver = class
    function GetResult(msg: string; AValue: Integer): string;
  end;
{$METHODINFO OFF}


  TForm1 = class(TForm)
    Panel1: TPanel;
    EmbeddedWB1: TEmbeddedWB;
    procedure FormCreate(Sender: TObject);
    procedure EmbeddedWB1GetExternal(Sender: TCustomEmbeddedWB;
      var ppDispatch: IDispatch);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ObjComAuto;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//  テスト用の HTML コードを読み込んで表示
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LURL : string;
begin
  LURL := ExtractFilePath(Application.ExeName) + 'JaveScriptTest.html';
  EmbeddedWB1.Navigate(LURL);
end;

//=============================================================================
//  EmbeddedWB1 の OnGetExternal イベント
//  JavaScript で window.external を使用可能 (機能するよう) にする
//
//  TObjectDispatch の使用には uses に ObjComAuto が必要
//=============================================================================
procedure TForm1.EmbeddedWB1GetExternal(Sender: TCustomEmbeddedWB;
  var ppDispatch: IDispatch);
begin
  ppDispatch := TObjectDispatch.Create(TJavascriptReceiver.Create);
end;

{ TJavascriptReceiver }

//-----------------------------------------------------------------------------
//  JavaScript 内から window.external で呼び出す関数
//  この関数の場合は window.external.GetResult(引数...) とする
//
//  関数は必要に応じて追加する
//  関数名と引数の数と型は任意
//-----------------------------------------------------------------------------
function TJavascriptReceiver.GetResult(msg: string; AValue: Integer): string;
var
  LText : string;
begin
  Result := '';

  LText := msg + sLineBreak + IntToStr(AValue);
  MessageBox(Form1.Handle, PChar(LText), '結果', MB_ICONINFORMATION);
end;

end.

  function testScript(msg) {
    IntVal = 1230;
    ValfromDelphi = window.external.GetResult(msg, IntVal);
    alert(ValfromDelphi);
  }

function TJavascriptReceiver.GetResult(msg: string; AValue: Integer): string;
begin
  Result := 'テスト文字列';
end;

  function testScript(msg) {
    var testarray = [123, 'ABC'];
    window.external.GetResult(msg, testarray);
  }

function TJavascriptReceiver.GetResult(msg: string; AArray: OleVariant): string;
var
  LText  : string;
begin
  Result := '';

  // JavaScript の配列の値を取得
  // 要素番号の指定は文字列を使用する
  // GetDispatchPropValue の使用には uese に ComObj が必要
  LText := '要素数 : ' + IntToStr(AArray.length) + sLineBreak
         + IntToStr(GetDispatchPropValue(AArray, '0')) + sLineBreak
         + GetDispatchPropValue(AArray, '1');

  MessageBox(Form1.Handle, PChar(LText), '結果', MB_ICONINFORMATION);
end;

  function testScript(msg) {
    var testarray = [123, 'ABC'];
    window.external.GetResult(msg, testarray);

    for (var i = 0; i < testarray.length; i++){
      alert(testarray[i]);    
    }
  }

function TJavascriptReceiver.GetResult(msg: string; AArray: OleVariant): OleVariant;
var
  LText  : string;
begin
  Result := '';

  // JavaScript に配列の値を返す
  // 要素番号の指定は文字列を使用する
  // SetDispatchPropValue の使用には uese に ComObj が必要
  SetDispatchPropValue(AArray, '0', 5200);
  SetDispatchPropValue(AArray, '1', 'テスト文字列');
end;

  private
    FExternalObject: IDispatch;

    property ExternalObject: IDispatch read FExternalObject write FExternalObject;

function TWebBrowser.GetExternal(out ppDispatch: IDispatch): HRESULT;
begin
  ppDispatch := nil;
  Result := E_FAIL;
  if Assigned(FExternalObject) then begin
    try
      ppDispatch := FExternalObject;
      Result := S_OK;
    except
    end;
  end;

//  ppDispatch := nil;
//  Result := E_FAIL;
end;

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.OleCtrls, SHDocVw,
  Vcl.ExtCtrls;

type
{$METHODINFO ON}
  TJavascriptReceiver = class
   function GetResult(msg: string; AValue: Integer): string;
  end;
{$METHODINFO OFF}


  TForm1 = class(TForm)
    Panel1: TPanel;
    WebBrowser1: TWebBrowser;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ObjComAuto,
  ComObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//  テスト用の HTML コードを読み込んで表示
//
//  uses に ObjComAuto, ComObj が必要
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LURL : string;
begin
  // TWebBrowser.ExternalObject オブジェクトの生成
  // JavaScript で window.external を使用可能 (機能するよう) にする
  WebBrowser1.ExternalObject := TObjectDispatch.Create(TJavascriptReceiver.Create);

  LURL := ExtractFilePath(Application.ExeName) + 'JaveScriptTest.html';
  WebBrowser1.Navigate(LURL);
end;

//=============================================================================
//  フォーム破棄時の処理
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  WebBrowser1.ExternalObject := Unassigned;
end;



//-----------------------------------------------------------------------------
//  JavaScript 内から window.external で呼び出す関数
//  この関数の場合は window.external.GetResult(引数...) とする
//
//  関数は必要に応じて追加する
//  関数名と引数の数と型は任意
//-----------------------------------------------------------------------------
function TJavascriptReceiver.GetResult(msg: string; AValue: Integer): string;
var
  LText : string;
begin
  Result := '';

  LText := msg + sLineBreak + IntToStr(AValue);
  MessageBox(Form1.Handle, PChar(LText), '結果', MB_ICONINFORMATION);
end;

end.

end.

// Delphi XE8 以前の TWebBrowser
TWebBrowser = class(TOleControl)

// Delphi 10 Seattle 以降の TWebBrowser
TWebBrowser = class(TOleControl, IDocHostUIHandler, IDocHostShowUI, IOleCommandTarget)

// 以下のファイルをライブラリパスの通ったフォルダ内に置く
IntfDocHostUIHandler.pas
UContainer.pas    // 要編集ユニット(uses して使用するユニット)
UNulContainer.pas

  TWBContainer = class(TNulWBContainer, IDocHostUIHandler, IOleClientSite)
  private
    // 略
    FExternalObject: IDispatch;
  protected
    // 略
  public
    // 略
    function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;
    // 略
    property ExternalObject: IDispatch read FExternalObject write FExternalObject;
  end;

function TWBContainer.GetExternal(out ppDispatch: IDispatch): HRESULT;
begin
  ppDispatch := nil;
  Result := E_FAIL;
  if Assigned(FExternalObject) then begin
    try
      ppDispatch := FExternalObject;
      Result := S_OK;
    except
    end;
  end;
end;

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OleCtrls, SHDocVw, ExtCtrls, UContainer;

type
{$METHODINFO ON}
  TJavascriptReceiver = class
   function GetResult(msg: string; AValue: Integer): string;
  end;
{$METHODINFO OFF}

  TForm1 = class(TForm)
    Panel1: TPanel;
    WebBrowser1: TWebBrowser;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
    FWBContainer : TWBContainer;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ObjComAuto,
  ComObj;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//
//  (1) TWBContainer (UContainer.pas) のインスタンスを生成
//  (2) TWBContainer.ExternalObject を生成
//  (3) テスト用の HTML コードを読み込んで表示
//
//  uses に UContainer, ObjComAuto, ComObj が必要
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LURL : string;
begin
 FWBContainer := TWBContainer.Create(WebBrowser1);

  // TWBContainer.ExternalObject オブジェクトの生成
  // JavaScript で window.external を使用可能 (機能するよう) にする
  FWBContainer.ExternalObject := TObjectDispatch.Create(TJavascriptReceiver.Create);

  LURL := ExtractFilePath(Application.ExeName) + 'JaveScriptTest.html';
  FWBContainer.HostedBrowser.Navigate(LURL);
  // 以下でもよい
  // WebBrowser1.Navigate(LURL);
end;

//=============================================================================
//  フォーム破棄時の処理
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  FWBContainer.ExternalObject := Unassigned;
  FWBContainer.Free;
end;

//-----------------------------------------------------------------------------
//  JavaScript 内から window.external で呼び出す関数
//  この関数の場合は window.external.GetResult(引数...) とする
//
//  関数は必要に応じて追加する
//  関数名と引数の数と型は任意
//-----------------------------------------------------------------------------
function TJavascriptReceiver.GetResult(msg: string; AValue: Integer): string;
var
  LText : string;
begin
  Result := '';

  LText := msg + sLineBreak + IntToStr(AValue);
  MessageBox(Form1.Handle, PChar(LText), '結果', MB_ICONINFORMATION);
end;

end.

<!DOCTYPE html>
<html>
<head>
<script type="text/javascript">
  function mousemove(event){
    window.external.HtmlMouseMove(event);
  }
  function mouseclick(event){
    window.external.HtmlClick(event);
  }
</script>
</head>     

<body
  <div id="element1" onmousemove="mousemove(event);"
                     onclick="mouseclick(event);"
    >　
    マウスイベントテスト用<br>
    マウスカーソル移動とクリック<br>
    要素上の移動と要素上のクリックを検出
  </div>
</body>
</html>

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, OleCtrls, Buttons, SHDocVw_EWB, EwbCore, EmbeddedWB;

type
{$METHODINFO ON}
  TJavascriptReceiver = class
    procedure HtmlMouseMove(Aevent: OleVariant);
    procedure HtmlClick(Aevent: OleVariant);
  end;
{$METHODINFO OFF}


  TForm1 = class(TForm)
    Panel1: TPanel;
    EmbeddedWB1: TEmbeddedWB;
    Panel2: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure EmbeddedWB1GetExternal(Sender: TCustomEmbeddedWB;
      var ppDispatch: IDispatch);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  ObjComAuto;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//  テスト用の HTML コードを読み込んで表示
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LURL : string;
begin
  LURL := ExtractFilePath(Application.ExeName) + 'EventtTest.html';
  EmbeddedWB1.Navigate(LURL);
end;

//=============================================================================
//  EmbeddedWB1 の OnGetExternal イベント
//  JavaScript で window.external を使用可能 (機能するよう) にする
//
//  TObjectDispatch の使用には uses に ObjComAuto が必要
//=============================================================================
procedure TForm1.EmbeddedWB1GetExternal(Sender: TCustomEmbeddedWB;
  var ppDispatch: IDispatch);
begin
  ppDispatch := TObjectDispatch.Create(TJavascriptReceiver.Create);
end;

{ TJavascriptReceiver }

//-----------------------------------------------------------------------------
//  JavaScript 内から window.external で呼び出すメソッド
//  メソッド名と引数の数と型は任意
//-----------------------------------------------------------------------------
procedure TJavascriptReceiver.HtmlMouseMove(Aevent: OleVariant);
var
  LText : string;
begin
  LText := IntToStr(Aevent.clientX) + ', ' + IntToStr(Aevent.clientY);
  Form1.Panel2.Caption := LText;
end;

//-----------------------------------------------------------------------------
//  JavaScript 内から window.external で呼び出すメソッド
//  メソッド名と引数の数と型は任意
//-----------------------------------------------------------------------------
procedure TJavascriptReceiver.HtmlClick(Aevent: OleVariant);
begin
  MessageBox(Form1.Handle, 'クリック', '情報', MB_ICONINFORMATION);
end;

end.

<!DOCTYPE html>
<html>
<body>
  <div id="element1" onmousemove="external.HtmlMouseMove(event);"
                     onclick="external.HtmlClick(event);"
    >　
    マウスイベントテスト用<br>
    マウスカーソル移動とクリック<br>
    要素上の移動と要素上のクリックを検出
  </div>
</body>
</html>

<!DOCTYPE html>
<html>
<body onmousemove="external.HtmlMouseMove(event);"
      onclick="external.HtmlClick(event);"
      >　
    マウスイベントテスト用<br>
    マウスカーソル移動とクリック<br>
    要素上の移動と要素上のクリックを検出
</body>
</html>

<!DOCTYPE html>
<html>
<body>
  <img id="img01" src="testimage.gif"
   "" onclick="external.HtmlClick(event, id);"
   >　
</body>
</html>

procedure TJavascriptReceiver.HtmlClick(Aevent: OleVariant; AID: string);
begin
  MessageBox(0, PChar(AID), '情報', MB_ICONINFORMATION);
end;