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

Public Class Form1

    Private Label1 As New Label With {.Text = "戻る", .AutoSize = True, .Location = New Point(5, 2)}
    Private Label2 As New Label With {.Text = "進む", .AutoSize = True, .Location = New Point(5, 215)}
    Private ListBox1 As New ListBox With {.Location = New Point(0, 15), .Size = New Size(200, 200)}
    Private ListBox2 As New ListBox With {.Location = New Point(0, 230), .Size = New Size(200, 200)}
    Private Splitcontainer1 As New SplitContainer With {.FixedPanel = FixedPanel.Panel1, .Dock = DockStyle.Fill}
    Private WithEvents WebBrowser1 As New ExWebBrowser With {.Dock = DockStyle.Fill}

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        'WebBrowser1
        BrowserEmulation.CreateRenderingModeRegkey(BrowserEmulation.Emulation.IE11Edge)
        'Splitcontainer1
        Me.Splitcontainer1.Panel1.Controls.AddRange({Me.Label1, Me.ListBox1, Me.Label2, Me.ListBox2})
        Me.Splitcontainer1.Panel2.Controls.Add(Me.WebBrowser1)
        'Form1
        Me.Text = "WebBrowserTravelLog"
        Me.Size = New Size(800, 600)
        Me.Controls.Add(Me.Splitcontainer1)
        '
        Me.Splitcontainer1.SplitterDistance = 200
        Me.WebBrowser1.GoHome()
    End Sub

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

    Private Sub WebBrowser1_Navigated(ByVal sender As Object, ByVal e As System.Windows.Forms.WebBrowserNavigatedEventArgs) Handles WebBrowser1.Navigated
        '履歴の表示
        Dim History(10) As TravelLogEntry 'COMオブジェクトではない
        Me.ListBox1.Items.Clear()
        History = Me.WebBrowser1.History.EnumEntries(ITravelLogStg.TLENUMF.TLEF_RELATIVE_BACK, 10)
        For I As Integer = 0 To Me.WebBrowser1.History.GetCount(ITravelLogStg.TLENUMF.TLEF_RELATIVE_BACK) - 1
            ListBox1.Items.Add(History(I))
        Next
        Me.ListBox2.Items.Clear()
        History = Me.WebBrowser1.History.EnumEntries(ITravelLogStg.TLENUMF.TLEF_RELATIVE_FORE, 10)
        For I As Integer = 0 To Me.WebBrowser1.History.GetCount(ITravelLogStg.TLENUMF.TLEF_RELATIVE_FORE) - 1
            ListBox2.Items.Add(History(I))
        Next
    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

    Private _History As ExHtmlHistory = Nothing

    ReadOnly Property History() As ExHtmlHistory
        Get
            Return _History
        End Get
    End Property

    Protected Overrides Sub OnNavigated(ByVal e As System.Windows.Forms.WebBrowserNavigatedEventArgs)
        '履歴クラスのインスタンスを生成
        If _History Is Nothing Then
            _History = New ExHtmlHistory(Me)
        End If
        MyBase.OnNavigated(e)
    End Sub

End Class


Public Class ExHtmlHistory
    Implements IDisposable

    Private Const S_OK As Integer = &H0
    Private Const S_FALSE As Integer = &H1
    Private TravelLog As ITravelLogStg

    Sub New(ByVal WebBrowser As WebBrowser)
        If WebBrowser Is Nothing Then Throw New NullReferenceException
        Dim pISP As IServiceProvider = Nothing
        Dim ppvObject As Object = Nothing
        Dim SID_STravelLogCursor As Guid = New Guid("7EBFDD80-AD18-11d3-A4C5-00C04F72D6B8")
        Dim IID_ITravelLogStg As Guid = New Guid("7EBFDD80-AD18-11d3-A4C5-00C04F72D6B8")
        pISP = DirectCast(WebBrowser.ActiveXInstance, IServiceProvider)
        pISP.QueryService(SID_STravelLogCursor, IID_ITravelLogStg, ppvObject)
        TravelLog = DirectCast(ppvObject, ITravelLogStg)
    End Sub

    Public Function EnumEntries(ByVal Flags As ITravelLogStg.TLENUMF, ByVal maxEntries As Integer) As TravelLogEntry()
        Dim History As New Generic.List(Of TravelLogEntry)
        Dim TLEnum As IEnumTravelLogEntry = Nothing
        If TravelLog.EnumEntries(Flags, TLEnum) = S_FALSE Then Return Nothing
        Do While maxEntries > History.Count
            Dim TLEntry As ITravelLogEntry = Nothing
            If TLEnum.Next(1, TLEntry, Nothing) = S_FALSE Then Exit Do
            History.Add(New TravelLogEntry(TLEntry))
            Marshal.ReleaseComObject(TLEntry)
        Loop
        Marshal.ReleaseComObject(TLEnum)
        Return History.ToArray()
    End Function

    Public Sub TravelTo(ByVal Offset As Integer)
        Dim TLEntry As ITravelLogEntry = Nothing
        TravelLog.GetRelativeEntry(Offset, TLEntry)
        TravelLog.TravelTo(TLEntry)
        Marshal.ReleaseComObject(TLEntry)
    End Sub

    Public Function InsertEntry(ByVal Url As String, ByVal Title As String, ByVal TravelLogEntry As ITravelLogEntry, ByVal Prepend As Boolean) As ITravelLogEntry
        Dim TLEntry As ITravelLogEntry = Nothing
        TravelLog.CreateEntry(Url, Title, TravelLogEntry, Prepend, TLEntry)
        Return TLEntry
    End Function

    Public Function GetCount(ByVal Flags As ITravelLogStg.TLENUMF) As Integer
        Dim Entries As Integer = 0
        TravelLog.GetCount(Flags, Entries)
        Return Entries
    End Function

    Public Function GetRelativeEntry(ByVal Offset As Integer) As ITravelLogEntry
        Dim TLEntry As ITravelLogEntry = Nothing
        TravelLog.GetRelativeEntry(Offset, TLEntry)
        Return TLEntry
    End Function

    Public Sub RemoveEntry(ByVal TravelLogEntry As ITravelLogEntry)
        TravelLog.RemoveEntry(TravelLogEntry)
    End Sub

    ' IDisposable
    Private disposedValue As Boolean = False

    Protected Overridable Sub Dispose(ByVal disposing As Boolean)
        If Not Me.disposedValue Then
            If Me.TravelLog IsNot Nothing Then
                Marshal.ReleaseComObject(Me.TravelLog)
            End If
        End If
        Me.disposedValue = True
    End Sub

    Public Sub Dispose() Implements IDisposable.Dispose
        Dispose(True)
        GC.SuppressFinalize(Me)
    End Sub

