VB.NET Tips - YAS's VB.NET Tips

VB.NET Tips

2020/05/22	MeCabの辞書をコマンドラインド指定する	\| by:YAS

　MeCabをインストールしないで，VBからMeCabを使うために，辞書を起動オプションで指定する。MeCabをインストールしたフォルダから，実行ファイルのフォルダに辞書をコピーして使う場合は，

mecab_new2(" --rcfile=.\dic\ipadic\dicrc --dicdir=.\dic\ipadic")

もしくは，

mecab_new2(" -r .\dic\ipadic\dicrc -d .\dic\ipadic")

のようにオプションを指定する。（一文字目は半角空白）

参考Webページ MeCabで辞書の読込先を変える方法
　　　　　　　 http://awakia-n.hatenablog.com/entry/20080212/1202811277
　　　　　　　コマンドラインオプション
　　　　　　　 https://taku910.github.io/mecab/mecab.html

Imports System.Runtime.InteropServices

Public Class Form1

    Dim TextBox1 As New TextBox

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Me.TextBox1.Multiline = True
        Me.TextBox1.ScrollBars = ScrollBars.Vertical
        Me.TextBox1.Dock = DockStyle.Fill
        Me.Controls.Add(Me.TextBox1)
        Using Mecab As New MeCab("  --rcfile=.\dic\ipadic\dicrc --dicdir=.\dic\ipadic")
            Me.TextBox1.Text = Mecab.Parse("和布蕪を使って日本語文字列を形態素分析する。").Replace(vbLf, vbCrLf)
        End Using
    End Sub

End Class

Class MeCab
    Implements IDisposable

    <DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)>
    Public Shared Function mecab_new2(ByVal arg As String) As IntPtr
    End Function

    <DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)>
    Public Shared Function mecab_sparse_tostr(ByVal m As IntPtr, ByVal str As String) As IntPtr
    End Function

    <DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)>
    Public Shared Sub mecab_destroy(ByVal m As IntPtr)
    End Sub

    Private ptrMeCab As IntPtr

    Sub New()
        Me.New(String.Empty)
    End Sub

    Sub New(ByVal Arg As String)
        ptrMeCab = mecab_new2(Arg)
    End Sub

    Public Function Parse(ByVal [String] As String) As String
        Dim ptrResult As IntPtr = mecab_sparse_tostr(ptrMeCab, [String])
        Dim strResult As String = Marshal.PtrToStringAnsi(ptrResult)
        Return strResult
    End Function

    Public Overloads Sub Dispose() Implements IDisposable.Dispose
        mecab_destroy(ptrMeCab)
        GC.SuppressFinalize(Me)
    End Sub

    Protected Overrides Sub Finalize()
        Dispose()
    End Sub

End Class

MeCabで辞書の読込先を変える方法

20:18 | コメント(0)

2018/09/08	ぷりんときっずダウンローダーVer.2.0	\| by:YAS

　前回，プリントキッズの１ページ分のプリントをまとめてダウンロードするコードを考えた。今回は，カテゴリを指定して，カテゴリ内のすべてのプリントをダウンロードするコードを考える。

　最上位のカテゴリは左図のメニューとする。このメニューは下のようはHTMLになっている。id="picture"の要素を検索し，その中のa要素を検索すればカテゴリ一覧のリンクを取得できそうだ。

　上のカテゴリを選択すると，左図のような下位カテゴリが表示される。class="text-anime"のaside要素を検索し，その中のa要素を検索すれば下位カテゴリ一覧のリンクを取得できそうだ。

　左図が完成したものです。表示しているページのカテゴリ一覧からダウンロードするカテゴリページを選択し，再帰的に検索してPDFファイルをダウンロードします。

（プリントキッズのアイコンはfaviconを起動時にダウンロードして表示しています。）

バイナリのダウンロードページ

　Ver.1.0をもとに，機能追加，バグ修正，リファクタリングを行ったのが，下のコードです。Dialogを追加し，Form1とDialog1に下のコードをコピーすれば動作します。
【Form1】

【Dialog1】

21:56 | コメント(0)

2018/09/04	ぷりんときっずダウンローダーVer.1.0	\| by:YAS

　ぷりんときっずの無料プリントをよく利用させていただいている。フォントが丸文字のプリントもあったりするが，わざわざ教科書体で作り直してくださったものもあり，ありがたく活用させていただいている。
　まとめてダウンロードしたいプリントも多いのだが，一括ダウンロードはできないようなので，専用のダウンローダーを作成してみる。
　あまり負荷をかけるのもよくないとは思うが，かなり高速なレスポンスのサーバーのようなので，個人的にダウンローダーを作成して使う分には問題なさそうだと思っている。
　まずは，１ページにまとめられているPDFのプリントをすべてダウンロードしてみる。

　chromeでPDFのリンクを右クリック→検証で，デベロッパーツールでHTMLを確認すると，PDFのダウンロードページのPDFへのリンク部分は左のようになっている。
　PDFファイルへのリンクは，id="topic"のdiv要素を検索し，その中のa要素を検索して取得することにする。

※id="easy"のdiv要素内に「簡単」レベルのプリントが，id="normal"のdiv要素内に「普通」レベルのプリントが，id="hard"のdiv要素内に「難しい」レベルのプリントが格納されている。

　１つ１つのPDFファイルへのリンクは下のようなHTMLになっている。ファイル名からプリントを探しやすくするために，a要素内のp要素のInnerTextをファイル名として保存する。

　プリントの分類をわかりやすくするために，ダウンロードしたPDFフィアルを格納するフォルダは，下のパンくずリストをフォルダ名にする。

