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

VB.NET Tips

2022/02/20	VBでRaspberry Pi PICOにファイルを転送する	\| by:YAS

　Raspberry Pi PICOにファイルを転送するには、Thonnyなどを使えば簡単にできますが、PICOを使った自作VOCAにWAVEファイルを転送しようとすると、簡単にできる方法はなさそうです。バイナリ配列の内容をファイルを書き込むコードをREPLモードで実行してみましたが、メモリ不足のエラーが出て、ごく小さいファイルしか転送できませんでした。そこで、仮想COMポートのcom0comを使ってThonnyの通信内容を解読したところ、2kbyteずつ送信・書き込みを行っていることがわかりました。
　下のサンプルコードはtest.wavをPICOのルートディレクトリに転送します。コードをForm1にコピー・貼り付けすれば動作します。

Form1.vb

11:05 | コメント(0)

2022/02/13	Google Text-to-SpeechをVBから利用する	\| by:YAS

　以前、「VoiceTextサンプル」で、VoiceText（現在はReadSpeakerと改名）でWebAPIを使ってしゃべらせるサンプルを作成しました。ただ、ReadSpeakerの音声は個人的に聞くことに制限されていて、人に聞かせるためのアプリケーションで用いることは禁止されています。（一太郎付属の詠太も同様）
　そこで、今度は利用制限がゆるそうなGoogle Text-to Speechを使ってみることにしました。
　下のサンプルは、まず、「Google Cloud Text-to-Speech の使い方日本語テキストを読み上げさせてみよう」などを参考にして、Google Cloud Platformのアカウントを取得し、Google Cloud SDKをインストールし、Text-to-Speech APIを有効化します。認証ファイルを取得したら、「credential.json」にリネームし、実行ファイルと同じフォルダに配置きます。その後、コードをコピー・貼り付けすれば動作します。

Form1.vb

15:59 | コメント(0)

2022/02/12	GhostScriptで一時ファイルを作らずにPDFのサムネイルを作成する	\| by:YAS

　以前、「PDFをJPEGに変換する」で、GhostScriptでPDFを画像化してファイルに保存することができました。
　しかし、各ページをサムネイルで表示したい場合などでは、むやみにファイルを作らず、メモリ上でdllとやり取りをしたいと思います。
　「gsapi_set_display_callback()」を使うことで、コールバック関数で、dllが生成した画像を直接受け取ることができました。
　詳しくはサンプルのコードをご覧ください。
　サンプルは，下のコードをコピー・貼り付けし、実行ファイルと同じフォルダにGhostSciptから抽出した「gsdll64.dll」と、適当なPDFを「test.pdf」とリネームして配置すれば動作します。32bit環境では、「gsdll32.dll」を配置し、定数gsdllを「gsdll32.dll」に書き換えてください。

Form1.vb

mdlGhostScript.vb

07:48 | コメント(0)

2021/07/17	WebView2でファイルアップロードを自動化する	\| by:YAS

　2021年ともなると，IEを使うのはさすがに厳しい状況です。ソフトウェアにブラウザを組み込むにしても，WebBrowserコントロールではなく，WebView2を使うことになります。以前作ったNetCommons2へのアップロードを自動化するために，「開く」ダイアログに自動的にファイルのパスを入力するサンプルをWebView2用に変更してみました。
　WebView2コントロールを使うには，新規プロジェクトを作成してから，「プロジェクト」-「NuGetパッケージの管理」から「Microsoft.Web.WebView2」をインストールします。
　サンプルは，下のコードをコピー・貼り付けすれば動作します。
　※WebView2OpenDialogAutomaticInput.vbのコードをアップロードする際に間違えて違うコードをアップロードしていました。2022/01/09に修正しました。
Form1.vb

WebView2OpenDialogAutomaticInput.vb

13:52 | コメント(0)

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)

1 2 3 4 次