WebBrowserコントロールにNewWindow2イベントを拡張する

VB.NET Tips　>>　記事詳細

2018/06/10	WebBrowserコントロールにNewWindow2イベントを拡張する	\| by:YAS

　WebBrowserコントロールにはNewWindow2イベントがありません。そのため新規ウィンドウ表示をキャンセルすることはできても，Webページをロードするオブジェクトを指定することはできません。
　WebBrowser.CreateSinkメソッドのヘルプのサンプルを参考にDWebBrowserEvents2のNewWindow2のイベントを実装してみました。
　以下のサンプルはWebBrowserコントロールにNewWindow2イベントを拡張し，新規ウィンドウ表示を新規タブに表示するようにします。
　下のコードをフォームのコードにコピー・貼り付けをすれば動作します。

※遅延バインディングを行っていたところを事前バインディングに変更しました。

Option Explicit On
Option Strict On

Imports System.ComponentModel
Imports System.IO
Imports System.Runtime.InteropServices
Imports System.Security.Permissions
Imports Microsoft.Win32

Public Class Form1

    Dim TabControl1 As New TabControl
    Dim WebBrowser1 As ExWebBrowser
    Dim TabPage1 As TabPage

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        'WebBrowser1
        BrowserEmulation.CreateRenderingModeRegkey(BrowserEmulation.Emulation.IE11Edge)
        Me.WebBrowser1 = New ExWebBrowser
        Me.WebBrowser1.Dock = DockStyle.Fill
        AddHandler WebBrowser1.NewWindow2, AddressOf WebBrowser_NewWindow2
        'TabPage1
        Me.TabPage1 = New TabPage
        Me.TabPage1.Controls.Add(WebBrowser1)
        'TabControl
        Me.TabControl1.Dock = DockStyle.Fill
        Me.TabControl1.TabPages.Add(TabPage1)
        'Form1
        Me.Text = "WebBrowserNewWindow2Event"
        Me.Controls.Add(Me.TabControl1)
        '
        Me.WebBrowser1.GoHome()
    End Sub

    Private Sub Form1_Closing(sender As Object, e As CancelEventArgs) Handles Me.Closing
        BrowserEmulation.DeleteRenderingModeRegkey()
    End Sub

    Private Sub WebBrowser_NewWindow2(ByVal sender As Object, ByVal e As WebBrowserNewWindow2EventArgs)
        'WebBrowser1
        Me.WebBrowser1 = New ExWebBrowser
        Me.WebBrowser1.Dock = DockStyle.Fill
        AddHandler WebBrowser1.NewWindow2, AddressOf WebBrowser_NewWindow2
        'TabPage1
        Me.TabPage1 = New TabPage
        Me.TabPage1.Controls.Add(WebBrowser1)
        'TabControl
        Me.TabControl1.Controls.Add(TabPage1)
        Me.TabControl1.SelectedTab = TabPage1
        '新しいウィンドウが開くのを抑制
        e.ppDisp = Me.WebBrowser1.Application
        Me.WebBrowser1.RegisterAsBrowser = True
    End Sub

End Class

Public Class BrowserEmulation

    Public Enum Emulation
        IE11Edge = 11001
        IE11 = 11000
        IE10Std = 10001
        IE10 = 10000
        IE9Std = 9999
        IE9 = 9000
        IE8Std = 8888
        IE8 = 8000
        IE7 = 7000
    End Enum

    Private Const FEATURE_BROWSER_EMULATION As String = "Software\Microsoft\Internet Explorer\Main\FeatureControl\FEATURE_BROWSER_EMULATION"

    Public Shared Sub CreateRenderingModeRegkey(EmulationMode As Emulation)
        Using Regkey As RegistryKey = Registry.CurrentUser.CreateSubKey(FEATURE_BROWSER_EMULATION)
            Regkey.SetValue(GetReleaseBuildName, EmulationMode, RegistryValueKind.DWord)
            Regkey.SetValue(GetDebugBuildName, EmulationMode, RegistryValueKind.DWord)
        End Using
    End Sub

    Public Shared Sub DeleteRenderingModeRegkey()
        Using Regkey As RegistryKey = Registry.CurrentUser.CreateSubKey(FEATURE_BROWSER_EMULATION)
            Regkey.DeleteValue(GetReleaseBuildName)
            Regkey.DeleteValue(GetDebugBuildName)
        End Using
    End Sub

    Private Shared Function GetReleaseBuildName() As String
        Return Path.GetFileName(Application.ExecutablePath)
    End Function

    Private Shared Function GetDebugBuildName() As String
        Return GetReleaseBuildName.Replace(".exe", ".svhost.exe")
    End Function

End Class