　パンくずリストは，id="pan-nav"のdiv要素を取得し，その中のspan要素のInnerTextから取得する。

　下のコードをフォームのコードにコピー・貼り付けをすれば動作します。

Option Explicit On
Option Strict On

Imports System.IO
Imports Microsoft.Win32

Public Class Form1

    Private ToolStrip As New ToolStrip
    Private WithEvents tsbDownload As New ToolStripButton With {.Text = "ダウンロード"}
    Private StatusStrip As New StatusStrip
    Private WithEvents tspProgress As New ToolStripProgressBar
    Private tslStatus As New ToolStripLabel
    Private WithEvents WebBrowser As New WebBrowser With {.Dock = DockStyle.Fill}
    Private baseUrl As New Uri("https://print-kids.net/")

    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        Me.Text = "ぷりんときっずダウンローダー"
        Me.Size = New Size(1024, 678)
        BrowserEmulation.CreateRenderingModeRegkey(BrowserEmulation.Emulation.IE11Edge)
        Me.WebBrowser.ScriptErrorsSuppressed = True
        Me.ToolStrip.Items.Add(tsbDownload)
        Me.StatusStrip.Items.AddRange({tspProgress, tslStatus})
        Me.Controls.AddRange({Me.ToolStrip, Me.WebBrowser, Me.StatusStrip})
        Me.WebBrowser.Navigate(baseUrl)
    End Sub

    Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) Handles Me.FormClosing
        BrowserEmulation.DeleteRenderingModeRegkey()
    End Sub

    Private Sub tsbDownload_Click(sender As Object, e As EventArgs) Handles tsbDownload.Click
        downloadPdfs(Me.WebBrowser.Url)
    End Sub

    Private Sub downloadPdfs(url As Uri)
        Dim tempWebBrowser As New WebBrowser
        tempWebBrowser.ScriptErrorsSuppressed = True
        AddHandler tempWebBrowser.DocumentCompleted, AddressOf WebBrowser_DocumentCompleted
        tempWebBrowser.Navigate(url)
    End Sub

    Private Sub WebBrowser_DocumentCompleted(sender As Object, e As WebBrowserDocumentCompletedEventArgs)
        Dim Browser As WebBrowser = DirectCast(sender, WebBrowser)
        If e.Url.Equals(Browser.Url) Then
            'PDFファイルのリンクを取得
            Dim pdfLinks = Browser.Document.GetElementById("topic").GetElementsByTagName("a").Cast(Of HtmlElement) _
                .Select(Function(anchorTag) New With {.AnchorElement = anchorTag, .Uri = New Uri(anchorTag.GetAttribute("href"))}) _
                .Where(Function(anchorTag) baseUrl.IsBaseOf(anchorTag.Uri) AndAlso Path.GetExtension(anchorTag.Uri.AbsoluteUri).ToLower = ".pdf") _
                .Select(Function(anchorTag) New With {anchorTag.Uri, .Text = anchorTag.AnchorElement.GetElementsByTagName("p")(0).InnerText})
            'パンなびリストを取得
            Dim downloadDir = Browser.Document.GetElementById("pan-nav").GetElementsByTagName("span").Cast(Of HtmlElement) _
                .Select(Function(spanTag) spanTag.InnerText) _
                .Aggregate(String.Empty, Function(result As String, title As String) Path.Combine(result, title))
            'ダウンロード先フォルダ作成
            downloadDir = Path.Combine(My.Computer.FileSystem.SpecialDirectories.Desktop, downloadDir)
            If Not Directory.Exists(downloadDir) Then
                My.Computer.FileSystem.CreateDirectory(Path.Combine(downloadDir))
            End If
            'PDFファイルをダウンロード
            Dim Progress As Integer = 0
            Me.tspProgress.Maximum = pdfLinks.Count
            Me.tspProgress.Value = Progress
            Me.tslStatus.Text = ""
            Me.StatusStrip.Refresh()
            For Each pdfLink In pdfLinks
                Dim DownloadFileName As String = Path.Combine(downloadDir, pdfLink.Text.Replace(" ", "") & ".pdf")
                Dim DownloadUrl As String = Path.GetFileName(pdfLink.Uri.AbsoluteUri)
                Dim Status As String = " スキップ"
                If Not File.Exists(DownloadFileName) Then
                    My.Computer.Network.DownloadFile(pdfLink.Uri, DownloadFileName)
                    Status = " ダウンロード中..."
                End If
                Me.tspProgress.Value = Progress
                Me.tslStatus.Text = Progress + 1 & "/" & Me.tspProgress.Maximum & " " & DownloadUrl & Status
                Me.StatusStrip.Refresh()
                Progress += 1
            Next
            Me.tspProgress.Value = Me.tspProgress.Maximum
            Me.tslStatus.Text = "ダウンロード完了"
            Me.StatusStrip.Refresh()
            Browser.Dispose()
        End If
    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

22:23 | コメント(0)

2018/06/29	MeCabを使ってWebBrowserにルビをふる	\| by:YAS

　日本語形態素分析エンジンMeCabを使って，WebBrowserの表示にルビを振ります。
　クロスドメインのiframe以外は，iframeの中も再帰的にテキストノードを検索してMeCabで分析し，ルビエレメントノードに置き換えます。（クロスドメインのiframeにアクセスしようとした際の例外（UnauthorizedAccessException）は握りつぶしています。）
　マネージコードだけでは，テキストノードを取得できないので，mshtmlを参照設定して使用しています。COMオブジェクトの開放はやっているつもりですが，完全ではないかもしれません。