End Class

Public Class TravelLogEntry 'COMオブジェクトは保存しない

    Const S_OK As Integer = &H0

    Private _Title As String
    Private _Url As String

    Public Sub New(ByVal TravelLogEntry As ITravelLogEntry)
        Dim TitlePtr As IntPtr = IntPtr.Zero
        Dim UrlPtr As IntPtr = IntPtr.Zero
        If TravelLogEntry.GetTitle(TitlePtr) = S_OK Then
            _Title = Marshal.PtrToStringUni(TitlePtr)
        End If
        If TravelLogEntry.GetURL(UrlPtr) = S_OK Then
            _Url = Marshal.PtrToStringUni(UrlPtr)
        End If
    End Sub

    Public Property Title() As String
        Get
            Return _Title
        End Get
        Set(ByVal value As String)
            _Title = value
        End Set
    End Property


    Public Property Url() As String
        Get
            Return _Url
        End Get
        Set(ByVal value As String)
            _Url = value
        End Set
    End Property

    Overrides Function ToString() As String
        Return String.Format("{0}({1})", _Title, _Url)
    End Function

End Class

'IServiceProviderインターフェイス
'http://msdn.microsoft.com/workshop/components/com/reference/ifaces/iserviceprovider/iserviceprovider.asp
<ComImport(),
Guid("6d5140c1-7436-11ce-8034-00aa006009fa"),
InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
Public Interface IServiceProvider

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

End Interface

'IEnumTravelLogEntryインターフェイス
'このインターフェイスはtravel logの列挙を実行するのに必要なメソッドを提供する。
'http://msdn.microsoft.com/workshop/browser/travellog/reference/ifaces/ienumtravellogentry/ienumtravellogentry.asp
<ComImport(),
Guid("7EBFDD85-AD18-11d3-A4C5-00C04F72D6B8"),
InterfaceType(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

'ITravelLogEntryインターフェイス
'このインターフェイスはtravel logのエントリのタイトルとURLを検索するメソッドを提供する。
'http://msdn.microsoft.com/workshop/browser/travellog/reference/ifaces/itravellogentry/itravellogentry.asp
<ComImport(),
Guid("7EBFDD87-AD18-11d3-A4C5-00C04F72D6B8"),
InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
Public Interface ITravelLogEntry

    <PreserveSig()> Function GetTitle(<Out()> ByRef ppszTitle As IntPtr) As Integer
    <PreserveSig()> Function GetURL(<Out()> ByRef ppszUrl As IntPtr) As Integer

End Interface

'ITravelLogStgインターフェイス
'このインターフェイスはtravel logのエントリを作り，列挙し，削除するメソッドを提供する。
'http://msdn.microsoft.com/workshop/browser/travellog/reference/ifaces/itravellogstg/itravellogstg.asp
<ComImport(),
ComVisible(False),
Guid("7EBFDD80-AD18-11d3-A4C5-00C04F72D6B8"),
InterfaceType(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,
        <Out(), MarshalAs(UnmanagedType.Interface)> 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,
        <Out(), MarshalAs(UnmanagedType.Interface)> ByRef ppenum As IEnumTravelLogEntry
    ) As Integer

    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

    Function GetCount(
        <[In](), MarshalAs(UnmanagedType.U4)> ByVal flags As TLENUMF,
        <Out(), MarshalAs(UnmanagedType.U4)> 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,
        <Out(), MarshalAs(UnmanagedType.Interface)> ByRef ptle As ITravelLogEntry
    ) As Integer

End Interface