Internet ExplorerをFoxProでHOOKする

Object Oriented XBASE Forum 2006
*===============================================================================================
* Object Oriented XBASE Forum 2006  by YOSHIIKE
* Calvin Hsia's WebLog : Binding to Internet Explorer Instances
* http://blogs.msdn.com/calvin_hsia/archive/2005/09/06/461783.aspx
* 上記由来コードより動作しないProcedureを補修し、WindowsXP VFP9.0用に IEのフック部分を
* 付加して実行可能なコード体系としました。
* 下記ソースを切り出しプログラムファイルとして登録し実行してみてください。(例)HookIEbyVFP.PRG
* SCREENウインドウにIEの挙動がHOOKされ表示されます。
* Errorや警告用のMessageboxが、開いたIEの裏側で見えない場合があります。ご注意ください。
*===============================================================================================

Public oShell As Shell.Application
Public oWindow As InternetExplorer.Application
Public oIE As InternetExplorer.Application

lcURl="http://www2u.biglobe.ne.jp/~objxbase/"
*シェルのオブジェクトを作成する
oShell = Createobject("Shell.Application")

*ウインドウの数だけまわす
For Each oWindow In oShell.Windows

	? oWindow.path
	*IEだったら
	If "internet explorer"$LOWER(oWindow.Path)
      ? "■■起動済みInternet Explorerを見つけました。フックします。■■"
		MESSAGEBOX("起動済みInternet Explorerを見つけました",64,"フックします",3000)
		*オブジェクトを代入する
		oIE = oWindow
		oIE.Navigate("&lcURl")
		Exit For  &&初めに見つけたオブジェクトを代入
	Endif
Next
If Type("oIe.Height") # "N"
	oIE = Createobject("InternetExplorer.Application")
   ? "■■起動済みIntrnet Explorerが見つかりません。新規起動しフックします。■■"
	MESSAGEBOX("起動済みIntrnet Explorerが見つかりません",64,"新規起動しフックします",3000)
Endif

oIEEvents = Createobject("WebBrowserEvents")
Eventhandler(oIe,oIEEvents)

Try
	oIe.Navigate("about:blank")
Catch
	* 起動時のファイルダウンロードイベントエラーを無視する
Endtry

* フックしたInternet Explorerのウインドウサイズやデザインを制御し
* lcURlに代入されたURLへジャンプさせる
oIe.Height = 400
oIe.Width = 400
oIe.Toolbar = .T.
oIe.AddressBar= .T.
oIe.Left = 400
oIe.Visible = .T.
oIe.Navigate("&lcURl")

Return oIe

* IMPLEMENTS DWebBrowserEvents2 IN "SHDOCVW.DLL"

