webbrowserで別ドメインを制御する方法 (ID:103020)

名前

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

本文

> 似たような質問が過去にあったようなので張っておきます。

》一応 VB6 で書き直してみました。
》http://www.ocv.ne.jp/~oratorio/junk/Sample/40/ZoneTest.lzh
》なお実行前には、必ず、エラートラップモードを、
》『エラー処理対象外のエラーで中断』モードにしておいてください。

おおぅ、書いた本人も完全に忘れていました。
既にデッドリンクですけれどね。

過去 2 回のサーバー移転の際に、幾つかのコンテンツは失われていますが、
少なくとも上記のファイルは手元に残っていたので、現行サーバーに
再度アップロードしておきました。新しい URL はこちら。

http://www.vb-user.net/junk/Sample/40/ZoneTest.lzh

ただし、当時使っていたサイトは、現在ではフレームが使われていない
ようなので、中にあるサンプルは別の URL に差し替えてください。

一応、ソースコードも転記しておきます。

'--- Form1 ---
Option Explicit

'参照設定が必要：
'  なお、olelibOrator というは自作のタイプライブラリ。
Implements olelibOrator.IServiceProvider
Implements olelib.IInternetSecurityManager

Private SID_SProfferService As UUID
Private IID_IProfferService As UUID
Private IID_IInternetSecurityManager As UUID
Private ps As IProfferService
Private cookie As Long
Private sp As olelib.IServiceProvider

Private Sub Check1_Click()
    If cookie <> 0 Then
        ps.RevokeService cookie
        cookie = 0
    End If
    If Check1.Value = vbChecked Then
        cookie = ps.ProfferService(IID_IInternetSecurityManager, Me)
    End If
    WebBrowser1.Refresh
End Sub

Private Sub Form_Load()
    Check1.Caption = "GetSecurityId変更"
    Check1.Value = vbUnchecked
    Command1.Caption = "フレーム読み込み"

CLSIDFromString SIDSTR_SProfferService, IID_IProfferService
    CLSIDFromString SIDSTR_SProfferService, SID_SProfferService
    CLSIDFromString IIDSTR_IInternetSecurityManager, IID_IInternetSecurityManager

Set sp = WebBrowser1.object
    sp.QueryService SID_SProfferService, IID_IProfferService, ps

'2005年12月当時のサンプルでは、下記に具体的な URL を記載していましたが、
    'そのサイトは現在、フレームを使わない構成になっているようです。
    '適当なサイトに差し替えてください。
    WebBrowser1.Navigate URL
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If cookie <> 0 Then
        ps.RevokeService cookie
    End If
End Sub

Private Sub Command1_Click()
'    Text1.Text = WebBrowser1.Document.documentElement.outerHTML
'    Text2.Text = WebBrowser1.Document.frames(0).Document.documentElement.outerHTML
'    Text3.Text = WebBrowser1.Document.frames(1).Document.documentElement.outerHTML
'    Text4.Text = WebBrowser1.Document.frames(0).Document.frames(0).Document.documentElement.outerHTML
'    Text5.Text = WebBrowser1.Document.frames(0).Document.frames(1).Document.documentElement.outerHTML

Text1.Text = ""
    Text2.Text = ""
    Text3.Text = ""
    Text4.Text = ""
    Text5.Text = ""

On Error GoTo ErrExit
    Dim d As HTMLDocument
    Dim fs As IHTMLFramesCollection2
    Dim f1 As IHTMLWindow2
    Dim f2 As IHTMLWindow2
    Dim d1 As HTMLDocument
    Dim d2 As HTMLDocument

Set d = WebBrowser1.Document
    Text1.Text = d.documentElement.outerHTML
    
    Set fs = d.frames
    Set f1 = fs.Item(0)
    Set f2 = fs.Item(1)
    Set d1 = f1.Document
    Set d2 = f1.Document
    Text2.Text = d1.documentElement.outerHTML
    Text3.Text = d1.documentElement.outerHTML
    
    Set fs = d1.frames
    Set f1 = fs.Item(0)
    Set f2 = fs.Item(1)
    Set d1 = f1.Document
    Set d2 = f1.Document
    Text4.Text = d1.documentElement.outerHTML
    Text5.Text = d1.documentElement.outerHTML
    Exit Sub
