HTMLブラウザをFormの代替に (ID:19648)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

>Delphiでクリックイベントにうまくリンクさせて動作させる
こういうことでしょうか？↓

{
参考:
TEventDelegator
http://www.effie.co.il/default.asp?sec=printview&topic=delphiasp&lang=he

Bubble Power: Internet Explorer 4.0 におけるイベント処理
http://www.microsoft.com/japan/msdn/web/ie/ie40/ie4event.asp

Handling Events in Visual Basic Applications
http://msdn.microsoft.com/workshop/browser/webbrowser/tutorials/forward.asp

TieAutomationコンポーネント
http://www33.ocn.ne.jp/~takoyakusi/delphi/InternetProg.html
}

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ieAutomation, SHDocVw_TLB, MSHTML_TLB;

//-----------------------------------------------------------------------------

type
  TCallbackMethod = procedure of object;
  
  TEventDelegator = class(TInterfacedObject, IDispatch)
  private
    FOwner : TObject;
    FCallback: TCallbackMethod;
  protected
    { IDispatch }
    function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
                    Flags: Word; var Params; VarResult, ExcepInfo,
                    ArgErr: Pointer): HRESULT; stdcall;
  public
    constructor Create(AOwner:TObject; Callback :TCallbackMethod);
  end;

//-----------------------------------------------------------------------------

type
  TForm1 = class(TForm)
    ieAuto: TieAutomation;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure ieAutoDocumentComplete(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ieAutoQuit(Sender: TObject);
  private
    { Private 宣言 }
    procedure IE_AttachEvevt;
    procedure Some_Procedure1;
    procedure Some_Procedure2;
    procedure Some_Procedure3;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//-----------------------------------------------------------------------------

constructor TEventDelegator.Create(AOwner:TObject; Callback:TCallbackMethod);
begin
  inherited Create;
  FOwner := AOwner;
  FCallback := Callback;
end;

function TEventDelegator.GetTypeInfoCount(out Count: Integer): HRESULT;
begin
// Skeleton implementation
  Count  := 0;
  Result := S_OK;
end;

function TEventDelegator.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT;
begin
// Skeleton implementation
  Result := E_NOTIMPL;
end;

function TEventDelegator.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;
begin
// Skeleton implementation
  Result := E_NOTIMPL;
end;

function TEventDelegator.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT;
begin
  try
    FCallback;
  except
  end;
  Result := S_OK;
end;

//-----------------------------------------------------------------------------

procedure TForm1.Some_Procedure1;
var
  oDoc2: IHTMLDocument2;
  oWindow: IHTMLWindow2;
  oEle: IHTMLElement;
begin
  Windows.Beep(3000, 100);
  Button1.Caption := 'Some_Procedure1 was called.';
  oDoc2 := ieAuto.ieObject.Document as IHTMLDocument2;
  oWindow := oDoc2.parentWindow;
  oEle := oWindow.event.srcElement;
  oEle.innerText := 'Some_Procedure1 was called.';
end;

procedure TForm1.Some_Procedure2;
var
  oDoc: IHTMLDocument2;
  oWindow: IHTMLWindow2;
  oEle: IHTMLElement;
begin
  oDoc := ieAuto.ieObject.Document as IHTMLDocument2;
  oWindow := oDoc.parentWindow;
  oEle := oWindow.event.srcElement;
  oEle.style.backgroundColor := 'Gray';
end;

procedure TForm1.Some_Procedure3;
var
  oDoc: IHTMLDocument2;
  oWindow: IHTMLWindow2;
  oEle: IHTMLElement;
begin
  oDoc := ieAuto.ieObject.Document as IHTMLDocument2;
  oWindow := oDoc.parentWindow;
  oEle := oWindow.event.srcElement;
  oEle.style.backgroundColor := '';
end;

//-----------------------------------------------------------------------------

// ブラウザオープン
procedure TForm1.Button1Click(Sender: TObject);
begin
  ieAuto.IeOpen;
end;

procedure TForm1.ieAutoDocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  oDoc: IHTMLDocument2;
  sHTML: WideString;
begin
  // 適当なHTML
  // ID,Name などで識別できるようにしておく
  sHTML := '<P>This is some text.</P>';
  sHTML := sHTML + '<P>And here is a button.</P>';
  sHTML := sHTML + '<BUTTON ID="btnMyButton">Click this Button.</BUTTON>';

oDoc := ieAuto.ieObject.Document as IHTMLDocument2; 
  oDoc.body.innerHTML := sHTML;

IE_AttachEvevt;
end;

// イベント実装
procedure TForm1.IE_AttachEvevt;
var
  oDoc: IHTMLDocument3;
  oEle: IHTMLElement2;
  oEvent: IDispatch;
begin
  if not Assigned(ieAuto.ieObject) then Exit;

oDoc := ieAuto.ieObject.Document as IHTMLDocument3;

// ID で識別
  oEle := oDoc.getElementById('btnMyButton') as IHTMLElement2;
  oEvent := TEventDelegator.Create(Form1, Some_Procedure1);
  oEle.attachEvent('onclick', oEvent);

// Document すべてに（イベント バブリング）
  oEvent := TEventDelegator.Create(Form1, Some_Procedure2);
  oDoc.attachEvent('onmouseover', oEvent);

oEvent := TEventDelegator.Create(Form1, Some_Procedure3);
  oDoc.attachEvent('onmouseout', oEvent);

{onclick, ondblclick,
  onmousedown, onmouseup,
  onmouseover, onmouseout,
  onmousemove,
  onkeydown, onkeyup,
  onkeypress
  ...などなど}
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // フォームを表示しない
  Application.ShowMainForm := False;
  Button1Click(Sender);
end;

// ブラウザとフォームの終了を連動
procedure TForm1.FormDestroy(Sender: TObject);
begin
  ieAuto.IeClose;
end;

procedure TForm1.ieAutoQuit(Sender: TObject);
begin
  Application.Terminate;
end;

end.

←解決時は質問者本人がここをチェックしてください。

戻る