Define Class WebBrowserEvents As Session OlePublic

	Implements DWebBrowserEvents2 In "SHDOCVW.DLL"

	Procedure DWebBrowserEvents2_BeforeNavigate2(pDisp As VARIANT, URL As VARIANT, Flags As VARIANT, TargetFrameName As VARIANT, PostData As VARIANT, Headers As VARIANT, Cancel As LOGICAL @) As VOID;
			HELPSTRING "Fired before navigate occurs in the given WebBrowser (window or frameset element). The processing of this navigation may be modified."
			? URL
         * URLの移動を禁止したい場合は下記のようにします。
			If !("http://www2u.biglobe.ne.jp/~objxbase/" $ Lower(URL)) And URL != "about:blank"
            ? "■■URLの移動は禁止されています。申し訳ありません■■"
				Messagebox("URLの移動は禁止されています。申し訳ありません",16,"IEのイベントをフックしています。")
				Cancel = .T.
			Endif
	Endproc

	Procedure DWebBrowserEvents2_StatusTextChange(Text As String) As VOID;
			HELPSTRING "Statusbar text changed."
		? "DWebBrowserEvents2_StatusTextChange"
	Endproc

	Procedure DWebBrowserEvents2_ProgressChange(Progress As Number, ProgressMax As Number) As VOID;
			HELPSTRING "Fired when download progress is updated."
		? "DWebBrowserEvents2_ProgressChange"
	Endproc

	Procedure DWebBrowserEvents2_CommandStateChange(Command As Number, Enable As LOGICAL) As VOID;
			HELPSTRING "The enabled state of a command changed."
		? "DWebBrowserEvents2_CommandStateChange"
	Endproc

	Procedure DWebBrowserEvents2_DownloadBegin() As VOID;
			HELPSTRING "Download of a page started."
		? "DWebBrowserEvents2_DownloadBegin"
	Endproc

	Procedure DWebBrowserEvents2_DownloadComplete() As VOID;
			HELPSTRING "Download of page complete."
		? "DWebBrowserEvents2_DownloadComplete"
	Endproc

	Procedure DWebBrowserEvents2_TitleChange(Text As String) As VOID;
			HELPSTRING "Document title changed."
		? "DWebBrowserEvents2_TitleChange"
	Endproc

	Procedure DWebBrowserEvents2_PropertyChange(szProperty As String) As VOID;
			HELPSTRING "Fired when the PutProperty method has been called."
		? "DWebBrowserEvents2_PropertyChange"
	Endproc

	Procedure DWebBrowserEvents2_NewWindow2(ppDisp As VARIANT @, Cancel As LOGICAL @) As VOID;
			HELPSTRING "A new, hidden, non-navigated WebBrowser window is needed."
		? "DWebBrowserEvents2_NewWindow2"
	ENDPROC
	
	*LPARAMETERS ppdisp, cancel, dwflags, bstrurlcontext, bstrurl
	Procedure DWebBrowserEvents2_NewWindow3(ppDisp As VARIANT @, Cancel As LOGICAL @,dwflags As Variant,bstrurlcontext As Variant,bstrurl As Variant) As VOID;
			HELPSTRING "A new, hidden, non-navigated WebBrowser window is needed."
		? "DWebBrowserEvents2_NewWindow3"
	Endproc

	Procedure DWebBrowserEvents2_NavigateComplete2(pDisp As VARIANT, URL As VARIANT) As VOID;
			HELPSTRING "Fired when the document being navigated to becomes visible and enters the navigation stack."
		? "DWebBrowserEvents2_NavigateComplete2"
	Endproc

	Procedure DWebBrowserEvents2_DocumentComplete(pDisp As VARIANT, URL As VARIANT) As VOID;
			HELPSTRING "Fired when the document being navigated to reaches ReadyState_Complete."
		? "DWebBrowserEvents2_DocumentComplete"
	Endproc

	Procedure DWebBrowserEvents2_OnQuit() As VOID;
			HELPSTRING "Fired when application is quiting."
		? "■■InternetExplorerを終了しました■■"
	Endproc

	Procedure DWebBrowserEvents2_OnVisible(Visible As LOGICAL) As VOID;
			HELPSTRING "Fired when the window should be shown/hidden"
		? "DWebBrowserEvents2_OnVisible"
	Endproc

	Procedure DWebBrowserEvents2_OnToolBar(Toolbar As LOGICAL) As VOID;
			HELPSTRING "Fired when the toolbar  should be shown/hidden"
		? "DWebBrowserEvents2_OnToolBar"
	Endproc

	Procedure DWebBrowserEvents2_OnMenuBar(MenuBar As LOGICAL) As VOID;
			HELPSTRING "Fired when the menubar should be shown/hidden"
		? "DWebBrowserEvents2_OnMenuBar"
	Endproc

	Procedure DWebBrowserEvents2_OnStatusBar(StatusBar As LOGICAL) As VOID;
			HELPSTRING "Fired when the statusbar should be shown/hidden"
		? "DWebBrowserEvents2_OnStatusBar"
	Endproc

	Procedure DWebBrowserEvents2_OnFullScreen(FullScreen As LOGICAL) As VOID;
			HELPSTRING "Fired when fullscreen mode should be on/off"
		? "DWebBrowserEvents2_OnFullScreen"
	Endproc

	Procedure DWebBrowserEvents2_OnTheaterMode(TheaterMode As LOGICAL) As VOID;
			HELPSTRING "Fired when theater mode should be on/off"
		? "DWebBrowserEvents2_OnTheaterMode"
	Endproc

	Procedure DWebBrowserEvents2_WindowSetResizable(Resizable As LOGICAL) As VOID;
			HELPSTRING "Fired when the host window should allow/disallow resizing"
		? "DWebBrowserEvents2_WindowSetResizable"
	Endproc

	Procedure DWebBrowserEvents2_WindowSetLeft(Left As Number) As VOID;
			HELPSTRING "Fired when the host window should change its Left coordinate"
		? "DWebBrowserEvents2_WindowSetLeft"
	Endproc

	Procedure DWebBrowserEvents2_WindowSetTop(Top As Number) As VOID;
			HELPSTRING "Fired when the host window should change its Top coordinate"
		? "DWebBrowserEvents2_WindowSetTop"
	Endproc

	Procedure DWebBrowserEvents2_WindowSetWidth(Width As Number) As VOID;
			HELPSTRING "Fired when the host window should change its width"
		? "DWebBrowserEvents2_WindowSetWidth"
	Endproc

	Procedure DWebBrowserEvents2_WindowSetHeight(Height As Number) As VOID;
			HELPSTRING "Fired when the host window should change its height"
		? "DWebBrowserEvents2_WindowSetHeight"
	Endproc

	Procedure DWebBrowserEvents2_WindowClosing(IsChildWindow As LOGICAL, Cancel As LOGICAL @) As VOID;
			HELPSTRING "Fired when the WebBrowser is about to be closed by script"
		? "DWebBrowserEvents2_WindowClosing"
	Endproc

	Procedure DWebBrowserEvents2_ClientToHostWindow(CX As Number @, CY As Number @) As VOID;
			HELPSTRING "Fired to request client sizes be converted to host window sizes"
		? "DWebBrowserEvents2_ClientToHostWindow"
	Endproc

	Procedure DWebBrowserEvents2_SetSecureLockIcon(SecureLockIcon As Number) As VOID;
			HELPSTRING "Fired to indicate the security level of the current web page contents"
		? "DWebBrowserEvents2_SetSecureLockIcon"
	Endproc

	Procedure DWebBrowserEvents2_FileDownload(Cancel as Logical @,cDummy as Boolean ) As VOID;
			HELPSTRING "Fired to indicate the File Download dialog is opening"
	Endproc

	Procedure DWebBrowserEvents2_NavigateError(pDisp As object, URL As VARIANT, Frame As VARIANT, StatusCode As VARIANT, Cancel As LOGICAL @) As VOID;
			HELPSTRING "Fired when a binding error occurs (window or frameset element)."
		? "DWebBrowserEvents2_NavigateError"
	Endproc

	Procedure DWebBrowserEvents2_PrintTemplateInstantiation(pDisp As VARIANT) As VOID;
			HELPSTRING "Fired when a print template is instantiated."
		? "DWebBrowserEvents2_PrintTemplateInstantiation"
	Endproc

	Procedure DWebBrowserEvents2_PrintTemplateTeardown(pDisp As VARIANT) As VOID;
			HELPSTRING "Fired when a print template destroyed."
		? "DWebBrowserEvents2_PrintTemplateTeardown"
	Endproc

	Procedure DWebBrowserEvents2_UpdatePageStatus(pDisp As VARIANT, nPage As VARIANT, fDone As VARIANT) As VOID;
			HELPSTRING "Fired when a page is spooled. When it is fired can be changed by a custom template."
		? "DWebBrowserEvents2_UpdatePageStatus"
	Endproc

	Procedure DWebBrowserEvents2_PrivacyImpactedStateChange(bImpacted As LOGICAL) As VOID;
			HELPSTRING "Fired when the global privacy impacted state changes"
		? "DWebBrowserEvents2_PrivacyImpactedStateChange"
	Endproc

Enddefine