ErrExit:
    MsgBox Err.Description
End Sub

Private Sub IInternetSecurityManager_GetSecurityId(ByVal pwszUrl As Long, ByVal pbSecurityId As Long, pcbSecurityId As Long, ByVal dwReserved As Long)
    'Err.Raise olelib.HRESULTS.INET_E_DEFAULT_ACTION
    
    Dim URL As String
    URL = lpwstrPtrToString(pwszUrl)
    Debug.Print URL
    pcbSecurityId = 0
End Sub

Private Function IInternetSecurityManager_GetSecuritySite() As olelib.IInternetSecurityMgrSite
    Err.Raise olelib.HRESULTS.INET_E_DEFAULT_ACTION
End Function

Private Sub IInternetSecurityManager_GetZoneMappings(ByVal dwZone As Long, ppenumString As olelib.IEnumString, ByVal dwFlags As Long)
    Err.Raise olelib.HRESULTS.INET_E_DEFAULT_ACTION
End Sub

Private Sub IInternetSecurityManager_MapUrlToZone(ByVal pwszUrl As Long, pdwZone As Long, ByVal dwFlags As Long)
    pdwZone = 0
    Err.Raise olelib.HRESULTS.INET_E_DEFAULT_ACTION
End Sub

Private Sub IInternetSecurityManager_ProcessUrlAction(ByVal pwszUrl As Long, ByVal dwAction As olelib.URLACTIONS, ByVal pPolicy As Long, ByVal cbPolicy As Long, pContext As Byte, ByVal cbContext As Long, ByVal dwFlags As olelib.PUAF, ByVal dwReserved As Long)
    Err.Raise olelib.HRESULTS.INET_E_DEFAULT_ACTION
End Sub

Private Sub IInternetSecurityManager_QueryCustomPolicy(ByVal pwszUrl As Long, guidKey As olelib.UUID, ppPolicy As Long, pcbPolicy As Long, pContext As Byte, ByVal cbContext As Long, Optional ByVal dwReserved As Long = 0&)
    Err.Raise olelib.HRESULTS.INET_E_DEFAULT_ACTION
End Sub

Private Sub IInternetSecurityManager_SetSecuritySite(ByVal pSite As olelib.IInternetSecurityMgrSite)
    Err.Raise olelib.HRESULTS.INET_E_DEFAULT_ACTION
End Sub

Private Sub IInternetSecurityManager_SetZoneMapping(ByVal dwZone As Long, ByVal lpszPattern As Long, ByVal dwFlags As olelib.SZM_FLAGS)
    Err.Raise olelib.HRESULTS.INET_E_DEFAULT_ACTION
End Sub

Private Function IServiceProvider_QueryService(guidService As olelib.UUID, riid As olelib.UUID) As olelib.IInternetSecurityManager
    If GetStringFromGUID(guidService) = UCase(IIDSTR_IInternetSecurityManager) Then
        Set IServiceProvider_QueryService = Me
    Else
        Set IServiceProvider_QueryService = Nothing
        Err.Raise olelib.HRESULTS.E_NOINTERFACE
    End If
End Function

Public Function GetStringFromGUID(X As UUID) As String
    Dim s As String
    Dim L As Long
    s = String(100, 0)
    L = StringFromGUID2(X, s, Len(s))
    GetStringFromGUID = UCase(Left(s, L - 1))
End Function

Private Function lpwstrPtrToString(ByVal lpwstrPtr As Long) As String
    Dim lSize As Long
    If lpwstrPtr <> 0 Then
        lSize = lstrlenW(ByVal lpwstrPtr)
        If lSize > 0 Then
            ReDim b(0 To (lSize * 2) - 1) As Byte
            MoveMemory b(0), ByVal lpwstrPtr, lSize * 2
            lpwstrPtrToString = b
        End If
    End If
End Function

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

戻る