PrivateSub Form1_Load(sender AsObject, e As EventArgs) HandlesMyBase.Load BrowserEmulation.CreateRenderingModeRegkey(BrowserEmulation.Emulation.IE11Edge) Me.WebBrowser.ScriptErrorsSuppressed = True Me.Controls.Add(Me.WebBrowser) Me.WebBrowser.GoHome() EndSub
PrivateSub Form1_FormClosing(sender AsObject, e As FormClosingEventArgs) HandlesMe.FormClosing BrowserEmulation.DeleteRenderingModeRegkey() MeCab.Dispose() EndSub
PrivateSub WebBrowser_DocumentCompleted(sender AsObject, e As WebBrowserDocumentCompletedEventArgs) Handles WebBrowser.DocumentCompleted Dim domElement As IHTMLDOMNode = DirectCast(Me.WebBrowser.Document.Body.DomElement, IHTMLDOMNode) AttachRuby(domElement) Marshal.FinalReleaseComObject(domElement) EndSub
'テキストノードを検索してMeCabで処理する PrivateSub AttachRuby(ByVal node As IHTMLDOMNode) SelectCase node.nodeName.ToLower Case"ruby", "select" Return EndSelect Dim document As IHTMLDocument2 = Nothing Dim childNodes As IHTMLDOMChildrenCollection = Nothing Try document = DirectCast(DirectCast(node, IHTMLDOMNode2).ownerDocument, IHTMLDocument2) childNodes = DirectCast(node.childNodes, IHTMLDOMChildrenCollection) ForEach childNode As IHTMLDOMNode In childNodes Try If childNode.nodeType = NODETYPE.TEXT_NODE Then Dim childNodeValue AsString = DirectCast(childNode.nodeValue, String) If Regex.IsMatch(childNodeValue, "[\u4E00-\u9FFF\u3040-\u309F\u30A0-\u30FA]") Then 'MeCabでテキストノードを解析する Dim result AsString = 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 IsNotNothingThen Marshal.ReleaseComObject(newElement) EndIf EndTry EndIf 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 IsNotNothingThen Marshal.ReleaseComObject(frameBody) EndIf If frameDocument IsNotNothingThen Marshal.ReleaseComObject(frameDocument) EndIf If frame IsNotNothingThen Marshal.ReleaseComObject(frame) EndIf EndTry Else If childNode.hasChildNodes Then AttachRuby(childNode) '子エレメントを再帰的に処理 EndIf EndIf EndIf Finally If childNode IsNotNothingThen Marshal.ReleaseComObject(childNode) EndIf EndTry Next Finally If childNodes IsNotNothingThen Marshal.ReleaseComObject(childNodes) EndIf If document IsNotNothingThen Marshal.ReleaseComObject(document) EndIf EndTry EndSub
PrivateFunction RegexMatchEvaluator(ByVal M As Match) AsString Dim kanji AsString = M.Groups(1).Value '漢字 Dim kana AsString = StrConv(M.Groups(2).Value, VbStrConv.Hiragana) 'かな Dim result AsString = kanji If Regex.IsMatch(kanji, "\p{IsCJKUnifiedIdeographs}") Then result = "<ruby>" & kanji & "<rt>" & kana & "</rt></ruby>" EndIf Return result EndFunction
<DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)> PublicSharedFunction mecab_new2(ByVal arg AsString) As IntPtr EndFunction
<DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)> PublicSharedFunction mecab_sparse_tostr(ByVal m As IntPtr, ByVal str AsString) As IntPtr EndFunction
<DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)> PublicSharedSub mecab_destroy(ByVal m As IntPtr) EndSub
PrivateSub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) HandlesMyBase.Load Me.TextBox1.Multiline = True Me.TextBox1.ScrollBars = ScrollBars.Vertical Me.TextBox1.Dock = DockStyle.Fill Me.Controls.Add(Me.TextBox1) Using Mecab1 AsNew MeCab Me.TextBox1.Text = Mecab1.Parse("和布蕪を使って日本語文字列を形態素分析する。").Replace(vbLf, vbCrLf) EndUsing EndSub
EndClass
ClassMeCab Implements IDisposable
<DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)> PublicSharedFunction mecab_new2(ByVal arg AsString) As IntPtr EndFunction
<DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)> PublicSharedFunction mecab_sparse_tostr(ByVal m As IntPtr, ByVal str AsString) As IntPtr EndFunction
<DllImport("libmecab.dll", CallingConvention:=CallingConvention.Cdecl)> PublicSharedSub mecab_destroy(ByVal m As IntPtr) EndSub
PrivateWithEvents TextBox1 AsNew TextBox With {.Multiline = True, .Dock = DockStyle.Fill} Private MsIme As Type = Type.GetTypeFromProgID("MSIME.Japan") Private Language As IFELanguage = DirectCast(Activator.CreateInstance(MsIme), IFELanguage)
PrivateSub Form1_Load(sender AsObject, e As EventArgs) HandlesMyBase.Load Me.Controls.Add(TextBox1) Language.Open() Dim KanjiText AsString = "天気予報によると,明日は晴れになるでしょう。" Dim List As List(Of kanjiRuby) = getMonoRuby(KanjiText) ForEach l In List Me.TextBox1.Text &= l.kanji & "(" & l.ruby & ")" & vbCrLf Next Language.Close() Marshal.FinalReleaseComObject(Language) EndSub
PublicFunction getMonoRuby(kanjiSentence AsString) As List(Of kanjiRuby) Dim resultPtr As IntPtr Dim hr AsInteger = 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 AsInteger = kanjiSentence.Length Dim kanjiRubyPosList = {NewWith {.kanji = "", .rubyPos = 0}}.ToList kanjiRubyPosList.Clear() For i AsInteger = 0 To length Dim kanji AsString = If(i < length, kanjiSentence.Substring(i, 1), "") Dim rubyPos AsInteger = CInt(Marshal.ReadInt16(result.paMonoRubyPos, i * 2)) kanjiRubyPosList.Add(NewWith {kanji, rubyPos}) Next '熟字訓をまとめる For i AsInteger = length To 0 Step -1 If kanjiRubyPosList(i).rubyPos = -1 Then kanjiRubyPosList(i - 1).kanji &= kanjiRubyPosList(i).kanji kanjiRubyPosList.Remove(kanjiRubyPosList(i)) EndIf Next 'モノルビをふる Dim rubySentence AsString = Marshal.PtrToStringUni(result.pwchOutput, CInt(result.cchOutput)) Dim kanjiRubyList AsNew List(Of kanjiRuby) For i AsInteger = 0 To kanjiRubyPosList.Count - 2 Dim kanji AsString = kanjiRubyPosList(i).kanji Dim rubyStartPos AsInteger = kanjiRubyPosList(i).rubyPos Dim rubyEndPos AsInteger = kanjiRubyPosList(i + 1).rubyPos Dim rubyLength AsInteger = rubyEndPos - rubyStartPos Dim ruby AsString = rubySentence.Substring(rubyStartPos, rubyLength) kanjiRubyList.Add(New kanjiRuby With {.kanji = kanji, .ruby = ruby}) Next Return kanjiRubyList EndFunction
PublicClasskanjiRuby Property kanji AsString Property ruby AsString EndClass
<ComImport> <Guid(Interface_ID.IID_IFELanguage)> <InterfaceType(ComInterfaceType.InterfaceIsIUnknown)> PublicInterfaceIFELanguage <PreserveSig> Function Open() AsInteger <PreserveSig> Function Close() AsInteger <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 AsInteger, 'The number of characters in pwchInput. <[In], MarshalAs(UnmanagedType.LPWStr)> pwchInput AsString, '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) AsInteger'The address of a MORRSLT structure that receives the morphology result data. <PreserveSig> Function GetConversionModeCaps(<Out> ByRef pdwCaps AsUInteger) AsInteger <PreserveSig> Function GetPhonetic(<[In]> [string] AsString, <[In]> start AsInteger, <[In]> length AsInteger, <Out> ByRef phonetic AsString) AsInteger <PreserveSig> Function GetConversion(<[In], MarshalAs(UnmanagedType.BStr)> [string] AsString, <[In]> start AsInteger, <[In]> length AsInteger, <Out> ByRef result AsString) AsInteger EndInterface
<StructLayout(LayoutKind.Explicit, Size:=48, Pack:=1)> PublicStructureMORRSLT <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. EndStructure
''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
PrivateSub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) HandlesMyBase.Load BrowserEmulation.CreateRenderingModeRegkey(BrowserEmulation.Emulation.IE11Edge) Me.WebBrowser1.Dock = DockStyle.Fill Me.WebBrowser1.GoHome() Me.Text = "WebBrowserMouseClickEvent" Me.Controls.Add(Me.WebBrowser1) EndSub
PrivateSub Form1_Closing(sender AsObject, e As CancelEventArgs) HandlesMe.Closing BrowserEmulation.DeleteRenderingModeRegkey() EndSub
PrivateSub WebBrowserMouseClick_MouseClick(sender AsObject, e As MouseEventArgs) Handles WebBrowserMouseClick.MouseClick MessageBox.Show(e.Button.ToString) EndSub
<DllImport("user32")> PrivateSharedFunction GetAsyncKeyState(<[In]()> ByVal vKey As VirtualKeyCodes) AsShort EndFunction
PublicEvent MouseClick(ByVal sender AsObject, ByVal e As MouseEventArgs)
PrivateWithEvents WebBrowser As WebBrowser
PublicSubNew(WebBrowser As WebBrowser) Me.WebBrowser = WebBrowser EndSub
PrivateSub WebBrowser_HandleCreated(sender AsObject, e As EventArgs) Handles WebBrowser.HandleCreated AssignHandle(DirectCast(sender, WebBrowser).Handle) EndSub
PrivateSub WebBrowser_HandleDestroyed(sender AsObject, e As EventArgs) Handles WebBrowser.HandleDestroyed ReleaseHandle() EndSub
ProtectedSub OnMouseClick(ByVal e As System.Windows.Forms.MouseEventArgs) If e.Button = Windows.Forms.MouseButtons.XButton1 Then Me.WebBrowser.GoBack() EndIf If e.Button = Windows.Forms.MouseButtons.XButton2 Then Me.WebBrowser.GoForward() EndIf RaiseEvent MouseClick(Me, e) EndSub
ProtectedOverridesSub WndProc(ByRef m As Message) Const WM_MOUSEACTIVATE = &H21 If m.Msg = WM_MOUSEACTIVATE Then Dim x AsInteger = Control.MousePosition.X Dim y AsInteger = Control.MousePosition.Y If GetAsyncKeyState(VirtualKeyCodes.VK_LBUTTON) < 0 Then OnMouseClick(New MouseEventArgs(Windows.Forms.MouseButtons.Left, 1, x, y, 0)) EndIf If GetAsyncKeyState(VirtualKeyCodes.VK_RBUTTON) < 0 Then OnMouseClick(New MouseEventArgs(Windows.Forms.MouseButtons.Right, 1, x, y, 0)) EndIf If GetAsyncKeyState(VirtualKeyCodes.VK_MBUTTON) < 0 Then OnMouseClick(New MouseEventArgs(Windows.Forms.MouseButtons.Middle, 1, x, y, 0)) EndIf If GetAsyncKeyState(VirtualKeyCodes.VK_XBUTTON1) < 0 Then OnMouseClick(New MouseEventArgs(Windows.Forms.MouseButtons.XButton1, 1, x, y, 0)) EndIf If GetAsyncKeyState(VirtualKeyCodes.VK_XBUTTON2) < 0 Then OnMouseClick(New MouseEventArgs(Windows.Forms.MouseButtons.XButton2, 1, x, y, 0)) EndIf EndIf MyBase.WndProc(m) EndSub
'WinUser.h '#define GET_APPCOMMAND_LPARAM(lParam) ((short)(HIWORD(lParam) & ~FAPPCOMMAND_MASK)) PrivateFunction GET_APPCOMMAND_LPARAM(ByVal lParam As IntPtr) AsShort Const FAPPCOMMAND_MASK As UInt16 = &HF000 ReturnCShort(((CType(lParam, Integer) And &HFFFF0000) >> 16) And (Not FAPPCOMMAND_MASK)) EndFunction
ProtectedOverridesSub WndProc(ByRef m As System.Windows.Forms.Message) Const WM_APPCOMMAND = &H319 If m.Msg = WM_APPCOMMAND Then SelectCase 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 EndSelect EndIf MyBase.WndProc(m) EndSub
'キーボードショートカットの処理を変更 PublicOverridesFunction PreProcessMessage(ByRef msg As System.Windows.Forms.Message) AsBoolean Const WM_KEYDOWN AsInteger = &H100 If msg.Msg = WM_KEYDOWN Then Dim keyCode As Keys = CType(msg.WParam, Keys) And Keys.KeyCode If My.Computer.Keyboard.CtrlKeyDown Then SelectCase keyCode Case Keys.N MessageBox.Show("Ctrl-Nが押されました", "ショートカットキー", MessageBoxButtons.OK, MessageBoxIcon.Information) ReturnTrue Case Keys.P Me.ShowPrintPreviewDialog() ReturnTrue EndSelect EndIf EndIf ReturnMyBase.PreProcessMessage(msg) EndFunction
<DllImport("user32.dll")> PrivateSharedFunction GetWindow(ByVal hWnd As IntPtr, ByVal uCmd As GETWINDOWCMD) As IntPtr EndFunction
PublicEvent WindowClosing As EventHandler
ProtectedOverridableSub OnWindowClosing(ByVal e As EventArgs) RaiseEvent WindowClosing(Me, e) EndSub
ProtectedOverridesSub 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 AsNew EventArgs OnWindowClosing(e) Return EndIf EndIf EndIf MyBase.WndProc(m) EndSub