特許技術者の憂鬱を軽減する誤字/表記揺れ検出ツールのWord版

ツールの概要とリリース場所

ワード版リント君は、文章の表記揺れを検知するソフトウエアです。
このツールは、パワポエンジニアの憂鬱を軽減する誤字/表記揺れ検出ツールを作った物語に基づいて、実装しました。

ワード版リント君のリリース場所は以下です。lintkun_0010.zip をダウンロードして解凍し、setup.exeを実行してください。
https://osdn.net/projects/lintkun/releases

（注：インストールが上手くいかないときは、setup.exe を管理者権限で起動してください。）

（ソースコードも、そのうちアップロードします。）

前書き

或るブラック特許事務所の午後。

ワイ「あー、今日もワード、明日もワードで明細書書きや。」
ワイ「１ページ２０００文字で、１５ページくらいの明細書を２～３日で仕上げんとなあ。
　　　ほんまに腱鞘炎になるで。」
ブラック所長「クライアント企業に納品する特許明細書できたか？」
ワイ「はい、できました！」
ブラック所長「なんやこれは、誤字だらけやないかい！」

ブラック所長「【行なう】じゃのうて【行う】や！JISZ8301にそう書いてあるやろ！」
ブラック所長「【ギア】ってなんや、誤字やろ！【ギヤ】や！」
ブラック所長「【インタフェース】【インターフェース】【インターフェイス】と表記揺れしとるがな、」
ブラック所長「【トラフィック】やのうて【トラヒック】や」
ブラック所長「【ダイヤル】と【ダイアル】とが混在しとるぞ！」
ワイ「は、はい（白目）」
ブラック所長「誤字、脱字、表記の揺れ、があると、
　　　　　　　クライアント企業に、中身もその程度の品質だって思われるぞ！」
ブラック所長「納品時に厳しくチェックされるし注意せなあかん！」
ワイ「はい（白目）」
ブラック所長「ほな、ワシはとりあえず帰るぞ。」
・・・
ワイ「あー、ブラック所長はとっとと帰ってしもうたか。
　　　なんや最近の所長は、どうでもいい重箱の隅つつきばっかやなあ。
　　　まあええわ、こんな重箱の隅なところは、機械でチェックしたるぞ。」

特徴

ワード版リント君の実装形態は、VBAのWordアドインとしました。MS-Wordの編集作業中にシームレスに呼び出すことができます。
分かち書きはJanomeなどの形態素解析エンジンではなく、IWordBreakerを用いました。これもまた問題なのですがそれは後述します。

インストール方法

　インストールシールドLEでsetup.exe を構築しました。setup.exe を起動すればインストール可能です。
　追記：よく考えてみると、「会社パソコンへのソフトインストールに許可が必要」な場合には適用できないですね。近日中にインストーラ版以外にも、アドインファイル自体も公開して、手作業でインストール可能にします。

コード説明

・MS-Wordのリボンからワード版リント君を呼び出せるように、WordアドインにカスタムUIのxmlを登録しました。リボン上の「表記揺れ」ボタンをクリックしたときに Callback_wordLintkun が呼び出されます。

カスタムUI

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
    <ribbon startFromScratch="false">
        <tabs>
            <tab idMso="TabAddIns" label="AppLint">
                <group id="LintkunGroupJP" label="リント君">
                    <button id="idWordLintkun" label="表記揺れ" imageMso="TextBoxPositionGallery" size="large" onAction="Callback_wordLintkun" screentip="ver.0.0.1.0" />
                </group>
            </tab>
        </tabs>
    </ribbon>
</customUI>

・カスタムUI.xmlにより、MS-Word上にリボンと「表記揺れ」ボタンが表示されます。

・コールバック関数は、単にワード版リント君の関数をコールしているだけです。

Callbacks

Option Explicit

'Callback for Auto_JP onAction
Sub Callback_wordLintkun(control As IRibbonControl)
    Call ワード版リント君
End Sub

ワード版リント君の関数

最初はプログレスバーのフォームを表示します。

ワード版リント君の関数(1/3)