まず，Microsoft HTML Object Libraryを参照設定してください。
次に，下のコードをフォームのコードにコピー・貼り付けをすれば動作します。

Option Explicit On
Option Strict On

Imports System.IO
Imports System.Runtime.InteropServices
Imports System.Text.RegularExpressions
Imports Microsoft.Win32
Imports mshtml

Public Class Form1

    Private WithEvents WebBrowser As New WebBrowser With {.Dock = DockStyle.Fill}
    Private MeCab As New MeCab("--node-format=[#%M:%f[7]:%f[0]#] --unk-format=%M --eos-format=\0")

    Public Enum NODETYPE As UShort
        ELEMENT_NODE = 1
        TEXT_NODE = 3
        PROCESSING_INSTRUCTION_NODE = 7
        COMMENT_NODE = 8
        DOCUMENT_NODE = 9
        DOCUMENT_TYPE_NODE = 10
        DOCUMENT_FRAGMENT_NODE = 11
    End Enum

    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        BrowserEmulation.CreateRenderingModeRegkey(BrowserEmulation.Emulation.IE11Edge)
        Me.WebBrowser.ScriptErrorsSuppressed = True
        Me.Controls.Add(Me.WebBrowser)
        Me.WebBrowser.GoHome()
    End Sub

    Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) Handles Me.FormClosing
        BrowserEmulation.DeleteRenderingModeRegkey()
        MeCab.Dispose()
    End Sub

    Private Sub WebBrowser_DocumentCompleted(sender As Object, e As WebBrowserDocumentCompletedEventArgs) Handles WebBrowser.DocumentCompleted
        Dim domElement As IHTMLDOMNode = DirectCast(Me.WebBrowser.Document.Body.DomElement, IHTMLDOMNode)
        AttachRuby(domElement)
        Marshal.FinalReleaseComObject(domElement)
    End Sub

    'テキストノードを検索してMeCabで処理する
    Private Sub AttachRuby(ByVal node As IHTMLDOMNode)
        Select Case node.nodeName.ToLower
            Case "ruby", "select"
                Return
        End Select
        Dim document As IHTMLDocument2 = Nothing
        Dim childNodes As IHTMLDOMChildrenCollection = Nothing
        Try
            document = DirectCast(DirectCast(node, IHTMLDOMNode2).ownerDocument, IHTMLDocument2)
            childNodes = DirectCast(node.childNodes, IHTMLDOMChildrenCollection)
            For Each childNode As IHTMLDOMNode In childNodes
                Try
                    If childNode.nodeType = NODETYPE.TEXT_NODE Then
                        Dim childNodeValue As String = DirectCast(childNode.nodeValue, String)
                        If Regex.IsMatch(childNodeValue, "[\u4E00-\u9FFF\u3040-\u309F\u30A0-\u30FA]") Then
                            'MeCabでテキストノードを解析する
                            Dim result As String = MeCab.Parse(childNodeValue)
                            '解析結果をルビタグに置き換える
                            result = Regex.Replace(result, "\[#(.+?):(.+?):(.+?)\#]", New MatchEvaluator(AddressOf RegexMatchEvaluator))
                            'テキストノードをルビエレメントノードに置き換える
                            Dim newElement As IHTMLElement = Nothing
                            Try
                                newElement = document.createElement(String.Empty)
                                newElement.innerHTML = result
                                childNode.replaceNode(DirectCast(newElement, IHTMLDOMNode))
                            Finally
                                If newElement IsNot Nothing Then
                                    Marshal.ReleaseComObject(newElement)
                                End If
                            End Try
                        End If
                    Else
                        If childNode.nodeName.ToLower = "frame" Or childNode.nodeName.ToLower = "iframe" Then
                            Dim frame As IHTMLWindow2 = Nothing
                            Dim frameDocument As IHTMLDocument2 = Nothing
                            Dim frameBody As IHTMLElement = Nothing
                            Try
                                frame = DirectCast(childNode, IHTMLFrameBase2).contentWindow
                                frameDocument = frame.document
                                frameBody = frameDocument.body
                                AttachRuby(DirectCast(frameBody, IHTMLDOMNode)) 'フレーム内を再帰的に処理
                            Catch ex As UnauthorizedAccessException
                            Finally
                                If frameBody IsNot Nothing Then
                                    Marshal.ReleaseComObject(frameBody)
                                End If
                                If frameDocument IsNot Nothing Then
                                    Marshal.ReleaseComObject(frameDocument)
                                End If
                                If frame IsNot Nothing Then
                                    Marshal.ReleaseComObject(frame)
                                End If
                            End Try
                        Else
                            If childNode.hasChildNodes Then
                                AttachRuby(childNode) '子エレメントを再帰的に処理
                            End If
                        End If
                    End If
                Finally
                    If childNode IsNot Nothing Then
                        Marshal.ReleaseComObject(childNode)
                    End If
                End Try
            Next
        Finally
            If childNodes IsNot Nothing Then
                Marshal.ReleaseComObject(childNodes)
            End If
            If document IsNot Nothing Then
                Marshal.ReleaseComObject(document)
            End If
        End Try
    End Sub

    Private Function RegexMatchEvaluator(ByVal M As Match) As String
        Dim kanji As String = M.Groups(1).Value '漢字
        Dim kana As String = StrConv(M.Groups(2).Value, VbStrConv.Hiragana) 'かな
        Dim result As String = kanji
        If Regex.IsMatch(kanji, "\p{IsCJKUnifiedIdeographs}") Then
            result = "<ruby>" & kanji & "<rt>" & kana & "</rt></ruby>"
        End If
        Return result
    End Function

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 MeCab
    Implements IDisposable

    <DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)>
    Public Shared Function mecab_new2(ByVal arg As String) As IntPtr
    End Function

    <DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)>
    Public Shared Function mecab_sparse_tostr(ByVal m As IntPtr, ByVal str As String) As IntPtr
    End Function

    <DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)>
    Public Shared Sub mecab_destroy(ByVal m As IntPtr)
    End Sub

    Private ptrMeCab As IntPtr

    Sub New()
        Me.New(String.Empty)
    End Sub

    Sub New(ByVal Arg As String)
        ptrMeCab = mecab_new2(Arg)
    End Sub

    Public Function Parse(ByVal [String] As String) As String
        Dim ptrResult As IntPtr = mecab_sparse_tostr(ptrMeCab, [String])
        Dim strResult As String = Marshal.PtrToStringAnsi(ptrResult)
        Return strResult
    End Function

    Public Overloads Sub Dispose() Implements IDisposable.Dispose
        mecab_destroy(ptrMeCab)
        GC.SuppressFinalize(Me)
    End Sub

    Protected Overrides Sub Finalize()
        Dispose()
    End Sub

