YAS's VB.NET Tips
 
VB.NET Tips
VB.NET Tips
123
2018/09/08

ぷりんときっずダウンローダーVer.2.0

| by:YAS
 前回,プリントキッズの1ページ分のプリントをまとめてダウンロードするコードを考えた。今回は,カテゴリを指定して,カテゴリ内のすべてのプリントをダウンロードするコードを考える。
 最上位のカテゴリは左図のメニューとする。このメニューは下のようは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
 ぷりんときっずの無料プリントをよく利用させていただいている。フォントが丸文字のプリントもあったりするが,わざわざ教科書体で作り直してくださったものもあり,ありがたく活用させていただいている。
 まとめてダウンロードしたいプリントも多いのだが,一括ダウンロードはできないようなので,専用のダウンローダーを作成してみる。
 あまり負荷をかけるのもよくないとは思うが,かなり高速なレスポンスのサーバーのようなので,個人的にダウンローダーを作成して使う分には問題なさそうだと思っている。
 まずは,1ページにまとめられているPDFのプリントをすべてダウンロードしてみる。
 chromeでPDFのリンクを右クリック→検証で,デベロッパーツールでHTMLを確認すると,PDFのダウンロードページのPDFへのリンク部分は左のようになっている。
 PDFファイルへのリンクは,id="topic"のdiv要素を検索し,その中のa要素を検索して取得することにする。

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


 1つ1つの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 StringAs IntPtr
    
End Function

    <DllImport(
"libmecab.dll", CallingConvention:=CallingConvention.Cdecl)>
    
Public Shared Function mecab_sparse_tostr(ByVal m As IntPtr, ByVal str As StringAs 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 StringAs 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 StringAs IntPtr
    
End Function

    <DllImport(
"libmecab.dll", CallingConvention:=CallingConvention.Cdecl)>
    
Public Shared Function mecab_sparse_tostr(ByVal m As IntPtr, ByVal str As StringAs 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 StringAs 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 StringAs 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 UIntegerAs Integer
    <PreserveSig>
    
Function GetPhonetic(<[In]> [string] As String,
                         <[In]> start 
As Integer,
                         <[In]> length 
As Integer,
                         <Out> 
ByRef phonetic As StringAs Integer
    <PreserveSig>
    
Function GetConversion(<[In], MarshalAs(UnmanagedType.BStr)> [string] As String,
                           <[In]> start 
As Integer,
                           <[In]> length 
As Integer,
                           <Out> 
ByRef result As StringAs 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(マウスの第4・第5ボタン)はサポートしていません。
 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 ObjectByVal 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
 この記事は2005年頃に.NET Framework2.0で作成したものを元にし,.NET Framework4以降でエラーになるところだけを修正したものです。10年以上前のものですので,今コードを見ると「違う,そうじゃない」(by鈴木雅之)を歌いたくなるところだらけですが,資料としてアップロードしておきます。

 下のサンプルは次の機能・特徴を備えるタブ型のブラウザです。
・TabControlコントロールを利用したタブ型ブラウザである。 
・新しいウィンドウで開くで新しいタブが開く。(NewWindow2イベントを実装)
・ スクリプトのWindow.close()でタブが閉じる。(WindowClosingイベントもどきを実装) 
・キーボードショートカットCtrl-Nで新しいタブが開く等,ショートカットの機能の置き換えている。 
・マウスの第4・第5ボタンや,インターネットショートカットボタン付きキーボードに対応している。(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コントロールはマウスの第4・第5ボタンやキーボードの「戻る」「進む」ボタンに対応しておらず,入力しても反応がありません。また,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, IntegerAnd &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
2018/06/11

WebBrowserコントロールにWindowClosingイベントもどきを拡張する

| by:YAS
 WebBrowserコントロールにはWindowClosingイベントがありません。そのため,スクリプトのwindow.close()が検知できず,しかもwindow.close()を実行されると無反応になってしまいます。 NewWindow2イベントの拡張と同様の方法でWindowClosingイベントの実装を試みましたが,実装方法に問題があるのか動作しません。そこでウィンドウメッセージWM_PARENTNOTIFYで子ウィンドウの破棄を検知し,そのタイミングでWindowClosingイベントを発生するようにしました。 この方法でwindow.close()を検知し,アプリケーションを適切に閉じることができるようになります。しかし,この方法はwindow.close()をキャンセルすることができません。イベントを無視しても,WebBrowserコントロールは破棄され,無反応となります。
 下のコードをフォームのコードにコピー・貼り付けをすれば動作します。
Option Explicit On
Option Strict On

Imports System.Runtime.InteropServices

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
        
Me.WebBrowser.Dock = DockStyle.Fill
        
Me.Text = "WebBrowserWindowClosingEventSample"
        
Me.Controls.Add(Me.WebBrowser)
        
Me.WebBrowser.DocumentText = "<!DOCTYPE html>" &
                                     
"<html >" &
                                     
"<body>" &
                                     
"<input type=""button"" value=""ウィンドウを閉じる"" onclick=""window.close();"" />" &
                                     
"</body>" &
                                     
"</html>"
    
End Sub

    
Private Sub WebBrowser_WindowClosing(ByVal sender As ObjectByVal e As EventArgs) Handles WebBrowser.WindowClosing
        MessageBox.Show(
"ウィンドウを閉じます""WindowClosingイベント発生", MessageBoxButtons.OK, MessageBoxIcon.Information)
        
Me.Close()
    
End Sub

End Class

Public Class ExWebBrowser
    
Inherits WebBrowser

    
Sub New()
        
MyBase.New()
    
End Sub

    
'WindowClosingイベントの拡張
    
Enum GETWINDOWCMD
        GW_HWNDFIRST = 0
        GW_HWNDLAST = 1
        GW_HWNDNEXT = 2
        GW_HWNDPREV = 3
        GW_OWNER = 4
        GW_CHILD = 5
        GW_ENABLEDPOPUP = 6
    
End Enum

    <DllImport(
"user32.dll")>
    
Private Shared Function GetWindow(ByVal hWnd As IntPtr, ByVal uCmd As GETWINDOWCMD) As IntPtr
    
End Function

    
Public Event WindowClosing As EventHandler

    
Protected Overridable Sub OnWindowClosing(ByVal e As EventArgs)
        
RaiseEvent WindowClosing(Me, e)
    
End Sub

    
Protected Overrides Sub WndProc(ByRef m As System.Windows.Forms.Message)
        
Const WM_PARENTNOTIFY = &H210
        
Const WM_DESTROY = &H2
        
If m.Msg = WM_PARENTNOTIFY Then
            
If m.WParam.ToInt32 = WM_DESTROY Then
                
If m.LParam = GetWindow(Me.Handle, GETWINDOWCMD.GW_CHILD) Then
                    
Dim e As New EventArgs
                    OnWindowClosing(e)
                    
Return
                
End If
            
End If
        
End If
        
MyBase.WndProc(m)
    
End Sub

End Class



※このTipsは2005年頃にNiftyの@homepageで公開していたもの一部変更して再掲載しました。
 http://homepage1.nifty.com/yasunari/VB/VB2005/WebBrowserWindowClosingEvent.htm
21:51 | コメント(0) | WebBrowser
123
メニュー