AxWebBrowserに関するTips。　Windows XP上のInternet Explorer 6.0で検証したもの。

Sponsored Link

セッション履歴を取得する

IEの戻る・進むボタンの横に付いているシェブロンをクリックすると、今まで閲覧してきたページの一覧が表示されます(「履歴」とは異なります)。　これを実現するためには、セッション履歴を取得します。

Function EnumSessionHistory(ByVal flags As ITravelLogStg.TLENUMF, ByVal maxEntries As Integer) As SessionHistory()

    Dim histories As New System.Collections.ArrayList

    ' 各インターフェイス
    Dim pISP As IServiceProvider = Nothing
    Dim pTLStg As ITravelLogStg = Nothing
    Dim pTLEnum As IEnumTravelLogEntry = Nothing

    Const S_OK As Integer = &H0
    Const S_FALSE As Integer = &H1

    Try

        ' IServiceProviderを取得
        pISP = DirectCast(m_AxWebBrowser.GetOcx(), IServiceProvider)

        ' ITravelLogStgを取得
        Dim ppvObject As Object

        pISP.QueryService(TravelLogGuid.SID_STravelLogCursor, TravelLogGuid.IID_ITravelLogStg, ppvObject)

        pTLStg = DirectCast(ppvObject, ITravelLogStg)

        ' IEnumTravelLogEntryを取得
        If S_OK = pTLStg.EnumEntries(flags, pTLEnum) AndAlso Not pTLEnum Is Nothing Then

            ' 列挙
            Do

                Dim pTLEntry As ITravelLogEntry = Nothing

                If pTLEnum.Next(1, pTLEntry, Nothing) = S_FALSE Then Exit Do

                If Not pTLEntry Is Nothing Then

                    Try

                        Dim urlPtr As IntPtr = IntPtr.Zero
                        Dim titlePtr As IntPtr = IntPtr.Zero

                        ' URLを取得
                        If S_OK = pTLEntry.GetURL(urlPtr) Then

                            ' タイトルを取得
                            If S_OK = pTLEntry.GetTitle(titlePtr) Then

                                ' ヒストリを追加
                                histories.Add(New SessionHistory(Marshal.PtrToStringUni(urlPtr), Marshal.PtrToStringUni(titlePtr)))

                            End If

                        End If

                    Finally

                        ' 列挙したエントリを解放
                        Marshal.ReleaseComObject(pTLEntry)

                        pTLEntry = Nothing

                    End Try

                    ' 列挙打ち切り
                    If maxEntries <= histories.Count Then Exit Do

                End If

            Loop

        End If

    Finally

        If Not pTLStg Is Nothing Then Marshal.ReleaseComObject(pTLStg)

        pTLStg = Nothing

        If Not pTLEnum Is Nothing Then Marshal.ReleaseComObject(pTLEnum)

        pTLEnum = Nothing

        If Not pISP Is Nothing Then Marshal.ReleaseComObject(pISP)

        pISP = Nothing

    End Try

    Return DirectCast(histories.ToArray(GetType(SessionHistory)), SessionHistory())

End Function

各インターフェイス、構造体の宣言は以下の通り。

Public Structure SessionHistory

    Public Sub New(ByVal url As String, ByVal title As String)

        m_Title = title
        m_Url = url

    End Sub

    Private m_Title As String

    Public ReadOnly Property Title() As String
        Get
            Return m_Title
        End Get
    End Property

    Private m_Url As String

    Public ReadOnly Property Url() As String
        Get
            Return m_Url
        End Get
    End Property