End Class

22:20 | コメント(0)

2018/06/28	日本語形態素分析エンジンMeCabをVBより利用する	\| by:YAS

　MeCab0.996にはCより利用可能なdllがバイナリで付属しています。これをDllImportで宣言し，VBから利用します。
　以下のサンプルは文字列をMeCabで形態素分析し，結果をTextBoxに表示します。なお，サンプルを実行するには，Mecab0.996をあらかじめデフォルトのフォルダにインストールし，libmecab.dllをバイナリと同じフォルダにコピーしておく必要であります。　IFELanguageのGetJMorphResultよりも利用が簡単で，私が考えたコードで安定して動作しています。

　下のコードをフォームのコードにコピー・貼り付けをすれば動作します。

Imports System.Runtime.InteropServices

Public Class Form1

    Dim TextBox1 As New TextBox

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Me.TextBox1.Multiline = True
        Me.TextBox1.ScrollBars = ScrollBars.Vertical
        Me.TextBox1.Dock = DockStyle.Fill
        Me.Controls.Add(Me.TextBox1)
        Using Mecab1 As New MeCab
            Me.TextBox1.Text = Mecab1.Parse("和布蕪を使って日本語文字列を形態素分析する。").Replace(vbLf, vbCrLf)
        End Using
    End Sub

End Class

Class MeCab
    Implements IDisposable

    <DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)>
    Public Shared Function mecab_new2(ByVal arg As String) As IntPtr
    End Function

    <DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)>
    Public Shared Function mecab_sparse_tostr(ByVal m As IntPtr, ByVal str As String) As IntPtr
    End Function

    <DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)>
    Public Shared Sub mecab_destroy(ByVal m As IntPtr)
    End Sub

    Private ptrMeCab As IntPtr

    Sub New()
        Me.New(String.Empty)
    End Sub

    Sub New(ByVal Arg As String)
        ptrMeCab = mecab_new2(Arg)
    End Sub

    Public Function Parse(ByVal [String] As String) As String
        Dim ptrResult As IntPtr = mecab_sparse_tostr(ptrMeCab, [String])
        Dim strResult As String = Marshal.PtrToStringAnsi(ptrResult)
        Return strResult
    End Function

    Public Overloads Sub Dispose() Implements IDisposable.Dispose
        mecab_destroy(ptrMeCab)
        GC.SuppressFinalize(Me)
    End Sub

    Protected Overrides Sub Finalize()
        Dispose()
    End Sub

End Class

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

20:33 | コメント(0)

2018/06/24	MS-IMEでモノルビを取得する	\| by:YAS

　MS-IMEでモノルビを取得します。Text Services Framework(TSF)を利用して，文全体の読み仮名や，一つ一つの文字に対しての読み仮名を取得することができます。

※下のコードは今ひとつ不安定です。APIの定義が間違っているのかもしれません。

下のコードをフォームのコードにコピー・貼り付けをすれば動作します。

Option Explicit On
Option Strict On

Imports System.Runtime.InteropServices

