このマクロは、ワードのチェック機能（スペルチェックと文章校正）でチェックできるワード文書中の誤字脱字をエクセルファイルに出力して一覧にするマクロ（Word VBA）です。
ワードの標準機能である「スペルチェックと文章校正」は便利な機能ですが、誤字脱字が疑われる箇所をいちいち１つ１つチェックするのは面倒です。
このマクロを使用すると、ワード文書中で誤字脱字が疑われる箇所が一覧になってエクセルファイルに出力されるため、誤字脱字箇所を集中的にチェックすることが可能になります。
このマクロの概要を以下にイラストで示します。
【スポンサーリンク】
マクロの全体の流れ
step
1各自のワードファイルを開きます
step
2ワード文書の左上に表示される本マクロのアイコンをクリックします
（アイコンの種類は各自が選べます。詳細は、後述の「マクロの使用準備」をご参照ください）
step
3モードを選択します
以下の入力ボックスが出ます。
モード選択については後述します。
モード番号を入力後に「OK」ボタンを押します。
確認メッセージがでるので、「はい」を選択します。
「はい」を選択すると、誤字脱字が疑われる箇所の自動収集が始まります。
処理中はワード文書の左下に、以下のように進行状況が表示されます。
処理が終了すると、以下のようなエクセルファイルが開きます。
このエクセルファイルはデスクトップ上に保存されています。
ファイル名は、「○○_誤字脱字_モード_YYYYMMDDHHMMSS.xlsx」という形式になります。
〇〇はチェック対象のワードファイルの名前です。
例えば、テスト.docxで本マクロを実行すると、テスト_誤字脱字一覧_スペル + 文法_20241004114657.xlsxという名前のエクセルファイルが出力されます。
ファイル名の末尾はHHMMSS（HH時MM分SS秒）となるため、既存のファイルが上書きされることはありません。
以上が全体の流れです！
マクロの詳細な説明
本マクロの処理モード
本マクロには、以下の３つのモードがあります。
１：スペルチェック
２：文法チェック
３：スペルチェック＋文法チェック
いずれのモードも、ワードの標準機能の「スペルチェックと文章校正」を使用します。
１：スペルチェック
半角英語のスペルミスが疑われる箇所を検出します。
ワード文書中で半角英字に赤線が引かれる箇所が検出されます。
例えば、以下のような箇所が検出されます。
半角英字がほぼ存在しない日本語メインの全角文字列のワード文書では、検出されることは稀なはずです。
英語のワードファイルでは、スペルミスの発見に有効です。
但し、マイナーな地名や独特の略語などもスペルミスとして検出されるため、ざっと見た感じで赤線部が多いワードファイルでは処理に時間がかかります。
そうしたものや、数百ページのワード文書をチェックしたい場合は、処理時間の長時間化をさけるために、ワード文書を分割後に本マクロを適用することをご検討ください。
ワード文書の分割には、以下のマクロが便利です。
２：文法チェック
文法的な間違いが疑われる箇所を検出します。
ワード文書中で赤線（主に全角文字列）と青線（主に半角文字列）が引かれる箇所が検出されます。
（表記ゆれは検出されません）
例えば、以下のような間違い箇所が検出されます。
（上記の英文では、半角スペースが連続して２つ存在するために文法ミスとして青線が引かれています）
このモードも、ページ数や誤字脱字箇所の多さに応じて処理時間がかかる場合があります。
場合によっては、ワード文書を分割することをご検討ください。
ワード文書の分割には、上に紹介した記事のマクロが便利です。
３：スペルチェック＋文法チェック
モード３では、スペルチェックと文法チェックを連続して行います。
各チェックの結果は、各チェックを独立して実施した場合と同じです。
このモードは３つのモード中で一番時間がかかります。
そのため、最初にモード１とモード２を実施し、許容できる処理時間であることを確認してから行うようにしてください
場合によっては、ワード文書の分割をご検討ください。
ワード文書の分割には、上に紹介した記事のマクロが便利です。
結果のエクセルファイル
結果のエクセルファイルの内容は以下のような感じです。
各列ごとに説明します。
番号
「番号」は、誤字脱字が疑われる箇所の連番を示します。
モード１とモード２では、この番号は、誤字脱字が疑われる箇所のワード文書での登場順序に対応します。
ページと行数
「ページ」と「行数」は、誤字脱字が疑われる箇所（後述の「誤字脱字」列）を含むパラグラフの最初の１文字が何ページ目の何行目にあるかを示します（「誤字脱字」そのものの位置ではないことにご注意ください）。
頻度
「頻度」は、誤字脱字が疑われる箇所がその文書の中で何回登場するかを示します。
種別
スペルチェックで検出されたものは、「種別」が「スペル」と表示されます。
文法チェックで検出されたものは、「種別」が「文法」になります。
誤字脱字
「誤字脱字」は、誤字脱字が疑われる文字列です。
「種別」が「スペル」の「誤字脱字」は、ワードの標準機能で認識されるスペルミスそのものです。
「種別」が「文法」の「誤字脱字」は、本マクロのアルゴリズムで特定されたものです。
アルゴリズムを使用している理由は、Word標準機能では文法チェックでヒットする単位がパラグラフ単位であり、その中のどの部分が問題なのかを標準機能では特定できないためです。
本マクロのアルゴリズムでは、ヒットパラグラフ単位を左右から削っていき、文法チェックでのエラーがでなくなった位置を手掛かりに「誤字脱字」を特定しています。
そのため、稀に、誤字脱字が疑われる箇所と少しずれた箇所が「誤字脱字」として特定されてしまうことがあります。
より正確には、後述の「リンク２」からワード文書中の該当部分へジャンプして確認してください。
周辺文字列
「周辺文字列」は、「誤字脱字」にその左右の文字列を含めたものです。
「誤字脱字」の左側と右側の文字数を何文字まで表示させるかは、後述の本マクロのコードの中の以下の赤線部で任意の値（0以上の整数）を設定できます。
この値は、最大数です。
デフォルト値は５０です。
０を設定すると、「誤字脱字」左右の表示文字数が０になり、結果的に周辺文字列の列は「誤字脱字」のみになります。
但し、「誤字脱字」でも説明しましたように、種別が「文法」の「誤字脱字」は、本マクロのアルゴリズムで特定していることから、たまに、本来の箇所と少しずれた箇所が「誤字脱字」として特定されることがあるため、０を設定することは推奨されません。
同じ問題パラグラフ中に「誤字脱字」が複数存在する場合は、一番左に位置する「誤字脱字」の左側と一番右に位置するの「誤字脱字」の右側にこの最大文字数設定値が適用されます。
デフォルト値は５０ですが、日本語の文書では２０～３０くらいでもいいかもしれません。
好みに合わせて設定してください。
設定値が５０の場合は、以下のような感じになります。
「誤字脱字」の左右の文字列の文字数が最大設定値以下の場合は、削られることなくそのままの数の文字数が表示されます。
リンク１とリンク２
リンク１をクリックすると、H列の「誤字脱字」の文字列を検索キーとして出力元ワードファイルにジャンプします。
そのため、「誤字脱字」の文字列がワード文書中に複数存在する場合（「頻度」の列の数が２以上の場合）は、常にワード文書中の最初のヒット部にジャンプしてしまいます。
リンク２をクリックすると、I列の「周辺文字列」の一部を検索キーとして出力元ワードファイルにジャンプするため、リンク２の方が精度が高いです。
これらのリンクがマクロで作成できなかった場合は「利用不可」と表示されます。
「誤字脱字」にタブが含まれている場合などは、リンクが機能しないこともあります。
【スポンサーリンク】
補足説明
チェック対象のワード文書について
本マクロとは無関係に、一般的に、新たに入手／コピーしたワードファイルを開くと、以下のように「編集を有効にする」というボタンが表示される場合があります。
本マクロは、チェック対象のワードファイルを変更するものではありませんが、本マクロが動作するには「編集を有効にする」を押す必要があります。
また、本マクロはチェック対象のワードファイルを変更するものではありませんが、念のためワードファイルの事前バックアップをお願いします。
チェック開始時に稀に表示されるメッセージについて
本マクロを使用して処理を開始すると、以下のようなメッセージが出る場合があります。
このメッセージは、本マクロが出しているものではなく、本マクロがワードの標準チェック機能を呼び出したときに表示されるものです。
手動で「スペルチェックと文章校正」を行った場合でも表示されるものです。
この例のメッセージの意味は、「○○語（この例では、ワードがスペイン語と判断する文字列）がワード文書中にありますが、その校正ツールはインストールされていません」というお知らせです。
この場合は、OKボタンを教えて下さい。
処理は続行されます。
通常、チェック対象としたい言語は英語と日本語だと思いますが、
本当にスペイン語がメインの文書をチェックしたい場合は、スペイン語（またはチェックしたい他の言語）の校正ツールをインストールするとよいと思います。
テストはしていませんが、おそらく出力エクセルに誤字脱字箇所が入ってくると思います。
マクロの準備
以下の手順を行うことで、各自のワードファイルから本マクロを簡単に呼び出せるようになります。
１．こちらの記事に記載したステップ①の手順０～６までを実施した後、ステップ①の手順７で、この記事の最後にあるコードを標準モジュールのＭodule1にコピペします。
２．こちらの記事に記載したステップ①の８から２２を行います
（ステップ①の１１では、以下のマクロ名を選択してから、追加ボタンを押してください）
Project.Module1.ExportTyposToExcel
ステップ①の１１で追加するのは、上記のマクロ名のみです。
（ステップ①の１３では、お好きなアイコンを選んでください）
（ステップ①の２０での保存名は何でもかまいません）
（ステップ①の２２の次に記載されている「動作確認」はスキップしていただいてかまいません）
３．こちらの記事に記載したステップ②を行います
ステップ②を行うことで、このマクロをどのワード文書からも呼び出せるようになります。
（このステップ②を行うと、各自のワードファイルを開いた際に、各自が選んだマクロアイコンがワード文書の左上に表示されるようになります）
以上で、マクロを使用する準備が整いました！
【スポンサーリンク】
マクロの削除
本マクロが不要になった場合は、こちらの手順でdotmファイルごと削除してください。
マクロのコード
以下は、本マクロのコードです。
上の説明にあるように標準モジュールにコピペしてご使用ください。
（以下のコードをすべて選択して、そのまま貼り付けてください）
現在の公開バージョンは、V01L01（公開日：2024/10/04）です。
Sub ExportTyposToExcel()
' V01L01
Dim doc As Document
Dim rng As Range
Dim errCount As Long
Dim errText As String
Dim errPage As Long
Dim excelApp As Object
Dim workbook As Object
Dim worksheet As Object
Dim desktopPath As String
Dim fileName As String
Dim baseName As String
Dim extCount As Long
Dim fullPath As String
Dim typoLine As String
Dim contextLength As Long
Dim spellingErrors As ProofreadingErrors
Dim grammarErrors As ProofreadingErrors
Dim pageInfo As Variant
Dim lineInfo As Variant
Dim errFrequency As Long
Dim typoDict As Object
Dim typoCounterForSpellingErrors As Long
Dim typoCounterForGrammarErrors As Long
Dim linkAddress1 As String
Dim linkAddress2 As String
Dim inputBoxValue As Variant
Dim totalSpellingErrors As Long
Dim totalGrammarErrors As Long
Dim currentDate As String
Dim OutputModeMessage As String
Dim msgBoxValue As Integer
Dim spellCell As Object
Dim GrammaticalErrorText As String
Dim iForTotal As Integer
Dim totalPages As Long
Dim uncPath As String
Dim typoLineForSearch As String
Dim link2ErrFlgForSpelErr As Boolean
Dim hasSpecialChars As Boolean
Dim dt As Date
' 未保存の変更をチェック
If ActiveDocument.Saved = False Then
MsgBox "このドキュメントには未保存の変更があります。" _
& vbCrLf & "保存後に再度処理を実行してください。", vbInformation, "未保存の変更あり"
Exit Sub
End If
' ★「誤字脱字」の前後の文字列を最大何文字表示するかを半角整数で指定してください★
' デフォルト値は50です。
contextLength = 50
' 最終ページの取得
totalPages = ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
Do
'入力ボックスの表示
inputBoxValue = InputBox _
("モードを数字（半角でも全角でも可）で入力してください" _
& vbCrLf & vbCrLf & "1：スペルチェック" _
& vbCrLf & vbCrLf & "2：文法チェック" _
& vbCrLf & vbCrLf & "3：スペルチェック+文法チェック" _
& vbCrLf & vbCrLf & "このワード文書のページ数：" & totalPages _
& vbCrLf, "モード選択")
'キャンセルの場合は終了
If StrPtr(inputBoxValue) = 0 Then
Exit Sub
ElseIf inputBoxValue = "" Then
MsgBox "数字を入力してください"
ElseIf inputBoxValue <> "" Then
Exit Do
End If
Loop
If inputBoxValue <> 1 And inputBoxValue <> 2 And inputBoxValue <> 3 Then
MsgBox "無効な入力値です。1～3の整数を入力してください。", vbCritical, "エラー"
Exit Sub
End If
Select Case inputBoxValue
Case 1
OutputModeMessage = "スペルチェックを開始します" _
& vbCrLf & "よろしいですか？"
Case 2
OutputModeMessage = "文法チェックを開始します" _
& vbCrLf & "よろしいですか？"
Case 3
OutputModeMessage = "スペルチェック + 文法チェックを開始します" _
& vbCrLf & "よろしいですか？"
End Select
msgBoxValue = MsgBox(OutputModeMessage, vbYesNo + vbQuestion + vbDefaultButton2, "確認")
If msgBoxValue = vbNo Then Exit Sub
' 現在のドキュメントを設定
Set doc = ActiveDocument
' ドキュメントが保存されていない場合、保存を促す
If doc.Path = "" Then
MsgBox "ドキュメントが保存されていません。まずドキュメントを保存してください。"
Exit Sub
End If
Application.StatusBar = "処理を開始しました"
' ドキュメントのフルパスをUNCパスで取得
uncPath = ConvertToUNC(doc)
hasSpecialChars = (InStr(uncPath, "[") > 0) Or (InStr(uncPath, "]") > 0)
If hasSpecialChars = True Then
MsgBox "このワードファイルのファイル名には、 [ または ] が使用されています。ファイルの名前を変更してから再度実行してください"
Set doc = Nothing
Exit Sub
End If
' デスクトップのパス取得
desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
' ドキュメント名から拡張子を除去し、ベースファイル名を設定
baseName = Left(doc.Name, InStrRev(doc.Name, ".") - 1) & "_誤字脱字一覧"
' モード名を付与
Select Case inputBoxValue
Case 1
baseName = baseName & "_スペル"
Case 2
baseName = baseName & "_文法"
Case 3
baseName = baseName & "_スペル + 文法"
End Select
dt = Now
fileName = baseName & "_" & Year(dt) & Right("0" & Month(dt), 2) & Right("0" & Day(dt), 2) _
& Right("0" & Hour(dt), 2) & Right("0" & Minute(dt), 2) & Right("0" & Second(dt), 2) & ".xlsx"
fullPath = desktopPath & "\" & fileName
' 誤字脱字の総数を取得
Select Case inputBoxValue
Case 1
Set spellingErrors = doc.spellingErrors
Application.StatusBar = "スペルチェック箇所の総数を取得しています"
totalSpellingErrors = spellingErrors.count
Case 2
Set grammarErrors = doc.GrammaticalErrors
Application.StatusBar = "文法チェック箇所の総数を取得しています"
totalGrammarErrors = grammarErrors.count
Case 3
Set spellingErrors = doc.spellingErrors
Set grammarErrors = doc.GrammaticalErrors
Application.StatusBar = "スペルチェック箇所の総数を取得しています"
totalSpellingErrors = spellingErrors.count
Application.StatusBar = "文法チェック箇所の総数を取得しています"
totalGrammarErrors = grammarErrors.count
End Select
DoEvents
Select Case inputBoxValue
Case 1
If totalSpellingErrors = 0 Then
MsgBox "スペルミスが疑われる箇所はありません。"
Exit Sub
End If
Case 2
If totalGrammarErrors = 0 Then
MsgBox "文法ミスが疑われる箇所はありません。"
Exit Sub
End If
Case 3
If totalSpellingErrors + totalGrammarErrors = 0 Then
MsgBox "誤字脱字が疑われる箇所はありません。"
Exit Sub
End If
End Select
' 誤字脱字をカウントするためのDictionaryを用意
Set typoDict = CreateObject("Scripting.Dictionary")
' 再度各誤字脱字総数を代入（総数が正確に反映されないバグ防止）
Application.StatusBar = "誤字脱字総数をセットしています"
For iForTotal = 1 To 10
Select Case inputBoxValue
Case 1
totalSpellingErrors = spellingErrors.count
Case 2
totalGrammarErrors = grammarErrors.count
Case 3
totalSpellingErrors = spellingErrors.count
totalGrammarErrors = grammarErrors.count
End Select
Next iForTotal
typoCounterForSpellingErrors = 0
typoCounterForGrammarErrors = 0
If inputBoxValue = 1 Or inputBoxValue = 3 Then
' スペルチェックを実行して要チェック箇所を辞書に追加
For Each rng In spellingErrors
errText = rng.Text
typoCounterForSpellingErrors = typoCounterForSpellingErrors + 1
DoEvents
Application.StatusBar = "スペルチェック箇所を集めています（" _
& typoCounterForSpellingErrors & "/" & totalSpellingErrors & "）"
If typoDict.Exists(errText) Then
typoDict(errText) = typoDict(errText) + 1
Else
typoDict.Add errText, 1
End If
Next rng
End If
If inputBoxValue = 2 Or inputBoxValue = 3 Then
' 文法チェックを実行して要チェック箇所を辞書に追加
For Each rng In grammarErrors
errText = rng.Text
typoCounterForGrammarErrors = typoCounterForGrammarErrors + 1
DoEvents
Application.StatusBar = "文法チェック箇所を集めています（" _
& typoCounterForGrammarErrors & "/" & totalGrammarErrors & "）"
If typoDict.Exists(errText) Then
typoDict(errText) = typoDict(errText) + 1
Else
typoDict.Add errText, 1
End If
Next rng
End If
Application.StatusBar = "エクセルファイルの準備をしています"
' Excelアプリケーションを起動
Set excelApp = CreateObject("Excel.Application")
Set workbook = excelApp.Workbooks.Add
Set worksheet = workbook.Sheets(1)
' シートのヘッダを設定
worksheet.Cells(1, 1).Value = "番号"
worksheet.Cells(1, 2).Value = "ページ"
worksheet.Cells(1, 3).Value = "行数"
worksheet.Cells(1, 4).Value = "頻度"
worksheet.Cells(1, 5).Value = "リンク1"
worksheet.Cells(1, 6).Value = "リンク2"
worksheet.Cells(1, 7).Value = "種別"
worksheet.Cells(1, 8).Value = "誤字脱字"
worksheet.Cells(1, 9).Value = "周辺文字列"
errCount = 2
If inputBoxValue = 1 Or inputBoxValue = 3 Then
' スペルチェックをエクスポート
For Each rng In spellingErrors
DoEvents
Application.StatusBar = "処理中: " & errCount - 1 & " / " & _
totalSpellingErrors & " のスペルチェック箇所を処理しています"
' ページと行の情報を取得
pageInfo = GetFirstCharacterPageNumber(rng)
lineInfo = rng.Information(wdFirstCharacterLineNumber)
' 誤字脱字を取得
errText = rng.Text
errFrequency = typoDict(errText)
typoLine = rng.Paragraphs(1).Range.Text
' お尻の改行を削る
If Right(typoLine, 1) = vbCrLf Or Right(typoLine, 1) = vbCr Or Right(typoLine, 1) = vbLf Then
typoLine = Left(typoLine, Len(typoLine) - 1)
End If
' typoLineの左右のトリミング
If InStr(typoLine, errText) > contextLength + 1 Then
typoLine = Right(typoLine, Len(typoLine) - (InStr(typoLine, errText) - contextLength - 1))
End If
If Len(typoLine) - (InStrRev(typoLine, errText) + Len(errText)) > contextLength Then
typoLine = Left(typoLine, InStrRev(typoLine, errText) + Len(errText) + contextLength - 1)
End If
' リンク１の作成（誤字脱字のみを検索キーとする）
linkAddress1 = uncPath & "#" & errText
' リンク２の作成（誤字脱字を含む１行を検索キーとする）
typoLineForSearch = typoLine
' 左右の不要文字をカット
typoLineForSearch = RemoveSpecificCharacterOnTheLeftandRight(typoLineForSearch, errText, Chr(7))
typoLineForSearch = RemoveSpecificCharacterOnTheLeftandRight(typoLineForSearch, errText, vbTab)
typoLineForSearch = RemoveSpecificCharacterOnTheLeftandRight(typoLineForSearch, errText, vbCr)
typoLineForSearch = RemoveSpecificCharacterOnTheLeftandRight(typoLineForSearch, errText, vbLf)
' 120字以上は右側をカット
If Len(typoLineForSearch) > 120 Then
typoLineForSearch = Left(typoLineForSearch, 120)
End If
With worksheet
.Cells(errCount, 1).Value = errCount - 1
.Cells(errCount, 2).Value = pageInfo
.Cells(errCount, 3).Value = lineInfo
.Cells(errCount, 4).Value = errFrequency
' リンク１の処理
On Error Resume Next
.Cells(errCount, 5).Formula = "=HYPERLINK(""" & linkAddress1 & """, ""リンク１"")"
If Err.Number <> 0 Then
.Cells(errCount, 5).Value = "利用不可"
End If
On Error GoTo 0
' リンク2の処理
Dim originalLink2 As String
originalLink2 = typoLineForSearch
link2ErrFlgForSpelErr = True
' リンクに使用できない文字列に備える
' エラーが出た場合は右から削る
Do While Len(typoLineForSearch) >= 10
On Error Resume Next
.Cells(errCount, 6).Formula = "=HYPERLINK(""" & uncPath & "#" & typoLineForSearch & """, ""リンク２"")"
If Err.Number = 0 Then
link2ErrFlgForSpelErr = False
Exit Do
End If
On Error GoTo 0
typoLineForSearch = Left(typoLineForSearch, Len(typoLineForSearch) - 1)
Loop
' まだエラーがある場合は左から削る
If link2ErrFlgForSpelErr = True Then
typoLineForSearch = originalLink2
Do While Len(typoLineForSearch) >= 10
On Error Resume Next
.Cells(errCount, 6).Formula = "=HYPERLINK(""" & uncPath & "#" & typoLineForSearch & """, ""リンク２"")"
If Err.Number = 0 Then
Exit Do
End If
On Error GoTo 0
typoLineForSearch = Right(typoLineForSearch, Len(typoLineForSearch) - 1)
Loop
End If
On Error Resume Next
.Cells(errCount, 6).Formula = "=HYPERLINK(""" & uncPath & "#" & typoLineForSearch & """, ""リンク２"")"
If Err.Number <> 0 Then
.Cells(errCount, 6).Value = "利用不可"
End If
On Error GoTo 0
.Cells(errCount, 7).Value = "スペル"
.Cells(errCount, 8).Value = "'" & errText
.Cells(errCount, 8).Font.Color = RGB(255, 0, 0)
.Cells(errCount, 8).Font.Bold = True
.Cells(errCount, 9).Value = "'" & typoLine
End With
' スペルミスのハイライト処理
Set spellCell = worksheet.Cells(errCount, 9)
' spellCell.Valueに複数のerrTextが含まれている場合、順次処理
Dim errPosInCell As Long
errPosInCell = InStr(1, spellCell.Value, errText)
Do While errPosInCell > 0
With spellCell.Characters(Start:=errPosInCell, Length:=Len(errText)).Font
.Color = RGB(255, 0, 0) ' 赤色
.Bold = True ' 太字
End With
' 次のerrTextを探す
errPosInCell = InStr(errPosInCell + Len(errText), spellCell.Value, errText)
Loop
errCount = errCount + 1
Next rng
End If
errCount = 2
If inputBoxValue = 2 Or inputBoxValue = 3 Then
' 文法チェックをエクスポート
For Each rng In grammarErrors
DoEvents
' ページと行の情報を取得
pageInfo = GetFirstCharacterPageNumber(rng)
lineInfo = rng.Information(wdFirstCharacterLineNumber)
' 誤字脱字を含むテキスト
errText = rng.Text
' 頻度を取得
errFrequency = typoDict(errText)
' アルゴリズムで文法的な誤字脱字を取得
Application.ScreenUpdating = False
GrammaticalErrorText = GetGrammaticalErrorText(errText)
Application.ScreenUpdating = True
Application.StatusBar = "処理中: " & errCount - 1 & " / " & _
totalGrammarErrors & " の文法チェック箇所を処理しています"
' GrammaticalErrorTextの左右のトリミング
If InStr(errText, GrammaticalErrorText) > contextLength + 1 Then
errText = Right(errText, Len(errText) - (InStr(errText, GrammaticalErrorText) - contextLength - 1))
End If
If Len(errText) - (InStrRev(errText, GrammaticalErrorText) + Len(GrammaticalErrorText)) > contextLength Then
errText = Left(errText, InStrRev(errText, GrammaticalErrorText) + Len(GrammaticalErrorText) + contextLength - 1)
End If
' リンク１の作成
linkAddress1 = uncPath & "#" & GrammaticalErrorText
' リンク２の作成
' 左右の不要文字の除去
typoLineForSearch = RemoveSpecificCharacterOnTheLeftandRight(errText, GrammaticalErrorText, Chr(7))
typoLineForSearch = RemoveSpecificCharacterOnTheLeftandRight(errText, GrammaticalErrorText, vbTab)
' 120超はカット
If Len(typoLineForSearch) > 120 Then
linkAddress2 = uncPath & "#" & Left(typoLineForSearch, 120)
Else
linkAddress2 = uncPath & "#" & typoLineForSearch
End If
With worksheet
.Cells(errCount + totalSpellingErrors, 1).Value = errCount + totalSpellingErrors - 1
.Cells(errCount + totalSpellingErrors, 2).Value = pageInfo
.Cells(errCount + totalSpellingErrors, 3).Value = lineInfo
.Cells(errCount + totalSpellingErrors, 4).Value = errFrequency
On Error Resume Next
.Cells(errCount + totalSpellingErrors, 5).Formula = "=HYPERLINK(""" & linkAddress1 & """, ""リンク１"")"
If Err.Number <> 0 Then
.Cells(errCount + totalSpellingErrors, 5).Value = "利用不可"
End If
On Error GoTo 0
On Error Resume Next
.Cells(errCount + totalSpellingErrors, 6).Formula = "=HYPERLINK(""" & linkAddress2 & """, ""リンク２"")"
If Err.Number <> 0 Then
.Cells(errCount + totalSpellingErrors, 6).Value = "利用不可"
End If
On Error GoTo 0
.Cells(errCount + totalSpellingErrors, 7).Value = "文法"
.Cells(errCount + totalSpellingErrors, 8).Value = "'" & GrammaticalErrorText
.Cells(errCount + totalSpellingErrors, 8).Font.Color = RGB(255, 0, 0)
.Cells(errCount + totalSpellingErrors, 8).Font.Bold = True
.Cells(errCount + totalSpellingErrors, 9).Value = "'" & errText
End With
' スペルミスのハイライト処理
Set spellCell = worksheet.Cells(errCount + totalSpellingErrors, 9)
With spellCell.Characters(Start:=InStr(1, errText, GrammaticalErrorText), _
Length:=Len(GrammaticalErrorText)).Font
.Color = RGB(255, 0, 0) ' 赤色
.Bold = True ' 太字
End With
errCount = errCount + 1
Next rng
End If
currentDate = Format(Now, "yyyy年mm月dd日 hh時nn分")
worksheet.Name = currentDate
workbook.SaveAs fullPath
Application.StatusBar = "終了処理をしています"
Set worksheet = Nothing
Set workbook = Nothing
Set spellingErrors = Nothing
Set grammarErrors = Nothing
Set rng = Nothing
Set doc = Nothing
Set typoDict = Nothing
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
excelApp.Visible = True
Documents.Open fileName:=uncPath
Application.StatusBar = "処理が終了しました！" & " 出力エクセルファイルはデスクトップに保存されています"
End Sub
Function GetGrammaticalErrorText(inputText As String) As String
Dim errorRange As Range
Dim startPos As Long, endPos As Long
Dim rightPos As Long, leftPos As Long
Dim errorText As String, testText As String
Dim containsError As Boolean
Dim i As Long, step As Long
Dim leftCounter As Long
Dim tempDoc As Document
Dim stepSearch1 As Integer
Dim stepSearch2 As Integer
Dim stepSearch3 As Integer
Set tempDoc = Documents.Add(Template:="", NewTemplate:=False, DocumentType:=0)
tempDoc.Windows(1).Visible = False
' 初期化
errorText = ""
stepSearch1 = 10
stepSearch2 = 20
stepSearch3 = 40
step = 0
' 最適なトリミング単位を決定
If stepSearch1 < Len(inputText) Then
tempDoc.Content.Text = Mid(inputText, stepSearch1, Len(inputText) - stepSearch1)
If tempDoc.GrammaticalErrors.count > 0 Then
step = stepSearch1
End If
End If
If stepSearch2 < Len(inputText) Then
tempDoc.Content.Text = Mid(inputText, stepSearch2, Len(inputText) - stepSearch2)
If tempDoc.GrammaticalErrors.count > 0 Then
step = stepSearch2
End If
End If
If stepSearch3 < Len(inputText) Then
tempDoc.Content.Text = Mid(inputText, stepSearch3, Len(inputText) - stepSearch3)
If tempDoc.GrammaticalErrors.count > 0 Then
step = stepSearch3
End If
End If
If step = 0 Then
step = 20
End If
' 文法エラーのある範囲を取得
tempDoc.Content.Text = inputText
If tempDoc.GrammaticalErrors.count > 0 Then
Set errorRange = tempDoc.Content.GrammaticalErrors(1)
' 文法エラーの範囲の開始位置と終了位置を取得
startPos = errorRange.Start
endPos = errorRange.End
Else
GetGrammaticalErrorText = "利用不可"
tempDoc.Close SaveChanges:=wdDoNotSaveChanges
Exit Function
End If
' 右側から削る処理
rightPos = endPos
Do While rightPos >= startPos
testText = Mid(inputText, startPos + 1, rightPos - startPos)
tempDoc.Content.Text = testText
containsError = (tempDoc.GrammaticalErrors.count > 0)
If Not containsError Then
' エラーがなくなったらstep分戻る
rightPos = rightPos + step
If rightPos > endPos Then rightPos = endPos
' 1文字ずつ削って正確な位置を特定
Do While rightPos > startPos
testText = Mid(inputText, startPos + 1, rightPos - startPos)
tempDoc.Content.Text = testText
containsError = (tempDoc.GrammaticalErrors.count > 0)
If containsError Then
rightPos = rightPos - 1
Else
Exit Do
End If
Loop
rightPos = rightPos + 1 ' エラーが発生する直前の位置に戻す
Exit Do
End If
rightPos = rightPos - step
If rightPos < startPos Then rightPos = startPos
Loop
' 左側から削る処理
leftPos = startPos
leftCounter = 0
Do While leftPos <= rightPos
testText = Mid(inputText, leftPos + 1, Len(inputText) - leftCounter)
tempDoc.Content.Text = testText
containsError = (tempDoc.GrammaticalErrors.count > 0)
If Not containsError Then
' エラーがなくなったらstep分戻る
leftPos = leftPos - step
If leftPos < startPos Then leftPos = startPos
' 1文字ずつ削って正確な位置を特定
Do While leftPos < rightPos
testText = Mid(inputText, leftPos + 1, Len(inputText) - leftCounter)
tempDoc.Content.Text = testText
containsError = (tempDoc.GrammaticalErrors.count > 0)
If containsError Then
leftPos = leftPos + 1
Else
Exit Do
End If
Loop
leftPos = leftPos - 1 ' エラーが発生する直前の位置に戻す
Exit Do
End If
leftPos = leftPos + step
If leftPos > rightPos Then leftPos = rightPos
leftCounter = leftCounter + 1
Loop
If leftPos < 0 Then leftPos = 0
errorText = Mid(inputText, leftPos + 1, rightPos - leftPos)
' 先頭の空白文字を削除
Do While (Left(errorText, 1) = " " Or Left(errorText, 1) = " " Or Left(errorText, 1) = vbTab)
If errorText = "" Then Exit Do
leftPos = leftPos + 1
errorText = Mid(inputText, leftPos, rightPos - leftPos)
Loop
' 文法エラーがない場合
If errorText = "" Then
errorText = "利用不可"
End If
tempDoc.Close SaveChanges:=wdDoNotSaveChanges
Set tempDoc = Nothing
' エラー部分のテキストを返す
GetGrammaticalErrorText = errorText
End Function
Function ConvertToUNC(doc As Document) As String
Dim fso As Object
Dim drv As Object
Dim uncPath As String
Dim localPath As String
localPath = doc.FullName
' 先頭にコンピューター名が入っている場合は除去
If Left(localPath, 2) = "\\" Then
' 3番目の\から後ろの文字列を切り出す
Dim thirdBackslash As Long
thirdBackslash = InStr(InStr(InStr(localPath, "\") + 1, localPath, "\") + 1, localPath, "\")
localPath = Mid(localPath, thirdBackslash + 1)
' localPath中の$を:に変換
localPath = Replace(localPath, "$", ":")
End If
Set fso = CreateObject("Scripting.FileSystemObject")
' ドライブ文字を取得
Dim driveLetter As String
driveLetter = Left(localPath, 2)
' ネットワークドライブの場合
If fso.GetDrive(driveLetter).DriveType = 3 Then ' 3 はネットワークドライブ
Set drv = fso.GetDrive(driveLetter)
uncPath = drv.ShareName & Mid(localPath, 3)
Else
' ローカルドライブの場合、コンピューター名を取得してUNCパスを構築
uncPath = "\\" & Environ$("COMPUTERNAME") & "\" & Replace(driveLetter, ":", "$") & Mid(localPath, 3)
End If
Set fso = Nothing
Set drv = Nothing
ConvertToUNC = uncPath
End Function
Function GetFirstCharacterPageNumber(rng As Range) As Long
Dim firstCharRange As Range
' 範囲の最初の文字だけを含む新しい範囲を作成
Set firstCharRange = rng.Duplicate
firstCharRange.End = firstCharRange.Start
' 最初の文字を含むページ番号を取得して返す
GetFirstCharacterPageNumber = firstCharRange.Information(wdActiveEndPageNumber)
End Function
Function RemoveSpecificCharacterOnTheLeftandRight(str As String, errText As String, charToRemove As String) As String
Dim errPos As Long
Dim leftBreakPos As Long
Dim rightBreakPos As Long
On Error GoTo ErrorHandler
errPos = InStr(str, errText)
' 右側の文字を削除（errPosからstr中にcharToRemoveがあるかを左から検索）
rightBreakPos = InStr(errPos, str, charToRemove)
If rightBreakPos > 0 Then
str = Left(str, rightBreakPos - Len(charToRemove))
End If
' 左側の文字を削除(errPosからstr中にcharToRemoveがあるかを右から検索）
leftBreakPos = InStrRev(str, charToRemove, errPos)
If leftBreakPos > 0 Then
str = Right(str, Len(str) - leftBreakPos)
End If
RemoveSpecificCharacterOnTheLeftandRight = str
Exit Function
ErrorHandler:
' エラーが発生した場合、元の文字列をそのまま返す
RemoveSpecificCharacterOnTheLeftandRight = str
End Function