End Structure

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("6d5140c1-7436-11ce-8034-00aa006009fa"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface IServiceProvider

    <PreserveSig()> _
    Function QueryService _
    ( _
        ByRef guidService As Guid, _
        ByRef riid As Guid, _
        <Out(), MarshalAs(UnmanagedType.Interface)> ByRef ppvObject As Object _
    ) _
    As Integer

End Interface

Public NotInheritable Class TravelLogGuid

    Private Sub New()
    End Sub

    Public Shared ReadOnly SID_STravelLogCursor As Guid = New Guid("7EBFDD80-AD18-11d3-A4C5-00C04F72D6B8")
    Public Shared ReadOnly IID_ITravelLogStg As Guid = New Guid("7EBFDD80-AD18-11d3-A4C5-00C04F72D6B8")

End Class

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("7EBFDD87-AD18-11d3-A4C5-00C04F72D6B8"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface ITravelLogEntry

    <PreserveSig()> Function GetTitle(<Out()> ByRef title As IntPtr) As Integer
    <PreserveSig()> Function GetURL(<Out()> ByRef url As IntPtr) As Integer

End Interface

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("7EBFDD85-AD18-11d3-A4C5-00C04F72D6B8"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface IEnumTravelLogEntry

    <PreserveSig()> _
    Function [Next] _
    ( _
        <[In](), MarshalAs(UnmanagedType.U4)> ByVal cElt As Integer, _
        <Out(), MarshalAs(UnmanagedType.Interface)> ByRef rgElt As ITravelLogEntry, _
        <Out(), MarshalAs(UnmanagedType.U4)> ByRef pcEltFetched As Integer _
    ) _
    As Integer

    <PreserveSig()> _
    Function Skip _
    ( _
        <[In](), MarshalAs(UnmanagedType.U4)> ByVal cElt As Integer _
    ) _
    As Integer

    <PreserveSig()> Function Reset() As Integer

    <PreserveSig()> _
    Function Clone _
    ( _
        <Out(), MarshalAs(UnmanagedType.Interface)> ByRef ppEnum As IEnumTravelLogEntry _
    ) _
    As Integer

End Interface

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("7EBFDD80-AD18-11d3-A4C5-00C04F72D6B8"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface ITravelLogStg

    Enum TLENUMF As Integer

        TLEF_RELATIVE_INCLUDE_CURRENT = &H1
        TLEF_RELATIVE_BACK = &H10
        TLEF_RELATIVE_FORE = &H20
        TLEF_INCLUDE_UNINVOKEABLE = &H40
        TLEF_ABSOLUTE = &H31

    End Enum

    <PreserveSig()> _
    Function CreateEntry _
    ( _
        <[In](), MarshalAs(UnmanagedType.BStr)> ByVal pszUrl As String, _
        <[In](), MarshalAs(UnmanagedType.BStr)> ByVal pszTitle As String, _
        <[In](), MarshalAs(UnmanagedType.Interface)> ByVal ptleRelativeTo As ITravelLogEntry, _
        <[In](), MarshalAs(UnmanagedType.Bool)> ByVal fPrepend As Boolean, _
        <Out(), MarshalAs(UnmanagedType.Interface)> ByRef pptle As ITravelLogEntry _
    ) _
    As Integer

    <PreserveSig()> _
    Function TravelTo _
    ( _
        <[In]()> ByVal ptle As ITravelLogEntry _
    ) _
    As Integer

    <PreserveSig()> _
    Function EnumEntries _
    ( _
        <[In](), MarshalAs(UnmanagedType.U4)> ByVal ptle As TLENUMF, _
        <Out(), MarshalAs(UnmanagedType.Interface)> ByRef ppenum As IEnumTravelLogEntry _
    ) _
    As Integer

    <PreserveSig()> _
    Function FindEntries _
    ( _
        <[In](), MarshalAs(UnmanagedType.U4)> ByVal flags As TLENUMF, _
        <[In](), MarshalAs(UnmanagedType.BStr)> ByVal pszUrl As String, _
        <Out(), MarshalAs(UnmanagedType.Interface)> ByRef ppenum As IEnumTravelLogEntry _
    ) _
    As Integer

    <PreserveSig()> _
    Function GetCount _
    ( _
        <[In](), MarshalAs(UnmanagedType.U4)> ByVal flags As TLENUMF, _
        <Out(), MarshalAs(UnmanagedType.U4)> ByRef pcEntries As Integer _
    ) _
    As Integer

    <PreserveSig()> _
    Function RemoveEntry _
    ( _
        <[In](), MarshalAs(UnmanagedType.Interface)> ByVal ptle As ITravelLogEntry _
    ) _
    As Integer

    <PreserveSig()> _
    Function GetRelativeEntry _
    ( _
        <[In]()> ByVal iOffset As Integer, _
        <Out(), MarshalAs(UnmanagedType.Interface)> ByRef ptle As ITravelLogEntry _
    ) _
    As Integer

End Interface
 _
Public Interface IServiceProvider

     _
    Function QueryService _
    ( _
        ByRef guidService As Guid, _
        ByRef riid As Guid, _
         ByRef ppvObject As Object _
    ) _
    As Integer

End Interface

Public NotInheritable Class TravelLogGuid

    Private Sub New()
    End Sub

    Public Shared ReadOnly SID_STravelLogCursor As Guid = New Guid("7EBFDD80-AD18-11d3-A4C5-00C04F72D6B8")
    Public Shared ReadOnly IID_ITravelLogStg As Guid = New Guid("7EBFDD80-AD18-11d3-A4C5-00C04F72D6B8")

End Class

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("7EBFDD87-AD18-11d3-A4C5-00C04F72D6B8"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface ITravelLogEntry

     Function GetTitle( ByRef title As IntPtr) As Integer
     Function GetURL( ByRef url As IntPtr) As Integer

End Interface

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("7EBFDD85-AD18-11d3-A4C5-00C04F72D6B8"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface IEnumTravelLogEntry

     _
    Function [Next] _
    ( _
        <[In](), MarshalAs(UnmanagedType.U4)> ByVal cElt As Integer, _
         ByRef rgElt As ITravelLogEntry, _
         ByRef pcEltFetched As Integer _
    ) _
    As Integer

     _
    Function Skip _
    ( _
        <[In](), MarshalAs(UnmanagedType.U4)> ByVal cElt As Integer _
    ) _
    As Integer

     Function Reset() As Integer

     _
    Function Clone _
    ( _
         ByRef ppEnum As IEnumTravelLogEntry _
    ) _
    As Integer

End Interface

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("7EBFDD80-AD18-11d3-A4C5-00C04F72D6B8"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface ITravelLogStg

    Enum TLENUMF As Integer

        TLEF_RELATIVE_INCLUDE_CURRENT = &H1
        TLEF_RELATIVE_BACK = &H10
        TLEF_RELATIVE_FORE = &H20
        TLEF_INCLUDE_UNINVOKEABLE = &H40
        TLEF_ABSOLUTE = &H31

    End Enum

     _
    Function CreateEntry _
    ( _
        <[In](), MarshalAs(UnmanagedType.BStr)> ByVal pszUrl As String, _
        <[In](), MarshalAs(UnmanagedType.BStr)> ByVal pszTitle As String, _
        <[In](), MarshalAs(UnmanagedType.Interface)> ByVal ptleRelativeTo As ITravelLogEntry, _
        <[In](), MarshalAs(UnmanagedType.Bool)> ByVal fPrepend As Boolean, _
         ByRef pptle As ITravelLogEntry _
    ) _
    As Integer

     _
    Function TravelTo _
    ( _
        <[In]()> ByVal ptle As ITravelLogEntry _
    ) _
    As Integer

     _
    Function EnumEntries _
    ( _
        <[In](), MarshalAs(UnmanagedType.U4)> ByVal ptle As TLENUMF, _
         ByRef ppenum As IEnumTravelLogEntry _
    ) _
    As Integer

     _
    Function FindEntries _
    ( _
        <[In](), MarshalAs(UnmanagedType.U4)> ByVal flags As TLENUMF, _
        <[In](), MarshalAs(UnmanagedType.BStr)> ByVal pszUrl As String, _
         ByRef ppenum As IEnumTravelLogEntry _
    ) _
    As Integer

     _
    Function GetCount _
    ( _
        <[In](), MarshalAs(UnmanagedType.U4)> ByVal flags As TLENUMF, _
         ByRef pcEntries As Integer _
    ) _
    As Integer

     _
    Function RemoveEntry _
    ( _
        <[In](), MarshalAs(UnmanagedType.Interface)> ByVal ptle As ITravelLogEntry _
    ) _
    As Integer

     _
    Function GetRelativeEntry _
    ( _
        <[In]()> ByVal iOffset As Integer, _
         ByRef ptle As ITravelLogEntry _
    ) _
    As Integer

End Interface]]>
⇑

セッション履歴を使ってページを移動する

「三つ前に見ていたページへ移動する」といったことを行う場合にもセッション履歴を使います。　次のメソッド TravelToSessionHistoryはセッション履歴を使ってoffset分だけ移動します。　offsetが正なら「進む」の方向、負なら「戻る」の方向に移動します。　offsetが-3ならば三つ前のページに移動します。

Sub TravelToSessionHistory(ByVal offset As Integer)

    ' 各インターフェイス
    Dim pISP As IServiceProvider = Nothing
    Dim pTLStg As ITravelLogStg = Nothing

    Const S_OK As Integer = &H0
    Const S_FALSE As Integer = &H1

    Try

        ' IServiceProviderを取得
        pISP = DirectCast(m_AxWebBrowser.GetOcx(), IServiceProvider)

        ' ITravelLogStgを取得
        Dim ppvObject As Object

        pISP.QueryService(TravelLogGuid.SID_STravelLogCursor, TravelLogGuid.IID_ITravelLogStg, ppvObject)

        pTLStg = DirectCast(ppvObject, ITravelLogStg)

        ' 指定されたoffsetからITravelLogEntryを取得 
        Dim pTLEntry As ITravelLogEntry = Nothing

        If S_OK = pTLStg.GetRelativeEntry(offset, pTLEntry) Then

            Try

                pTLStg.TravelTo(pTLEntry)

            Finally

                ' 取得したエントリを解放
                Marshal.ReleaseComObject(pTLEntry)

                pTLEntry = Nothing

            End Try

        End If

    Finally

        If Not pTLStg Is Nothing Then Marshal.ReleaseComObject(pTLStg)

        pTLStg = Nothing

        If Not pISP Is Nothing Then Marshal.ReleaseComObject(pISP)

        pISP = Nothing

    End Try

End Sub
⇑

「新しいウィンドウで開く」場合にIEが起動するのを防ぐ

まず、AxWebBrowserのNewWindow2イベントにイベントハンドラを割り当てます。　これで新しいウィンドウが開かれるときにこのハンドラが呼び出されます。　次に、イベント引数のDWebBrowserEvents2_NewWindow2Event.ppDispに AxWebBrowserのインスタンスを設定すれば新しいウィンドウの代わりにそのインスタンスが使用されます。　このとき、 AxWebBrowser.RegisterAsBrowserをTrueに設定します。

Class WebBrowser

    Private m_AxWebBrowser As AxWebBrowser

    ReadOnly Property AxWebBrowser As AxWebBrowser
        Get
            Return m_AxWebBrowser
        End Get
    End Property

    Private Sub Initialize()  

        AddHandler m_AxWebBrowser.NewWindow2, AddressOf AxWebBrowser_NewWindow2

    End Sub

    Private Sub AxWebBrowser_NewWindow2(ByVal sender As Object, ByVal e As DWebBrowserEvents2_NewWindow2Event)

        If Not e.cancel Then

            Dim browser As New WebBrowser()

            e.ppDisp = browser.AxWebBrowser.Application

            browser.AxWebBrowser.RegisterAsBrowser = True

        End If

    End Sub

End Class
⇑

Ctrl+NでIEのインスタンスが起動するのを防ぐ

IEでCtrl+Nを押すと新しいウィンドウが開きます。　これを阻止したい場合には、Ctrl+Nを無視するようにしてやります。　まず、キーイベントを取得するためにIDocHostUIHandlerとIOleClientSiteを実装したクラスを作成し、 IDocHostUIHandler.TranslateAcceleratorメソッドでWM_KEYDOWNを受信します。

この方法を使えば、Ctrl+N以外のショートカット(例えばCtrl+Pの「印刷」など)も無効にすることが出来ます。

Class Browser

    Inherits System.Windows.Forms.Control

    Implements IOleClientSite
    Implements IDocHostUIHandler

    Private m_AxWebBrowser As AxWebBrowser

    Public Sub New()

        MyBase.New()

        m_AxWebBrowser = New AxWebBrowser

        DirectCast(m_AxWebBrowser.GetOcx(), IOleObject).SetClientSite(Me)

    End Sub

#Region "IOleClientSite"

    Private Sub GetContainer(ByRef ppContainer As Object) Implements IOleClientSite.GetContainer

        ppContainer = Me

    End Sub

    Private Sub GetMoniker(ByVal dwAssign As Integer, ByVal dwWhichMoniker As Integer, ByRef ppmk As Object) Implements IOleClientSite.GetMoniker
    End Sub

    Private Sub OnShowWindow(ByVal fShow As Boolean) Implements IOleClientSite.OnShowWindow
    End Sub

    Private Sub RequestNewObjectLayout() Implements IOleClientSite.RequestNewObjectLayout
    End Sub

    Private Sub SaveObject() Implements IOleClientSite.SaveObject
    End Sub

    Private Sub ShowObject() Implements IOleClientSite.ShowObject
    End Sub

#End Region

#Region "IDocHostUIHandler"

    Private Sub EnableModeless(ByVal fEnable As Integer) Implements IDocHostUIHandler.EnableModeless
    End Sub

    Private Function FilterDataObject(ByVal pDO As IDataObject) As IDataObject Implements IDocHostUIHandler.FilterDataObject

        Return pDO

    End Function

    Private Function GetDropTarget(ByVal pDropTarget As IDropTarget) As IDropTarget Implements IDocHostUIHandler.GetDropTarget

        Return pDropTarget

    End Function

    Private Function GetExternal() As Object Implements IDocHostUIHandler.GetExternal

        Return Nothing

    End Function

    Private Sub GetHostInfo(ByRef theHostUIInfo As DOCHOSTUIINFO) Implements IDocHostUIHandler.GetHostInfo
    End Sub

    Private Sub GetOptionKeyPath(ByRef pchKey As String, ByVal dw As Integer) Implements IDocHostUIHandler.GetOptionKeyPath
    End Sub

    Private Sub HideUI() Implements IDocHostUIHandler.HideUI
    End Sub

    Private Sub OnDocWindowActivate(ByVal fActivate As Integer) Implements IDocHostUIHandler.OnDocWindowActivate
    End Sub

    Private Sub OnFrameWindowActivate(ByVal fActivate As Integer) Implements IDocHostUIHandler.OnFrameWindowActivate
    End Sub

    Private Sub ResizeBorder(ByRef prcBorder As tagRECT, ByVal pUIWindow As Integer, ByVal fFrameWindow As Integer) Implements IDocHostUIHandler.ResizeBorder
    End Sub

    Private Function ShowContextMenu(ByVal dwID As Integer, ByRef ppt As mshtml.tagPOINT, ByVal pcmdtReserved As IOleCommandTarget, ByVal pdispReserved As Object) As Integer Implements IDocHostUIHandler.ShowContextMenu

        Const S_FALSE As Integer = 1

        Return S_FALSE

    End Function

    Private Sub ShowUI(ByVal dwID As Integer, ByRef pActiveObject As Object, ByRef pCommandTarget As IOleCommandTarget, ByRef pFrame As Object, ByRef pDoc As Object) Implements IDocHostUIHandler.ShowUI
    End Sub

    Private Function TranslateAccelerator(ByRef lpMsg As tagMSG, ByRef pguidCmdGroup As System.Guid, ByVal nCmdID As Integer) As Integer Implements IDocHostUIHandler.TranslateAccelerator

        Const WM_KEYDOWN As Integer = &H100
        Const S_FALSE As Integer = 1
        Const S_OK As Integer = 0

        ' Ctrl+Nを無視する
        If lpMsg.message = WM_KEYDOWN Then

            ' Ctrlキーが押されている
            If (Control.ModifierKeys And Keys.Control) = Keys.Control Then

                Dim keyCode As Byte = CByte(lpMsg.wParam And &HFF)

                ' 何も行わない
                If keyCode = Keys.N Then Return S_OK

            End If

        End If

        ' 通常の処理を行う
        Return S_FALSE

    End Function

    Private Function TranslateUrl(ByVal dwTranslate As Integer, ByVal pchURLIn As Integer) As Integer Implements IDocHostUIHandler.TranslateUrl

        Return 0

    End Function

    Private Sub UpdateUI() Implements IDocHostUIHandler.UpdateUI
    End Sub

#End Region

End Class

インターフェイスの定義などは以下のとおり。

Public Enum DOCHOSTUITYPE

    DOCHOSTUITYPE_BROWSE = 0
    DOCHOSTUITYPE_AUTHOR = 1

End Enum

Public Enum DOCHOSTUIDBLCLK

    DOCHOSTUIDBLCLK_DEFAULT = 0
    DOCHOSTUIDBLCLK_SHOWPROPERTIES = 1
    DOCHOSTUIDBLCLK_SHOWCODE = 2

End Enum

<Flags()> _
Public Enum DOCHOSTUIFLAG

    DOCHOSTUIFLAG_DIALOG = &H1
    DOCHOSTUIFLAG_DISABLE_HELP_MENU = &H2
    DOCHOSTUIFLAG_NO3DBORDER = &H4
    DOCHOSTUIFLAG_SCROLL_NO = &H8
    DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE = &H10
    DOCHOSTUIFLAG_OPENNEWWIN = &H20
    DOCHOSTUIFLAG_DISABLE_OFFSCREEN = &H40
    DOCHOSTUIFLAG_FLAT_SCROLLBAR = &H80
    DOCHOSTUIFLAG_DIV_BLOCKDEFAULT = &H100
    DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY = &H200
    DOCHOSTUIFLAG_OVERRIDEBEHAVIORFACTORY = &H400
    DOCHOSTUIFLAG_CODEPAGELINKEDFONTS = &H800
    DOCHOSTUIFLAG_URL_ENCODING_DISABLE_UTF8 = &H1000
    DOCHOSTUIFLAG_URL_ENCODING_ENABLE_UTF8 = &H2000
    DOCHOSTUIFLAG_ENABLE_FORMS_AUTOCOMPLETE = &H4000
    DOCHOSTUIFLAG_ENABLE_INPLACE_NAVIGATION = &H10000
    DOCHOSTUIFLAG_IME_ENABLE_RECONVERSION = &H20000
    DOCHOSTUIFLAG_THEME = &H40000
    DOCHOSTUIFLAG_NOTHEME = &H80000
    DOCHOSTUIFLAG_NOPICS = &H100000
    DOCHOSTUIFLAG_NO3DOUTERBORDER = &H200000
    DOCHOSTUIFLAG_DELEGATESIDOFDISPATCH = &H400000

End Enum

<StructLayout(LayoutKind.Sequential)> _
Public Structure DOCHOSTUIINFO

    Public cbSize As Integer
    Public dwFlags As Integer
    Public dwDoubleClick As Integer
    <MarshalAs(UnmanagedType.BStr)> Public pchHostCss As String
    <MarshalAs(UnmanagedType.BStr)> Public pchHostNS As String

End Structure

<StructLayout(LayoutKind.Sequential, Pack:=4)> _
Public Structure tagMSG

    Public hwnd As IntPtr
    Public message As Integer
    Public wParam As Integer
    Public lParam As Integer
    Public time As Integer
    Public pt As tagPOINT

End Structure


< _
    ComImport(), _
    ComVisible(False), _
    Guid("BD3F23C0-D43E-11CF-893B-00AA00BDCE1A"), _
    InterfaceType(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface IDocHostUIHandler

    <PreserveSig()> _
    Function ShowContextMenu( _
        ByVal dwID As Integer, _
        ByRef ppt As tagPOINT, _
        ByVal pcmdtReserved As IOleCommandTarget, _
        <MarshalAs(UnmanagedType.IDispatch)> ByVal pdispReserved As Object) _
    As Integer

    Sub GetHostInfo(ByRef theHostUIInfo As DOCHOSTUIINFO)

    Sub ShowUI(ByVal dwID As Integer, _
        ByRef pActiveObject As Object, _
        ByRef pCommandTarget As IOleCommandTarget, _
        ByRef pFrame As Object, _
        ByRef pDoc As Object)

    Sub HideUI()
    Sub UpdateUI()
    Sub EnableModeless(ByVal fEnable As Integer)
    Sub OnDocWindowActivate(ByVal fActivate As Integer)
    Sub OnFrameWindowActivate(ByVal fActivate As Integer)
    Sub ResizeBorder(ByRef prcBorder As tagRECT, ByVal pUIWindow As Integer, ByVal fFrameWindow As Integer)

    <PreserveSig()> _
    Function TranslateAccelerator( _
        ByRef lpMsg As tagMSG, _
        ByRef pguidCmdGroup As Guid, _
        ByVal nCmdID As Integer) _
    As Integer

    Sub GetOptionKeyPath(<MarshalAs(UnmanagedType.BStr)> ByRef pchKey As String, ByVal dw As Integer)

    Function GetDropTarget(ByVal pDropTarget As IDropTarget) As IDropTarget

    Function GetExternal() As <MarshalAs(UnmanagedType.IDispatch)> Object

    Function TranslateUrl(ByVal dwTranslate As Integer, ByVal pchURLIn As Integer) As Integer

    Function FilterDataObject(ByVal pDO As IDataObject) As IDataObject

End Interface

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("00000118-0000-0000-C000-000000000046"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface IOleClientSite

    Sub SaveObject()
    Sub GetMoniker(ByVal dwAssign As Integer, ByVal dwWhichMoniker As Integer, ByRef ppmk As Object)
    Sub GetContainer(ByRef ppContainer As Object)
    Sub ShowObject()
    Sub OnShowWindow(ByVal fShow As Boolean)
    Sub RequestNewObjectLayout()

End Interface

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("00000112-0000-0000-C000-000000000046"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface IOleObject

    Sub SetClientSite(ByVal pClientSite As IOleClientSite)
    Sub GetClientSite(ByRef ppClientSite As IOleClientSite)
    Sub SetHostNames(ByVal szContainerApp As Object, ByVal szContainerObj As Object)
    Sub Close(ByVal dwSaveOption As Integer)
    Sub SetMoniker(ByVal dwWhichMoniker As Integer, ByVal pmk As Object)
    Sub GetMoniker(ByVal dwAssign As Integer, ByVal dwWhichMoniker As Integer, ByVal ppmk As Object)
    Sub InitFromData(ByVal pDataObject As IDataObject, ByVal fCreation As Boolean, ByVal dwReserved As Integer)
    Sub GetClipboardData(ByVal dwReserved As Integer, ByRef ppDataObject As IDataObject)
    Sub DoVerb(ByVal iVerb As Integer, ByVal lpmsg As Integer, ByVal pActiveSite As Object, ByVal lindex As Integer, ByVal hwndParent As Integer, ByVal lprcPosRect As Integer)
    Sub EnumVerbs(ByRef ppEnumOleVerb As Object)
    Sub Update()
    Sub IsUpToDate()
    Sub GetUserClassID(ByVal pClsid As Integer)
    Sub GetUserType(ByVal dwFormOfType As Integer, ByVal pszUserType As Integer)
    Sub SetExtent(ByVal dwDrawAspect As Integer, ByVal psizel As Integer)
    Sub GetExtent(ByVal dwDrawAspect As Integer, ByVal psizel As Integer)
    Sub Advise(ByVal pAdvSink As Object, ByVal pdwConnection As Integer)
    Sub Unadvise(ByVal dwConnection As Integer)
    Sub EnumAdvise(ByRef ppenumAdvise As Object)
    Sub GetMiscStatus(ByVal dwAspect As Integer, ByVal pdwStatus As Integer)
    Sub SetColorScheme(ByVal pLogpal As Object)

End Interface
 _
Public Enum DOCHOSTUIFLAG

    DOCHOSTUIFLAG_DIALOG = &H1
    DOCHOSTUIFLAG_DISABLE_HELP_MENU = &H2
    DOCHOSTUIFLAG_NO3DBORDER = &H4
    DOCHOSTUIFLAG_SCROLL_NO = &H8
    DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE = &H10
    DOCHOSTUIFLAG_OPENNEWWIN = &H20
    DOCHOSTUIFLAG_DISABLE_OFFSCREEN = &H40
    DOCHOSTUIFLAG_FLAT_SCROLLBAR = &H80
    DOCHOSTUIFLAG_DIV_BLOCKDEFAULT = &H100
    DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY = &H200
    DOCHOSTUIFLAG_OVERRIDEBEHAVIORFACTORY = &H400
    DOCHOSTUIFLAG_CODEPAGELINKEDFONTS = &H800
    DOCHOSTUIFLAG_URL_ENCODING_DISABLE_UTF8 = &H1000
    DOCHOSTUIFLAG_URL_ENCODING_ENABLE_UTF8 = &H2000
    DOCHOSTUIFLAG_ENABLE_FORMS_AUTOCOMPLETE = &H4000
    DOCHOSTUIFLAG_ENABLE_INPLACE_NAVIGATION = &H10000
    DOCHOSTUIFLAG_IME_ENABLE_RECONVERSION = &H20000
    DOCHOSTUIFLAG_THEME = &H40000
    DOCHOSTUIFLAG_NOTHEME = &H80000
    DOCHOSTUIFLAG_NOPICS = &H100000
    DOCHOSTUIFLAG_NO3DOUTERBORDER = &H200000
    DOCHOSTUIFLAG_DELEGATESIDOFDISPATCH = &H400000

End Enum

 _
Public Structure DOCHOSTUIINFO

    Public cbSize As Integer
    Public dwFlags As Integer
    Public dwDoubleClick As Integer
     Public pchHostCss As String
     Public pchHostNS As String

End Structure

 _
Public Structure tagMSG

    Public hwnd As IntPtr
    Public message As Integer
    Public wParam As Integer
    Public lParam As Integer
    Public time As Integer
    Public pt As tagPOINT

End Structure


< _
    ComImport(), _
    ComVisible(False), _
    Guid("BD3F23C0-D43E-11CF-893B-00AA00BDCE1A"), _
    InterfaceType(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface IDocHostUIHandler

     _
    Function ShowContextMenu( _
        ByVal dwID As Integer, _
        ByRef ppt As tagPOINT, _
        ByVal pcmdtReserved As IOleCommandTarget, _
         ByVal pdispReserved As Object) _
    As Integer

    Sub GetHostInfo(ByRef theHostUIInfo As DOCHOSTUIINFO)

    Sub ShowUI(ByVal dwID As Integer, _
        ByRef pActiveObject As Object, _
        ByRef pCommandTarget As IOleCommandTarget, _
        ByRef pFrame As Object, _
        ByRef pDoc As Object)

    Sub HideUI()
    Sub UpdateUI()
    Sub EnableModeless(ByVal fEnable As Integer)
    Sub OnDocWindowActivate(ByVal fActivate As Integer)
    Sub OnFrameWindowActivate(ByVal fActivate As Integer)
    Sub ResizeBorder(ByRef prcBorder As tagRECT, ByVal pUIWindow As Integer, ByVal fFrameWindow As Integer)

     _
    Function TranslateAccelerator( _
        ByRef lpMsg As tagMSG, _
        ByRef pguidCmdGroup As Guid, _
        ByVal nCmdID As Integer) _
    As Integer

    Sub GetOptionKeyPath( ByRef pchKey As String, ByVal dw As Integer)

    Function GetDropTarget(ByVal pDropTarget As IDropTarget) As IDropTarget

    Function GetExternal() As  Object

    Function TranslateUrl(ByVal dwTranslate As Integer, ByVal pchURLIn As Integer) As Integer

    Function FilterDataObject(ByVal pDO As IDataObject) As IDataObject

End Interface

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("00000118-0000-0000-C000-000000000046"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface IOleClientSite

    Sub SaveObject()
    Sub GetMoniker(ByVal dwAssign As Integer, ByVal dwWhichMoniker As Integer, ByRef ppmk As Object)
    Sub GetContainer(ByRef ppContainer As Object)
    Sub ShowObject()
    Sub OnShowWindow(ByVal fShow As Boolean)
    Sub RequestNewObjectLayout()

End Interface

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("00000112-0000-0000-C000-000000000046"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface IOleObject

    Sub SetClientSite(ByVal pClientSite As IOleClientSite)
    Sub GetClientSite(ByRef ppClientSite As IOleClientSite)
    Sub SetHostNames(ByVal szContainerApp As Object, ByVal szContainerObj As Object)
    Sub Close(ByVal dwSaveOption As Integer)
    Sub SetMoniker(ByVal dwWhichMoniker As Integer, ByVal pmk As Object)
    Sub GetMoniker(ByVal dwAssign As Integer, ByVal dwWhichMoniker As Integer, ByVal ppmk As Object)
    Sub InitFromData(ByVal pDataObject As IDataObject, ByVal fCreation As Boolean, ByVal dwReserved As Integer)
    Sub GetClipboardData(ByVal dwReserved As Integer, ByRef ppDataObject As IDataObject)
    Sub DoVerb(ByVal iVerb As Integer, ByVal lpmsg As Integer, ByVal pActiveSite As Object, ByVal lindex As Integer, ByVal hwndParent As Integer, ByVal lprcPosRect As Integer)
    Sub EnumVerbs(ByRef ppEnumOleVerb As Object)
    Sub Update()
    Sub IsUpToDate()
    Sub GetUserClassID(ByVal pClsid As Integer)
    Sub GetUserType(ByVal dwFormOfType As Integer, ByVal pszUserType As Integer)
    Sub SetExtent(ByVal dwDrawAspect As Integer, ByVal psizel As Integer)
    Sub GetExtent(ByVal dwDrawAspect As Integer, ByVal psizel As Integer)
    Sub Advise(ByVal pAdvSink As Object, ByVal pdwConnection As Integer)
    Sub Unadvise(ByVal dwConnection As Integer)
    Sub EnumAdvise(ByRef ppenumAdvise As Object)
    Sub GetMiscStatus(ByVal dwAspect As Integer, ByVal pdwStatus As Integer)
    Sub SetColorScheme(ByVal pLogpal As Object)

End Interface]]>
⇑

ページに表示されるボタンなどにテーマを適用する

IDocHostUIHandler.GetHostInfoにてDOCHOSTUIFLAG_THEMEフラグを立ててやればテーマが適用されるようになります。　また、DOCHOSTUIFLAG_NO3DBORDERフラグを立ててやればコントロールの枠線を消すことが出来ます。

Private Sub GetHostInfo(ByRef theHostUIInfo As DOCHOSTUIINFO) Implements IDocHostUIHandler.GetHostInfo

    theHostUIInfo.dwFlags = theHostUIInfo.dwFlags Or DOCHOSTUIFLAG.DOCHOSTUIFLAG_NO3DBORDER Or DOCHOSTUIFLAG.DOCHOSTUIFLAG_THEME

End Sub

IDocHostUIHandlerの実装は先に紹介した通り。

⇑

ページのフォントサイズを変える

AxWebBrowser.ExecWBメソッドを利用してフォントサイズを変更できます。　指定できるフォントサイズは

4
最大
3
大
2
中
1
小
0
最小

です。

Private Sub SetFontSize(ByVal fontSize As Integer)

    ' OLECMDID.OLECMDID_ZOOM As Integer = 19
    ' OLECMDEXECOPT.OLECMDEXECOPT_DONTPROMPTUSER = As Integer = 0

    Dim val As Object = fontSize
    Dim result As Object = New Object

    AxWebBrowser.ExecWB(OLECMDID.OLECMDID_ZOOM, OLECMDEXECOPT.OLECMDEXECOPT_DONTPROMPTUSER, val, result)

End Sub

Private Function GetFontSize()

    Dim val As Object = New Object
    Dim result As Object = New Object

    Try

        AxWebBrowser.ExecWB(OLECMDID.OLECMDID_ZOOM, OLECMDEXECOPT.OLECMDEXECOPT_DONTPROMPTUSER, val, result)

        Return CInt(result)

    Catch

        Return -1

    End Try

End Sub
⇑

OLEコマンドを実行する・OLEコマンドが有効か調べる

保存や印刷、切り取り・貼り付けといった基本的な機能はAxWebBrowser.ExecWBメソッドで簡単に実行出来ます。　また、その機能がサポートされているか・現在使える状態にあるかといった情報はQueryStatusWBメソッドで調べることが出来ます。

''' <summary>
''' 指定されたOLEコマンドが有効か否かを調べる
''' </summary>
Private Function IsOleCommandEnabled(ByVal cmdID As Browser.OLECMDID) As Boolean

    Return (m_Browser.QueryStatusWB(cmdID) = (Browser.OLECMDF.OLECMDF_SUPPORTED Or Browser.OLECMDF.OLECMDF_ENABLED))

End Function

''' <summary>
''' 指定されたOLEコマンドを実行する
''' </summary>
Private Sub ExecuteOleCommand(ByVal cmdID As Browser.OLECMDID, ByVal cmdexecopt As Browser.OLECMDEXECOPT)

    Dim input As Object = New Object
    Dim output As Object = New Object

    ExecuteOleCommand(cmdID, cmdexecopt, input, output)

End Sub

''' 指定されたOLEコマンドが有効か否かを調べる
''' 
Private Function IsOleCommandEnabled(ByVal cmdID As Browser.OLECMDID) As Boolean

    Return (m_Browser.QueryStatusWB(cmdID) = (Browser.OLECMDF.OLECMDF_SUPPORTED Or Browser.OLECMDF.OLECMDF_ENABLED))

End Function

''' 
''' 指定されたOLEコマンドを実行する
''' 
Private Sub ExecuteOleCommand(ByVal cmdID As Browser.OLECMDID, ByVal cmdexecopt As Browser.OLECMDEXECOPT)

    Dim input As Object = New Object
    Dim output As Object = New Object

    ExecuteOleCommand(cmdID, cmdexecopt, input, output)

End Sub]]>

これらのメソッドで有効なコマンドはOLECMDID(MSDN OLECMDID Enumeration)として定義されています。

⇑

検索・ソースの表示・インターネットオプションの表示

IOleCommandTargetインターフェイスのExecメソッドを使うことにより、検索ダイアログの表示、閲覧しているページのHTMLソースの表示、インターネットオプションのダイアログ表示を行うことが出来ます。

Const OLECMDEXECOPT_DODEFAULT As Integer = 0 
Const HTMLID_FIND As Integer = 1 ' 検索ダイアログの表示
Const HTMLID_VIEWSOURCE As Integer = 2 ' ソースの表示
Const HTMLID_OPTIONS As Integer = 3 ' インターネットオプションのダイアログ表示

Dim GuidIWebBrowser As Guid = New Guid("ED016940-BD5B-11CF-BA4E-00C04FD70816")

Dim browser As SHDocVw.IWebBrowser2 = DirectCast(m_AxWebBrowser.GetOcx(), SHDocVw.IWebBrowser2)

Dim oleCommandTarget As IOleCommandTarget = DirectCast(browser, IOleCommandTarget)

Dim input As Object = New Object
Dim output As Object = New Object

' 検索ダイアログを表示
oleCommandTarget.Exec(GuidIWebBrowser, HTMLID_FIND, OLECMDEXECOPT_DODEFAULT, input, output)

各インターフェイスの定義は以下の通り。

<StructLayout(LayoutKind.Sequential, CharSet:=CharSet.Unicode)> _
    Public Structure OLECMDTEXT

    Public cmdtextf As Integer
    Public cwActual As Integer
    Public cwBuf As Integer
    <MarshalAs(UnmanagedType.ByValTStr, SizeConst:=100)> Public rgwz As Char

End Structure

<StructLayout(LayoutKind.Sequential)> _
Public Structure OLECMD

    Public cmdID As Integer
    Public cmdf As Integer

End Structure

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("b722bccb-4e68-101b-a2bc-00aa00404770"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface IOleCommandTarget

    <PreserveSig()> _
    Function QueryStatus( _
        ByVal pguidCmdGroup As Guid, _
        ByVal cCmds As Integer, _
        <MarshalAs(UnmanagedType.LPArray, SizeParamIndex:=1)> ByRef prgCmds As OLECMD(), _
        ByRef CmdText As OLECMDTEXT) _
    As Integer

    <PreserveSig()> _
    Function Exec( _
        ByRef pguidCmdGroup As Guid, _
        ByVal nCmdId As Integer, _
        ByVal nCmdExecOpt As Integer, _
        ByRef pvaIn As Object, _
        ByRef pvaOut As Object) _
    As Integer

End Interface
 _
    Public Structure OLECMDTEXT

    Public cmdtextf As Integer
    Public cwActual As Integer
    Public cwBuf As Integer
     Public rgwz As Char

End Structure

 _
Public Structure OLECMD

    Public cmdID As Integer
    Public cmdf As Integer

End Structure

< _
    ComImport(), _
    ComVisible(False), _
    GuidAttribute("b722bccb-4e68-101b-a2bc-00aa00404770"), _
    InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIUnknown) _
> _
Public Interface IOleCommandTarget

     _
    Function QueryStatus( _
        ByVal pguidCmdGroup As Guid, _
        ByVal cCmds As Integer, _
         ByRef prgCmds As OLECMD(), _
        ByRef CmdText As OLECMDTEXT) _
    As Integer

     _
    Function Exec( _
        ByRef pguidCmdGroup As Guid, _
        ByVal nCmdId As Integer, _
        ByVal nCmdExecOpt As Integer, _
        ByRef pvaIn As Object, _
        ByRef pvaOut As Object) _
    As Integer

End Interface]]>

ちなみに、

System.Diagnostics.Process.Start("control.exe", "inetcpl.cpl")

とすることでもダイアログの表示は出来ますが、この方法ではモードレスダイアログとして表示されます。

⇑

ActiveXやJavaScriptの実行を制御する

ActiveXコントロールの実行を許可したり拒否したりするにはDISPID_AMBIENT_DLCONTROLアンビエントプロパティを実装し、フラグを設定することで可能になります。　このプロパティで、画像・映像のダウンロード許可、ActiveXコントロールのインストール許可なども設定できます。　設定可能な項目は、Web Development, Download Controlを参照してください。

< _
    ClassInterface(ClassInterfaceType.AutoDispatch) _
> _
Class Browser

    Inherits System.Windows.Forms.Control

    Implements IOleClientSite

    Private m_AxWebBrowser As AxWebBrowser

    Public Sub New()

        MyBase.New()

        m_AxWebBrowser = New AxWebBrowser

        DirectCast(m_AxWebBrowser.GetOcx(), IOleObject).SetClientSite(Me)

    End Sub

#Region "IOleClientSite"

    Private Sub GetContainer(ByRef ppContainer As Object) Implements IOleClientSite.GetContainer

        ppContainer = Me

    End Sub

    Private Sub GetMoniker(ByVal dwAssign As Integer, ByVal dwWhichMoniker As Integer, ByRef ppmk As Object) Implements IOleClientSite.GetMoniker
    End Sub

    Private Sub OnShowWindow(ByVal fShow As Boolean) Implements IOleClientSite.OnShowWindow
    End Sub

    Private Sub RequestNewObjectLayout() Implements IOleClientSite.RequestNewObjectLayout
    End Sub

    Private Sub SaveObject() Implements IOleClientSite.SaveObject
    End Sub

    Private Sub ShowObject() Implements IOleClientSite.ShowObject
    End Sub

#End Region

    Private Const DISPID_AMBIENT_DLCONTROL As Integer = -5512

    <DispIdAttribute(DISPID_AMBIENT_DLCONTROL)> _
    Public Function DispidAmbientDlcontrol() As Integer

        Return DLCTL_DLIMAGES Or DLCTL_VIDEOS Or DLCTL_BGSOUNDS Or DLCTL_NO_RUNACTIVEXCTLS

    End Function

    Private Sub OnAmbientPropertyChanged()

        DirectCast(m_AxWebBrowser.Application, IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL)

    End Sub

End Class
 _
Class Browser

    Inherits System.Windows.Forms.Control

    Implements IOleClientSite

    Private m_AxWebBrowser As AxWebBrowser

    Public Sub New()

        MyBase.New()

        m_AxWebBrowser = New AxWebBrowser

        DirectCast(m_AxWebBrowser.GetOcx(), IOleObject).SetClientSite(Me)

    End Sub

#Region "IOleClientSite"

    Private Sub GetContainer(ByRef ppContainer As Object) Implements IOleClientSite.GetContainer

        ppContainer = Me

    End Sub

    Private Sub GetMoniker(ByVal dwAssign As Integer, ByVal dwWhichMoniker As Integer, ByRef ppmk As Object) Implements IOleClientSite.GetMoniker
    End Sub

    Private Sub OnShowWindow(ByVal fShow As Boolean) Implements IOleClientSite.OnShowWindow
    End Sub

    Private Sub RequestNewObjectLayout() Implements IOleClientSite.RequestNewObjectLayout
    End Sub

    Private Sub SaveObject() Implements IOleClientSite.SaveObject
    End Sub

    Private Sub ShowObject() Implements IOleClientSite.ShowObject
    End Sub

#End Region

    Private Const DISPID_AMBIENT_DLCONTROL As Integer = -5512

     _
    Public Function DispidAmbientDlcontrol() As Integer

        Return DLCTL_DLIMAGES Or DLCTL_VIDEOS Or DLCTL_BGSOUNDS Or DLCTL_NO_RUNACTIVEXCTLS

    End Function

    Private Sub OnAmbientPropertyChanged()

        DirectCast(m_AxWebBrowser.Application, IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL)

    End Sub

End Class]]>

なお、アンビエントプロパティはナビゲーションの度にデフォルト値に戻されるので、BeforeNavigate2でOnAmbientPropertyChangedを呼ぶようにします。

⇑

User-Agentを変更する

UrlMkSetSessionOptionを使うことでリクエスト時に送信されるUser-Agentヘッダの値を変えることが可能になります。　設定ではなく取得する場合はUrlMkGetSessionOptionを使います。　この関数で設定したUser-Agentは現在のプロセス全体に対して有効になります。

<DllImport("urlmon.dll", CharSet:=CharSet.Ansi)> _
Private Shared Function UrlMkSetSessionOption(ByVal dwOption As Integer, ByVal pBuffer As String, _
ByVal dwBufferLength As Integer, ByVal dwReserved As Integer) As Integer
End Function

<DllImport("urlmon.dll", CharSet:=CharSet.Ansi)> _
Private Shared Function UrlMkGetSessionOption(ByVal dwOption As Integer, ByVal pBuffer As StringBuilder, ByVal dwBufferLength As Integer, _
ByRef pdwBufferLength As Integer, ByVal dwReserved As Integer) As Integer
End Function

Private Const URLMON_OPTION_USERAGENT As Integer = &H10000001

Private Sub SetUserAgent()

  Dim newUserAgent As String = "TestUserAgent"

  result = UrlMkSetSessionOption(URLMON_OPTION_USERAGENT, newUserAgent, newUserAgent.Length, 0)

  If result <> 0 Then

    Debug.WriteLine(String.Format("User-Agentの設定に失敗しました。　エラーコード: {0:X8}", result))

  End If

End Sub
 _
Private Shared Function UrlMkSetSessionOption(ByVal dwOption As Integer, ByVal pBuffer As String, _
ByVal dwBufferLength As Integer, ByVal dwReserved As Integer) As Integer
End Function

 _
Private Shared Function UrlMkGetSessionOption(ByVal dwOption As Integer, ByVal pBuffer As StringBuilder, ByVal dwBufferLength As Integer, _
ByRef pdwBufferLength As Integer, ByVal dwReserved As Integer) As Integer
End Function

Private Const URLMON_OPTION_USERAGENT As Integer = &H10000001

Private Sub SetUserAgent()

  Dim newUserAgent As String = "TestUserAgent"

  result = UrlMkSetSessionOption(URLMON_OPTION_USERAGENT, newUserAgent, newUserAgent.Length, 0)

  If result <> 0 Then

    Debug.WriteLine(String.Format("User-Agentの設定に失敗しました。　エラーコード: {0:X8}", result))

  End If

End Sub]]>
⇑

Feed Auto-Discovery

IHTMLDocument2を使ったHTML文書のスキャンのサンプルとして、WebBrowserコントロールで読み込んだHTML文書からフィードのURLを探し出す方法を取り上げます。　このメソッドでは、WebBrowserのDocumentを受け取った上で、

  1. HTML文書中の全ての要素からHTMLLinkElementClassを探す
  2. その中で、ref属性が「alternate」、type属性が次に示すもののいずれかのものを探す
  3. type属性が「application/rss+xml」、「application/rdf+xml」、「application/atom+xml」のいずれかなら無条件でRSSへのリンクと見なす
  4. type属性が「application/xml」の場合は、さらにtitle属性が「RSS」の場合に限ってRSSへのリンクと見なす
  5. RSSへのリンクと見なされたタグのhref属性からRSSのURLを取得する
  6. URLが相対アドレスなら絶対アドレスに直す

と言うことを行っています。　不完全ではありますが、ある程度のサイトでフィードのURLを取得できると思います。

Private Function DiscoverSummaryFeedUrl(ByVal htmlDocument As mshtml.IHTMLDocument2) As String()

    Dim rssUrls As New ArrayList
    Dim allElements As mshtml.IHTMLElementCollection = htmlDocument.all

    For Each element As Object In allElements

        If TypeOf element Is mshtml.HTMLLinkElementClass Then

            Dim isRssLink As Boolean = False
            Dim link As mshtml.HTMLLinkElementClass = DirectCast(element, mshtml.HTMLLinkElementClass)

            If "alternate".Equals(link.rel) Then

                Select Case link.type

                    Case "application/rss+xml"
                        isRssLink = True ' RSS 0.9x, 2.0

                    Case "application/rdf+xml"
                        isRssLink = True ' RSS 1.0

                    Case "application/atom+xml"
                        isRssLink = True ' Atom

                    Case "application/xml"

                        ' RSS? Atom?
                        isRssLink = "rss".Equals(link.title.ToLower())

                    Case Else
                        isRssLink = False

                End Select

            End If

            If isRssLink Then

                Dim rssUrl As String = link.href

                If rssUrl.IndexOf(Uri.SchemeDelimiter) < 0 Then

                    ' 「://」が含まれていない場合、相対アドレスで指定されていると見なす
                    Dim uriBuilder As New uriBuilder
                    Dim location As mshtml.HTMLLocation = htmlDocument.location

                    uriBuilder.Host = location.host
                    uriBuilder.Path = location.pathname
                    uriBuilder.Scheme = location.protocol

                    rssUrl = (New Uri(uriBuilder.Uri, link.href)).ToString()

                End If

                ' RSSのURLとして追加
                rssUrls.Add(rssUrl)

            End If

        End If

    Next

    Return DirectCast(rssUrls.ToArray(GetType(String)), String())

End Function

Sponsored Link
⇑