Public Class Form1

    Private WithEvents TextBox1 As New TextBox With {.Multiline = True, .Dock = DockStyle.Fill}
    Private MsIme As Type = Type.GetTypeFromProgID("MSIME.Japan")
    Private Language As IFELanguage = DirectCast(Activator.CreateInstance(MsIme), IFELanguage)

    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        Me.Controls.Add(TextBox1)
        Language.Open()
        Dim KanjiText As String = "天気予報によると，明日は晴れになるでしょう。"
        Dim List As List(Of kanjiRuby) = getMonoRuby(KanjiText)
        For Each l In List
            Me.TextBox1.Text &= l.kanji & "(" & l.ruby & ")" & vbCrLf
        Next
        Language.Close()
        Marshal.FinalReleaseComObject(Language)
    End Sub

    Public Function getMonoRuby(kanjiSentence As String) As List(Of kanjiRuby)
        Dim resultPtr As IntPtr
        Dim hr As Integer = Language.GetJMorphResult(FELANG_REQ.REV, FELANG_CMODE.MONORUBY, kanjiSentence.Length, kanjiSentence, 0, resultPtr)
        Dim result As MORRSLT = DirectCast(Marshal.PtrToStructure(resultPtr, GetType(MORRSLT)), MORRSLT)
        'MonoRubyPosをリストにコピーする
        Dim length As Integer = kanjiSentence.Length
        Dim kanjiRubyPosList = {New With {.kanji = "", .rubyPos = 0}}.ToList
        kanjiRubyPosList.Clear()
        For i As Integer = 0 To length
            Dim kanji As String = If(i < length, kanjiSentence.Substring(i, 1), "")
            Dim rubyPos As Integer = CInt(Marshal.ReadInt16(result.paMonoRubyPos, i * 2))
            kanjiRubyPosList.Add(New With {kanji, rubyPos})
        Next
        '熟字訓をまとめる
        For i As Integer = length To 0 Step -1
            If kanjiRubyPosList(i).rubyPos = -1 Then
                kanjiRubyPosList(i - 1).kanji &= kanjiRubyPosList(i).kanji
                kanjiRubyPosList.Remove(kanjiRubyPosList(i))
            End If
        Next
        'モノルビをふる
        Dim rubySentence As String = Marshal.PtrToStringUni(result.pwchOutput, CInt(result.cchOutput))
        Dim kanjiRubyList As New List(Of kanjiRuby)
        For i As Integer = 0 To kanjiRubyPosList.Count - 2
            Dim kanji As String = kanjiRubyPosList(i).kanji
            Dim rubyStartPos As Integer = kanjiRubyPosList(i).rubyPos
            Dim rubyEndPos As Integer = kanjiRubyPosList(i + 1).rubyPos
            Dim rubyLength As Integer = rubyEndPos - rubyStartPos
            Dim ruby As String = rubySentence.Substring(rubyStartPos, rubyLength)
            kanjiRubyList.Add(New kanjiRuby With {.kanji = kanji, .ruby = ruby})
        Next
        Return kanjiRubyList
    End Function

    Public Class kanjiRuby
        Property kanji As String
        Property ruby As String
    End Class

End Class

'参考
'msime.h ダウンロード
'https://www.microsoft.com/en-us/download/details.aspx?id=9739
'IFELanguage::GetJMorphResult method
'https://msdn.microsoft.com/ja-jp/library/windows/desktop/hh851782(v=vs.85).aspx
'searchcode imelib /ImeLibSrc/WinApi/MsIme.cs
'https://searchcode.com/codesearch/view/10960462/

Public NotInheritable Class Interface_ID
    Public Const IID_IFECommon As String = "019F7151-E6DB-11d0-83C3-00C04FDDB82E"
    Public Const IID_IFELanguage As String = "019F7152-E6DB-11d0-83C3-00C04FDDB82E"
    Public Const IID_IFELanguage2 As String = "21164102-C24A-11d1-851A-00C04FCC6B14"
    Public Const IID_IFEDictionary As String = "019F7153-E6DB-11d0-83C3-00C04FDDB82E"
End Class

<ComImport>
<Guid(Interface_ID.IID_IFELanguage)>
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
Public Interface IFELanguage
    <PreserveSig>
    Function Open() As Integer
    <PreserveSig>
    Function Close() As Integer
    <PreserveSig>
    Function GetJMorphResult(<[In]> dwRequest As FELANG_REQ,                                'The conversion request.
                             <[In]> dwCMode As FELANG_CMODE,                                'Specifies the conversion output characters and conversion options.
                             <[In]> cwchInput As Integer,                                   'The number of characters in pwchInput.
                             <[In], MarshalAs(UnmanagedType.LPWStr)> pwchInput As String,   'Input characters to be converted by the morphology engine. This must be a UNICODE string.
                             <[In]> ByRef pfCInfo As FELANG_CLMN,                           'The information for each column, where each pfCInfo[x] corresponds to pwchInput[x].
                             <Out> ByRef ppResult As IntPtr) As Integer                     'The address of a MORRSLT structure that receives the morphology result data.
    <PreserveSig>
    Function GetConversionModeCaps(<Out> ByRef pdwCaps As UInteger) As Integer
    <PreserveSig>
    Function GetPhonetic(<[In]> [string] As String,
                         <[In]> start As Integer,
                         <[In]> length As Integer,
                         <Out> ByRef phonetic As String) As Integer
    <PreserveSig>
    Function GetConversion(<[In], MarshalAs(UnmanagedType.BStr)> [string] As String,
                           <[In]> start As Integer,
                           <[In]> length As Integer,
                           <Out> ByRef result As String) As Integer
End Interface

Public Enum FELANG_REQ As UInteger
    CONV = &H10000
    RECONV = &H20000
    REV = &H30000
End Enum

Public Enum FELANG_CLMN As UInteger
    WBREAK = &H1
    NOWBREAK = &H2
    PBREAK = &H4
    NOPBREAK = &H8
    FIXR = &H10
    FIXD = &H20                     'fix display of word
End Enum

Public Enum FELANG_CMODE As UInteger
    MONORUBY = &H2                  'mono-ruby
    NOPRUNING = &H4                 'no pruning
    KATAKANAOUT = &H8               'katakana output
    HIRAGANAOUT = &H0               'default output
    HALFWIDTHOUT = &H10             'half-width output
    FULLWIDTHOUT = &H20             'full-width output
    BOPOMOFO = &H40                 '
    HANGUL = &H80                   '
    PINYIN = &H100                  '
    PRECONV = &H200                 'do conversion as follows:
    RADICAL = &H400                 '
    UNKNOWNREADING = &H800          '
    MERGECAND = &H1000              'merge display with same candidate
    ROMAN = &H2000                  '
    BESTFIRST = &H4000              'only make 1st best
    USENOREVWORDS = &H8000          'use invalid revword on REV/RECONV.
    NONE = &H1000000                'IME_SMODE_NONE
    PLAURALCLAUSE = &H2000000       'IME_SMODE_PLAURALCLAUSE
    SINGLECONVERT = &H4000000       'IME_SMODE_SINGLECONVERT
    AUTOMATIC = &H8000000           'IME_SMODE_AUTOMATIC
    PHRASEPREDICT = &H10000000      'IME_SMODE_PHRASEPREDICT
    CONVERSATION = &H20000000       'IME_SMODE_CONVERSATION
    NAME = PHRASEPREDICT            'Name mode (MSKKIME)
    NOINVISIBLECHAR = &H40000000    'remove invisible chars (e.g. tone mark)