Public Class ExWebBrowser
    Inherits WebBrowser

    'NewWindow2イベントの拡張
    Private cookie As AxHost.ConnectionPointCookie
    Private helper As WebBrowser2EventHelper

    <DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden)>
    <DispIdAttribute(200)>
    Public ReadOnly Property Application() As Object
        Get
            If IsNothing(Me.ActiveXInstance) Then
                Throw New AxHost.InvalidActiveXStateException("Application", AxHost.ActiveXInvokeKind.PropertyGet)
            End If
            Return DirectCast(Me.ActiveXInstance, IWebBrowser2).Application
        End Get
    End Property

    <DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden)>
    <DispIdAttribute(552)>
    Public Property RegisterAsBrowser() As Boolean
        Get
            If IsNothing(Me.ActiveXInstance) Then
                Throw New AxHost.InvalidActiveXStateException("RegisterAsBrowser", AxHost.ActiveXInvokeKind.PropertyGet)
            End If
            Return DirectCast(Me.ActiveXInstance, IWebBrowser2).RegisterAsBrowser
        End Get
        Set(ByVal value As Boolean)
            If IsNothing(Me.ActiveXInstance) Then
                Throw New AxHost.InvalidActiveXStateException("RegisterAsBrowser", AxHost.ActiveXInvokeKind.PropertySet)
            End If
            DirectCast(Me.ActiveXInstance, IWebBrowser2).RegisterAsBrowser = value
        End Set
    End Property

    <PermissionSetAttribute(SecurityAction.LinkDemand, Name:="FullTrust")>
    Protected Overrides Sub CreateSink()
        MyBase.CreateSink()
        helper = New WebBrowser2EventHelper(Me)
        cookie = New AxHost.ConnectionPointCookie(Me.ActiveXInstance, helper, GetType(DWebBrowserEvents2))
    End Sub

    <PermissionSetAttribute(SecurityAction.LinkDemand, Name:="FullTrust")>
    Protected Overrides Sub DetachSink()
        If cookie IsNot Nothing Then
            cookie.Disconnect()
            cookie = Nothing
        End If
        MyBase.DetachSink()
    End Sub

    Public Event NewWindow2 As WebBrowserNewWindow2EventHandler

    Protected Overridable Sub OnNewWindow2(ByVal e As WebBrowserNewWindow2EventArgs)
        RaiseEvent NewWindow2(Me, e)
    End Sub

    Private Class WebBrowser2EventHelper
        Inherits StandardOleMarshalObject
        Implements DWebBrowserEvents2

        Private parent As ExWebBrowser

        Public Sub New(ByVal parent As ExWebBrowser)
            Me.parent = parent
        End Sub

        Public Sub NewWindow2(ByRef ppDisp As Object, ByRef cancel As Boolean) Implements DWebBrowserEvents2.NewWindow2
            Dim e As New WebBrowserNewWindow2EventArgs(ppDisp)
            Me.parent.OnNewWindow2(e)
            ppDisp = e.ppDisp
            cancel = e.Cancel
        End Sub

    End Class

End Class

Public Delegate Sub WebBrowserNewWindow2EventHandler(ByVal sender As Object, ByVal e As WebBrowserNewWindow2EventArgs)

Public Class WebBrowserNewWindow2EventArgs
    Inherits CancelEventArgs

    Private ppDispValue As Object

    Public Sub New(ByVal ppDisp As Object)
        Me.ppDispValue = ppDisp
    End Sub

    Public Property ppDisp() As Object
        Get
            Return ppDispValue
        End Get
        Set(ByVal value As Object)
            ppDispValue = value
        End Set
    End Property

End Class

<ComImport(), Guid("34A715A0-6587-11D0-924A-0020AFC7AC4D"),
InterfaceType(ComInterfaceType.InterfaceIsIDispatch),
TypeLibType(TypeLibTypeFlags.FHidden)>
Public Interface DWebBrowserEvents2

    <DispId(DISPID.NEWWINDOW2)> Sub NewWindow2(
        <InAttribute(), OutAttribute(), MarshalAs(UnmanagedType.IDispatch)> ByRef ppDisp As Object,
        <InAttribute(), OutAttribute()> ByRef cancel As Boolean)

End Interface

<ComImport(), Guid("D30C1661-CDAF-11D0-8A3E-00C04FC9E26E"),
InterfaceType(ComInterfaceType.InterfaceIsIDispatch)>
Public Interface IWebBrowser2

    ReadOnly Property Application() As <MarshalAs(UnmanagedType.IDispatch)> Object
    Property RegisterAsBrowser() As <MarshalAs(UnmanagedType.VariantBool)> Boolean

End Interface

Public Enum DISPID
    NEWWINDOW2 = 251
End Enum

参考にしたページ
・NET Frameworkクラスライブラリ WebBrowser.CreateSinkメソッド
・PINVOKE.NET IWebBrowser2(Interfaces)

※このTipsは2005年頃にNiftyの@homepageで公開していたもの一部変更して再掲載しました。
　http://homepage1.nifty.com/yasunari/VB/VB2005/WebBrowserNewWindow2Event.htm

20:24 | コメント(0) | WebBrowser

< 前の記事へ次の記事へ >一覧へ戻る