'======================================================================
' 正規化したDamerau-Levenshtein距離を用いて表記揺れを算出
' 所定値以下は、表記揺れの可能性ありとしてExcelに書き出し
' Date : 17/Apr/2019
' Programmer : Ken'ichiro Ayaki
'======================================================================
Public Sub ワード版リント君()
    Dim Bar As New ProgressForm
    Application.StatusBar = "ワード版リント君"
    Bar.MaxCount = ActiveDocument.Sentences.Count 'プログレスバーの最大カウント数を設定（ループ回数）
    Bar.ShowBar 'プログレスバーを表示

・IWordBreaker で単語分割して単語表に追加します。なお、処理に応じてプログレスバーを更新します。

ワード版リント君の関数(2/3)

    Dim 単語 As Word.range
    Dim 文章 As Word.range
    Dim 単語表 As Object
    Set 単語表 = CreateObject("scripting.dictionary")
    Dim s単語 As String


    ' プログレスバーの表示オーバーヘッドを防ぐため、ドキュメント→文章→単語の順で分割
    Dim 文章数 As Long
    文章数 = 0
    For Each 文章 In ActiveDocument.Sentences
        Bar.CountUp 'プログレスバーをカウントアップ
        If Bar.StopProcedure = True Then        'キャンセルボタンをが押されたときの処理
            MsgBox "処理を中断しました。"
            Exit Sub
        End If
        Bar.Message = "形態素解析進捗　" & Int(文章数 * 100# / ActiveDocument.Sentences.Count) & "％"

        For Each 単語 In 文章.Words
            s単語 = Trim(単語.Text)
            If Len(s単語) > 3 Then
                If 単語表.Exists(s単語) = False Then
                    単語表.Add s単語, Len(s単語)
                End If
            End If
        Next
        文章数 = 文章数 + 1
    Next

・次に、Excelのワークシートを開きます。そして単語表から２つの単語を取り出して、正規化したDamerau-Levenshtein距離を算出します。その値が 0.34以下ならば、表記揺れの可能性があると判定して、ワークシートに書き込みます。

ワード版リント君の関数(3/3)

    Dim xl As Object
    Set xl = CreateObject("Excel.Application")
    xl.Visible = True
    xl.Workbooks.Add
    xl.Cells(1, 1) = ActiveDocument.name & "のリント結果"


    Dim v単語0 As Variant
    Dim v単語1 As Variant
    Dim s単語0 As String
    Dim s単語1 As String

    Dim row As Long
    Dim col As Long

    Application.StatusBar = "ワード版リント君"
    Bar.MaxCount = 単語表.Count 'プログレスバーの最大カウント数を設定（ループ回数）

    Dim 単語cnt As Long
    xl.Cells(2, 1) = "比較元"
    col = 3
    単語cnt = 1
    For Each v単語0 In 単語表
        Bar.CountUp 'プログレスバーをカウントアップ
        If Bar.StopProcedure = True Then        'キャンセルボタンをが押されたときの処理
            MsgBox "処理を中断しました。"
            Exit Sub
        End If
        Bar.Message = "Excelへの出力　" & Int(単語cnt * 100# / 単語表.Count) & "％"

        s単語0 = v単語0
        row = 1
        xl.Cells(col, row) = s単語0
        For Each v単語1 In 単語表
            s単語1 = v単語1
            If s単語0 <> s単語1 Then
                If NormalizeWeightedDL(s単語0, s単語1) <= 0.34 Then
                    row = row + 1
                    xl.Cells(col, row) = s単語1
                    xl.Cells(2, row) = "比較先"
                End If
            End If
        Next
        If row <> 1 Then
            col = col + 1
        Else
            xl.Cells(col, row) = ""
        End If
        単語cnt = 単語cnt + 1
    Next
    Set xl = Nothing
    Unload Bar
End Sub

正規化したDamerau-Levenshtein距離の算出関数

sourceとtargetの２つの単語のDamerau-Levenshtein距離を算出したのち、２つの単語のうち長い方でDamerau-Levenshtein距離を除算します。

NormalizeWeightedDL

'======================================================================
' 正規化したDamerau-Levenshtein距離の算出
'======================================================================
Public Function NormalizeWeightedDL(source As String, target As String) As Double
    Dim lSource As Long
    Dim lTarget As Long

    lSource = Len(source)
    lTarget = Len(target)
    If lSource > lTarget Then
        NormalizeWeightedDL = WeightedDL(source, target) / lSource
    Else
        NormalizeWeightedDL = WeightedDL(source, target) / lTarget
    End If
End Function

Damerau-Levenshtein距離の算出

以下のURLを参考としました。
https://stackoverflow.com/questions/13693149/weighted-damerau-levenshtein-in-vba

WeightedDL

'======================================================================
' Damerau-Levenshtein距離の算出
' https://stackoverflow.com/questions/13693149/weighted-damerau-levenshtein-in-vba
'======================================================================
Public Function WeightedDL(source As String, target As String) As Double

    Dim deleteCost As Double
    Dim insertCost As Double
    Dim replaceCost As Double
    Dim swapCost As Double

    deleteCost = 1
    insertCost = 1
    replaceCost = 1
    swapCost = 0.8

    Dim i As Long
    Dim j As Long
    Dim k As Long

    If Len(source) = 0 Then
        WeightedDL = Len(target) * insertCost
        Exit Function
    End If

    If Len(target) = 0 Then
        WeightedDL = Len(source) * deleteCost
        Exit Function
    End If

    Dim table() As Double
    ReDim table(Len(source), Len(target))

    Dim sourceIndexByCharacter() As Variant
    ReDim sourceIndexByCharacter(0 To 1, 0 To Len(source) - 1) As Variant

    If Left(source, 1) <> Left(target, 1) Then
        table(0, 0) = aMin(replaceCost, (deleteCost + insertCost))
    End If

    sourceIndexByCharacter(0, 0) = Left(source, 1)
    sourceIndexByCharacter(1, 0) = 0

    Dim deleteDistance As Double
    Dim insertDistance As Double
    Dim matchDistance As Double

    For i = 1 To Len(source) - 1

        deleteDistance = table(i - 1, 0) + deleteCost
        insertDistance = ((i + 1) * deleteCost) + insertCost

        If Mid(source, i + 1, 1) = Left(target, 1) Then
            matchDistance = (i * deleteCost) + 0
        Else
            matchDistance = (i * deleteCost) + replaceCost
        End If

        table(i, 0) = aMin(aMin(deleteDistance, insertDistance), matchDistance)
    Next

    For j = 1 To Len(target) - 1

        deleteDistance = table(0, j - 1) + insertCost
        insertDistance = ((j + 1) * insertCost) + deleteCost

        If Left(source, 1) = Mid(target, j + 1, 1) Then
            matchDistance = (j * insertCost) + 0
        Else
            matchDistance = (j * insertCost) + replaceCost
        End If

        table(0, j) = aMin(aMin(deleteDistance, insertDistance), matchDistance)
    Next

    For i = 1 To Len(source) - 1

        Dim maxSourceLetterMatchIndex As Long

        If Mid(source, i + 1, 1) = Left(target, 1) Then
            maxSourceLetterMatchIndex = 0
        Else
            maxSourceLetterMatchIndex = -1
        End If

        For j = 1 To Len(target) - 1

            Dim candidateSwapIndex As Long
            candidateSwapIndex = -1

            For k = 0 To UBound(sourceIndexByCharacter, 2)
                If sourceIndexByCharacter(0, k) = Mid(target, j + 1, 1) Then candidateSwapIndex = sourceIndexByCharacter(1, k)
            Next

            Dim jSwap As Long
            jSwap = maxSourceLetterMatchIndex

            deleteDistance = table(i - 1, j) + deleteCost
            insertDistance = table(i, j - 1) + insertCost
            matchDistance = table(i - 1, j - 1)

            If Mid(source, i + 1, 1) <> Mid(target, j + 1, 1) Then
                matchDistance = matchDistance + replaceCost
            Else
                maxSourceLetterMatchIndex = j
            End If

            Dim swapDistance As Double

            If candidateSwapIndex <> -1 And jSwap <> -1 Then

                Dim iSwap As Long
                iSwap = candidateSwapIndex

                Dim preSwapCost
                If iSwap = 0 And jSwap = 0 Then
                    preSwapCost = 0
                Else
                    preSwapCost = table(aMax(0, iSwap - 1), aMax(0, jSwap - 1))
                End If

                swapDistance = preSwapCost + ((i - iSwap - 1) * deleteCost) + ((j - jSwap - 1) * insertCost) + swapCost

            Else
                swapDistance = 500
            End If

            table(i, j) = aMin(aMin(aMin(deleteDistance, insertDistance), matchDistance), swapDistance)

        Next

        sourceIndexByCharacter(0, i) = Mid(source, i + 1, 1)
        sourceIndexByCharacter(1, i) = i

    Next

    WeightedDL = table(Len(source) - 1, Len(target) - 1)

End Function
'======================================================================
' 最小値
'======================================================================
Private Function aMin(v1 As Double, v2 As Double) As Double
    If v1 < v2 Then
        aMin = v1
    Else
        aMin = v2
    End If
End Function

'======================================================================
' 最大値
'======================================================================
Private Function aMax(v1 As Double, v2 As Double) As Double
    If v1 < v2 Then
        aMax = v2
    Else
        aMax = v1
    End If
End Function

実行方法

MS-Wordのリボンに表示されている「表記揺れ」ボタンをクリックしてください。

最初、形態素解析の進捗を示すプログレスバーか表示されます。

次に、Excelワークシートへの結果出力の進捗を示すプログレスバーが表示されます。

Excelが起動していますので、そのワークシートを確認してください。表記揺れの可能性のある文字列のペアが各カラムに表示されます。

後書き

深夜の或る特許事務所、ワイ君は「Word版リント君」のコーディングとテストに励むのであった。

ワイ「所長にお小言を言われた部分を、このツールでチェックしたで」
ワイ「やった！【インタフェース】【インターフェース】【インターフェイス】の表記揺れを検出できたで！」
ワイ「【トラフィック】【トラヒック】もＯＫや」
ワイ「【ダイヤル】と【ダイアル】もや。」
ワイ「２つの文字列の組合せが重複して表示されるのはご愛敬やが、
　　　これも対処した方がええやろなあ。」
　　　・・・・

ワイ「【行なう】と【行う】は抽出してくれんなあ。
　　　両方とも「おこなう」の読みやから、表記が類似して読みが同じなら表記揺れやと判定すればええんやろうけど、
　　　IWordBreaker やのうて、ちゃんとした形態素解析エンジンでないとできんなあ。」
ワイ「【ギア】と【ギヤ】も抽出してくれんなあ。
　　　２文字中１文字の違いやと、５０％やから無理やなあ。判定範囲外や。
　　　ローマ字で書けば、giyaとgiaやから、４文字中１文字違い、２５％で似てるのになあ。
　　　せや、かな文字の比較はローマ字に変換してからDamerau-Levenshtein距離をとれば・・・。
　　　次のバージョンの課題やな。」

ワイ「パワポエンジニアの憂鬱の例題も試したろ」

ワイ「とりあえず全部リストアップ出来とるみたいやな。」

ワイ「他の公報とかも試したろ。特開2010-130410や。」

ワイ「【ＭＦＰｌ０】【ＭＰＦ１０】の誤記が拾えたのはよかったで。」
ワイ「でも、用言の変化をもろに拾ってるなあ。
　　【問い合わせる】と【問い合わせ】とかを表記揺れとされるのは痛いなあ。
　　やっぱり形態素解析して、名詞に限らんといかんかなぁ。」
ワイ「名詞も【プリンタドライバ】と【プリンタドライバ上】が表記揺れとされとる。
　　　IWordBreakerの癖で、名詞に接尾辞をつけてしまうんやろうなあ。」