End Enum

<StructLayout(LayoutKind.Explicit, Size:=48, Pack:=1)>
Public Structure MORRSLT
    <FieldOffset(0)> Public dwSize As UInt32           'DWORD dwSize;          total size of this block.
    <FieldOffset(4)> Public pwchOutput As IntPtr       'WCHAR *pwchOutput;     conversion result string.
    <FieldOffset(8)> Public cchOutput As UInt16        'WORD  cchOutput;       lengh of result string.
    <FieldOffset(10)> Public pwchRead As IntPtr        'union {WCHAR *pwchRead;WCHAR *pwchRead;} reading string
    <FieldOffset(14)> Public cchRead As UInt16         'union {WORD cchRead;WORD cchComp;} length of reading string.
    <FieldOffset(16)> Public pchInputPos As IntPtr     'WORD  *pchInputPos;    index array of reading to input character.
    <FieldOffset(20)> Public pchOutPutIdxWDD As IntPtr 'WORD  *pchOutputIdxWDD;index array of output character to WDD
    <FieldOffset(24)> Public pchReadIdxWDD As IntPtr   'union {WORD *pchReadIdxWDD;WORD  *pchCompIdxWDD;} index array of reading character to WDD
    <FieldOffset(28)> Public paMonoRubyPos As IntPtr   'WORD  *paMonoRubyPos;  array of position of monoruby
    <FieldOffset(32)> Public pWDD As IntPtr            'WDD   *pWDD;           pointer to array of WDD
    <FieldOffset(36)> Public cWDD As Int32             'INT   cWDD;            number of WDD
    <FieldOffset(40)> Public pPrivate As IntPtr        'VOID  *pPrivate;       pointer of private data area
    <FieldOffset(44)> Public BLKBuff As IntPtr         'WCHAR BLKBuff[];       area for stored above members.
End Structure

''64bitの定義
'<StructLayout(LayoutKind.Explicit, Size:=84, Pack:=1)>
'Public Structure MORRSLT
'    <FieldOffset(0)> Public dwSize As UInt32           'DWORD dwSize;          total size of this block.
'    <FieldOffset(4)> Public pwchOutput As IntPtr       'WCHAR *pwchOutput;     conversion result string.
'    <FieldOffset(12)> Public cchOutput As UInt16       'WORD  cchOutput;       lengh of result string.
'    <FieldOffset(14)> Public pwchRead As IntPtr        'union {WCHAR *pwchRead;WCHAR *pwchRead;} reading string
'    <FieldOffset(22)> Public cchRead As UInt16         'union {WORD cchRead;WORD cchComp;} length of reading string.
'    <FieldOffset(24)> Public pchInputPos As IntPtr     'WORD  *pchInputPos;    index array of reading to input character.
'    <FieldOffset(32)> Public pchOutPutIdxWDD As IntPtr 'WORD  *pchOutputIdxWDD;index array of output character to WDD
'    <FieldOffset(40)> Public pchReadIdxWDD As IntPtr   'union {WORD *pchReadIdxWDD;WORD  *pchCompIdxWDD;} index array of reading character to WDD
'    <FieldOffset(48)> Public paMonoRubyPos As IntPtr   'WORD  *paMonoRubyPos;  array of position of monoruby
'    <FieldOffset(56)> Public pWDD As IntPtr            'WDD   *pWDD;           pointer to array of WDD
'    <FieldOffset(64)> Public cWDD As Int32             'INT   cWDD;            number of WDD
'    <FieldOffset(68)> Public pPrivate As IntPtr        'VOID  *pPrivate;       pointer of private data area
'    <FieldOffset(76)> Public BLKBuff As IntPtr         'WCHAR BLKBuff[];       area for stored above members.
'End Structure

19:12 | コメント(0)

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

　WebBrowserコントロールではMouseClickイベントがサポートされていません。HtmlDocumentオブジェクトやHtmlElementオブジェクトにClick等のマウスイベントがありますが，XBUTTON1やXBUTTON2（マウスの第４・第５ボタン）はサポートしていません。
　WebBrowserの派生クラスではControl.MouseButtonsが機能せず，常にNoneが返されます。そこで，NativeWindowクラスを使ってサブクラス化して，WebBrowserへのウィンドウメッセージを受け取り，WM_MOUSEACTIVATEのタイミングでGetAsyncKeyState関数でマウスの状態を取得し，MouseClickイベントを発火するようにします。
　下のサンプルではWebBrowserコントロール上でマウスをクリックしたときに，メッセージを表示します。また，XBUTTON1で「戻る」，XBUTTON2で「進む」機能を付加します。

　下のコードをフォームのコードにコピー・貼り付けをすれば動作します。

Option Explicit On
Option Strict On

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

Public Class Form1

    Private WebBrowser1 As New WebBrowser
    Private WithEvents WebBrowserMouseClick As New WebBrowserMouseClick(WebBrowser1)

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        BrowserEmulation.CreateRenderingModeRegkey(BrowserEmulation.Emulation.IE11Edge)
        Me.WebBrowser1.Dock = DockStyle.Fill
        Me.WebBrowser1.GoHome()
        Me.Text = "WebBrowserMouseClickEvent"
        Me.Controls.Add(Me.WebBrowser1)
    End Sub

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

    Private Sub WebBrowserMouseClick_MouseClick(sender As Object, e As MouseEventArgs) Handles WebBrowserMouseClick.MouseClick
        MessageBox.Show(e.Button.ToString)
    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 WebBrowserMouseClick
    Inherits NativeWindow

    Enum VirtualKeyCodes As Integer
        VK_LBUTTON = &H1
        VK_RBUTTON = &H2
        VK_MBUTTON = &H4
        VK_XBUTTON1 = &H5
        VK_XBUTTON2 = &H6
    End Enum

    <DllImport("user32")>
    Private Shared Function GetAsyncKeyState(<[In]()> ByVal vKey As VirtualKeyCodes) As Short
    End Function

    Public Event MouseClick(ByVal sender As Object, ByVal e As MouseEventArgs)

    Private WithEvents WebBrowser As WebBrowser

    Public Sub New(WebBrowser As WebBrowser)
        Me.WebBrowser = WebBrowser
    End Sub

    Private Sub WebBrowser_HandleCreated(sender As Object, e As EventArgs) Handles WebBrowser.HandleCreated
        AssignHandle(DirectCast(sender, WebBrowser).Handle)
    End Sub

    Private Sub WebBrowser_HandleDestroyed(sender As Object, e As EventArgs) Handles WebBrowser.HandleDestroyed
        ReleaseHandle()
    End Sub

    Protected Sub OnMouseClick(ByVal e As System.Windows.Forms.MouseEventArgs)
        If e.Button = Windows.Forms.MouseButtons.XButton1 Then
            Me.WebBrowser.GoBack()
        End If
        If e.Button = Windows.Forms.MouseButtons.XButton2 Then
            Me.WebBrowser.GoForward()
        End If
        RaiseEvent MouseClick(Me, e)
    End Sub

    Protected Overrides Sub WndProc(ByRef m As Message)
        Const WM_MOUSEACTIVATE = &H21
        If m.Msg = WM_MOUSEACTIVATE Then
            Dim x As Integer = Control.MousePosition.X
            Dim y As Integer = Control.MousePosition.Y
            If GetAsyncKeyState(VirtualKeyCodes.VK_LBUTTON) < 0 Then
                OnMouseClick(New MouseEventArgs(Windows.Forms.MouseButtons.Left, 1, x, y, 0))
            End If
            If GetAsyncKeyState(VirtualKeyCodes.VK_RBUTTON) < 0 Then
                OnMouseClick(New MouseEventArgs(Windows.Forms.MouseButtons.Right, 1, x, y, 0))
            End If
            If GetAsyncKeyState(VirtualKeyCodes.VK_MBUTTON) < 0 Then
                OnMouseClick(New MouseEventArgs(Windows.Forms.MouseButtons.Middle, 1, x, y, 0))
            End If
            If GetAsyncKeyState(VirtualKeyCodes.VK_XBUTTON1) < 0 Then
                OnMouseClick(New MouseEventArgs(Windows.Forms.MouseButtons.XButton1, 1, x, y, 0))
            End If
            If GetAsyncKeyState(VirtualKeyCodes.VK_XBUTTON2) < 0 Then
                OnMouseClick(New MouseEventArgs(Windows.Forms.MouseButtons.XButton2, 1, x, y, 0))
            End If
        End If
        MyBase.WndProc(m)
    End Sub

End Class

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

01:22 | コメント(0)

2018/06/12	ベーシックなタブブラウザを作る	\| by:YAS

　この記事は２００５年頃に.NET Framework2.0で作成したものを元にし，.NET Framework4以降でエラーになるところだけを修正したものです。１０年以上前のものですので，今コードを見ると「違う，そうじゃない」（by鈴木雅之）を歌いたくなるところだらけですが，資料としてアップロードしておきます。

　下のサンプルは次の機能・特徴を備えるタブ型のブラウザです。
・TabControlコントロールを利用したタブ型ブラウザである。
・新しいウィンドウで開くで新しいタブが開く。（NewWindow2イベントを実装）
・スクリプトのWindow.close()でタブが閉じる。（WindowClosingイベントもどきを実装）
・キーボードショートカットCtrl-Nで新しいタブが開く等，ショートカットの機能の置き換えている。
・マウスの第４・第５ボタンや，インターネットショートカットボタン付きキーボードに対応している。（WM_APPCOMMANDメッセージの処理を実装）

　下のコードをフォームのコードにコピー・貼り付けをすれば動作します。

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

22:52 | コメント(0) | WebBrowser

2018/06/11	WebBrowserコントロールをWM_APPCOMMANDメッセージに対応させる	\| by:YAS

　WebBrowserコントロールはマウスの第４・第５ボタンやキーボードの「戻る」「進む」ボタンに対応しておらず，入力しても反応がありません。また，WebBrowserコントロールはMouseClickイベント等のマウス関係のイベントやKeyDownイベント等のキー入力関係のイベントをサポートしていないのでそれらのイベントを利用した実装もできません。
　前述のボタンやキーの入力をするとWebBrowserコントロールにウィンドウメッセージWM_APPCOMMANDが送られてきます。そのメッセージのlParamを調べることでアプリケーションコマンドを特定することができます。
　下のサンプルでは，WndProcをオーバーライドし，WebBrowserコントロールをマウスやキーボードのアプリケーション用ボタンによる操作を可能としました。
　下のコードをフォームのコードにコピー・貼り付けをすれば動作します。

Option Explicit On
Option Strict On

Imports System.ComponentModel
Imports System.IO
Imports Microsoft.Win32

Public Class Form1

    Dim WithEvents WebBrowser As New ExWebBrowser

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        BrowserEmulation.CreateRenderingModeRegkey(BrowserEmulation.Emulation.IE11Edge)
        Me.WebBrowser.Dock = DockStyle.Fill
        Me.Text = "WM_APPCOMMANDに対応したWebBrowser"
        Me.Controls.Add(WebBrowser)
        Me.WebBrowser.GoHome()
    End Sub

    Private Sub Form1_Closing(sender As Object, e As CancelEventArgs) Handles Me.Closing
        BrowserEmulation.DeleteRenderingModeRegkey()
    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

    Sub New()
        MyBase.New()
    End Sub

    'WinUser.h
    Enum APPCOMMAND As Short
        BROWSER_BACKWARD = 1
        BROWSER_FORWARD = 2
        BROWSER_REFRESH = 3
        BROWSER_STOP = 4
        BROWSER_SEARCH = 5
        BROWSER_FAVORITES = 6
        BROWSER_HOME = 7
    End Enum

    'WinUser.h
    '#define GET_APPCOMMAND_LPARAM(lParam) ((short)(HIWORD(lParam) & ~FAPPCOMMAND_MASK))
    Private Function GET_APPCOMMAND_LPARAM(ByVal lParam As IntPtr) As Short
        Const FAPPCOMMAND_MASK As UInt16 = &HF000
        Return CShort(((CType(lParam, Integer) And &HFFFF0000) >> 16) And (Not FAPPCOMMAND_MASK))
    End Function

    Protected Overrides Sub WndProc(ByRef m As System.Windows.Forms.Message)
        Const WM_APPCOMMAND = &H319
        If m.Msg = WM_APPCOMMAND Then
            Select Case GET_APPCOMMAND_LPARAM(m.LParam)
                Case APPCOMMAND.BROWSER_BACKWARD
                    Me.GoBack()
                    Return
                Case APPCOMMAND.BROWSER_FORWARD
                    Me.GoForward()
                    Return
                Case APPCOMMAND.BROWSER_REFRESH
                    Me.Refresh()
                    Return
                Case APPCOMMAND.BROWSER_STOP
                    Me.Stop()
                    Return
                Case APPCOMMAND.BROWSER_SEARCH
                    Me.GoSearch()
                    Return
                Case APPCOMMAND.BROWSER_HOME
                    Me.GoHome()
                    Return
            End Select
        End If
        MyBase.WndProc(m)
    End Sub

End Class

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

22:11 | コメント(0) | WebBrowser

2018/06/11	WebBrowserコントロールのキーボードショートカットをカスタマイズする	\| by:YAS

　例えばタブブラウザをWebBrowserコントロールを利用して作成しても，キーボードショートカットCtrl-Nを押すとInternetExplorerが新しいウィンドウで開いてしまいます。これを新しいタブを開くなど別の処理をするように変更したいのですが，WebBrowserコントロールはKeyDown等のキー入力のイベントをサポートしていません。
　そこでWebBrowser.WebBrowserSiteを継承し，IDocHostUIHandlerインターフェイスを独自に実装しようとしたが，どうしてもうまく機能しません。（MSHTMLからメソッドが呼ばれません。実装方法に問題があるのでしょうが，正しい方法がわかりません。）
　ショートカットキーの入力を検知し，さらにオリジナルの処理をキャンセルできるメソッドを探したところ，PreProcessMessageメソッドが見つかりました。
　下のサンプルはWebBrowserコントロールのショートカットキーCtrl-Nでメッセージボックスを表示し，Ctrl-Pで印刷プレビューを表示します。
　下のコードをフォームのコードにコピー・貼り付けをすれば動作します。

Option Explicit On
Option Strict On

Imports System.ComponentModel
Imports System.IO
Imports Microsoft.Win32

Public Class Form1

    Dim WithEvents WebBrowser1 As New ExWebBrowser

    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.Dock = DockStyle.Fill
        'Form1
        Me.Controls.Add(Me.WebBrowser1)
        '
        Me.WebBrowser1.GoHome()
    End Sub

    Private Sub Form1_Closing(sender As Object, e As CancelEventArgs) Handles Me.Closing
        BrowserEmulation.DeleteRenderingModeRegkey()
    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

    Sub New()
        MyBase.New()
    End Sub

    'キーボードショートカットの処理を変更
    Public Overrides Function PreProcessMessage(ByRef msg As System.Windows.Forms.Message) As Boolean
        Const WM_KEYDOWN As Integer = &H100
        If msg.Msg = WM_KEYDOWN Then
            Dim keyCode As Keys = CType(msg.WParam, Keys) And Keys.KeyCode
            If My.Computer.Keyboard.CtrlKeyDown Then
                Select Case keyCode
                    Case Keys.N
                        MessageBox.Show("Ctrl-Nが押されました", "ショートカットキー", MessageBoxButtons.OK, MessageBoxIcon.Information)
                        Return True
                    Case Keys.P
                        Me.ShowPrintPreviewDialog()
                        Return True
                End Select
            End If
        End If
        Return MyBase.PreProcessMessage(msg)
    End Function

End Class

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

22:05 | コメント(0) | WebBrowser

1 2 3 4 次