「ちゃうちゃう！」で2つの文書を比較するWordマクロ

ホーム
Office関連, Word
「ちゃうちゃう！」で2つの文書を比較するWordマクロ

Office関連

2012.02.28

「ちゃうちゃう！」で2つの文書を比較するWordマクロ

2014/08/10 追記：
ちゃうちゃう！がバージョンアップされました。

・テキスト比較ソフト「ちゃうちゃう！」がバージョンアップされました。
//www.ka-net.org/blog/?p=4724

2つのテキストを比較し、その違いを検出するのに役立つツールとして「ちゃうちゃう！」があります。
ドキュメントを多く扱う編集者やライター、翻訳者といった方々には有名で、非常に便利なツールです。

今回はこの”ちゃうちゃう！“をVBAで無理やり制御して、

・指定した2つの文書を比較して、その結果をrtf形式で保存する

といった操作を自動化してみようと思います。

Option Explicit

Private Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, riid As Any, ByRef ppvObject As IAccessible) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hParent As Long, ByVal hChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, lpiid As Any) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const OBJID_CLIENT = &HFFFFFFFC
Private Const WM_COMMAND = &H111
Private Const WM_SETTEXT = &HC

Public Sub Sample()
  Dim FilePath1 As String
  Dim FilePath2 As String
  
  FilePath1 = "C:\Test\File01.txt"
  FilePath2 = "C:\Test\File02.txt"
  CompareDocumentChawChaw FilePath1, FilePath2
  FilePath1 = "C:\Test\File03.txt"
  FilePath2 = "C:\Test\File04.txt"
  CompareDocumentChawChaw FilePath1, FilePath2
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Public Sub CompareDocumentChawChaw(ByVal FilePath1 As String, ByVal FilePath2 As String)
'ちゃうちゃう！で2つの文書を比較する
  Dim TimeLimit As Date
  Dim SaveFilePath1 As String
  Dim SaveFilePath2 As String
  Dim hApp As Long
  Dim hBar As Long
  Dim btnState As Long
  Dim IID(0 To 3) As Long
  Dim acc As Office.IAccessible
  Const ChawChawExePath As String = "C:\Program Files\ChawChaw\ChawChaw.exe" '[ChawChaw.exe]のパス  ※ 必要に応じて変更
  
  With CreateObject("Scripting.FileSystemObject")
    If .FileExists(ChawChawExePath) = False Then
      MsgBox ChawChawExePath & " が見つかりません。" & vbCrLf & "処理を中止します。", vbExclamation + vbSystemModal
      Exit Sub
    End If
    If .FileExists(FilePath1) = False Then
      MsgBox FilePath1 & " が見つかりません。" & vbCrLf & "処理を中止します。", vbExclamation + vbSystemModal
      Exit Sub
    End If
    If .FileExists(FilePath2) = False Then
      MsgBox FilePath2 & " が見つかりません。" & vbCrLf & "処理を中止します。", vbExclamation + vbSystemModal
      Exit Sub
    End If
    SaveFilePath1 = .GetFile(FilePath1).ParentFolder.Path
    If Right$(SaveFilePath1, 1) <> "\" Then SaveFilePath1 = SaveFilePath1 & "\"
    SaveFilePath1 = SaveFilePath1 & "[ChawChawed]" & Left$(.GetFile(FilePath1).Name, InStrRev(.GetFile(FilePath1).Name, ".")) & "rtf"
    SaveFilePath2 = .GetFile(FilePath2).ParentFolder.Path
    If Right$(SaveFilePath2, 1) <> "\" Then SaveFilePath2 = SaveFilePath2 & "\"
    SaveFilePath2 = SaveFilePath2 & "[ChawChawed]" & Left$(.GetFile(FilePath2).Name, InStrRev(.GetFile(FilePath2).Name, ".")) & "rtf"
  End With
  
  '事前にファイル削除
  If Len(Dir$(SaveFilePath1)) > 0 Then Kill SaveFilePath1
  If Len(Dir$(SaveFilePath2)) > 0 Then Kill SaveFilePath2
  
  Shell ChawChawExePath, vbNormalFocus 'ちゃうちゃう！起動
  hApp = FindChawChawWindow()
  If hApp = 0& Then
    MsgBox "[ちゃうちゃう！]のウィンドウが見つかりませんでした。" & vbCrLf & "処理を中止します。", vbExclamation + vbSystemModal
    Exit Sub
  End If
  SendMessage hApp, WM_COMMAND, &HFF01, 0& '左ウィンドウ選択
  SendMessage hApp, WM_COMMAND, &HE121, 0& 'すべて消去
  FileContentCopy FilePath1 '対象ファイルの内容をクリップボードにコピー
  SendMessage hApp, WM_COMMAND, &HE125, 0& '文字列貼り付け

  SendMessage hApp, WM_COMMAND, &HFF00, 0& '右ウィンドウ選択
  SendMessage hApp, WM_COMMAND, &HE121, 0& 'すべて消去
  FileContentCopy FilePath2 '対象ファイルの内容をクリップボードにコピー
  SendMessage hApp, WM_COMMAND, &HE125, 0& '文字列貼り付け
  
  '全文比較
  'SendMessage hApp, WM_COMMAND, &H8015, 0&
  hBar = FindWindowEx(hApp, 0&, vbNullString, "Tool Bar")
  hBar = FindWindowEx(hBar, 0&, vbNullString, "Tool Bar")
  Set acc = Nothing '初期化
  If hBar <> 0& Then
    IIDFromString StrPtr("{618736E0-3C3D-11CF-810C-00AA00389B71}"), IID(0)
    AccessibleObjectFromWindow hBar, OBJID_CLIENT, IID(0), acc
  End If
  If acc Is Nothing Then
    MsgBox "処理が失敗しました。", vbExclamation + vbSystemModal
    Exit Sub
  End If
  acc.accDoDefaultAction &H10&
  Sleep 200&
  
  OperateSeparatorDialog '不適切な区切り文字ダイアログ制御
  
  '比較処理待ち
  TimeLimit = DateAdd("n", 10, Now())  'ループの制限時間:10分
  Do
    btnState = acc.accState(&H10&) '全文比較 (F5)ボタンの状態取得
    If Now() > TimeLimit Then Exit Do  '制限時間を過ぎたら脱ループ
    Sleep 1000&
    DoEvents
  Loop While btnState <> 0&
  Sleep 1000&

  SendMessage hApp, WM_COMMAND, &HFF01, 0& '左ウィンドウ選択
  'SendMessage hApp, WM_COMMAND, &HE104, 0& '名前を付けて保存
  PostMessage hApp, WM_COMMAND, &HE104, 0& '名前を付けて保存
  If OperateSaveAsDialog(SaveFilePath1) = 0& Then
    MsgBox "ファイルの保存に失敗しました。" & vbCrLf & "処理を中止します。", vbExclamation + vbSystemModal
    Exit Sub
  End If
  Sleep 2000& '保存処理待ち

  SendMessage hApp, WM_COMMAND, &HFF00, 0& '右ウィンドウ選択
  'SendMessage hApp, WM_COMMAND, &HE104, 0& '名前を付けて保存
  PostMessage hApp, WM_COMMAND, &HE104, 0& '名前を付けて保存
  If OperateSaveAsDialog(SaveFilePath2) = 0& Then
    MsgBox "ファイルの保存に失敗しました。" & vbCrLf & "処理を中止します。", vbExclamation + vbSystemModal
    Exit Sub
  End If
  Sleep 2000& '保存処理待ち
  
  SendMessage hApp, WM_COMMAND, &HE141, 0& 'アプリケーションの終了
End Sub

Private Sub FileContentCopy(ByVal FilePath As String)
'文書ファイルを開いて内容をクリップボードにコピー
  With Application.Documents.Open(FileName:=FilePath, ReadOnly:=True)
    .Content.Copy
    .Close wdDoNotSaveChanges
  End With
End Sub

Private Sub OperateSeparatorDialog()
'不適切な区切り文字ダイアログ制御
  Dim hDlg As Long
  Dim hSta As Long
  Dim hBtn As Long
  Dim s As String
  Dim buf As String * 255
  
  hDlg = FindWindowEx(0&, 0&, "#32770", "ChawChaw")
  'Debug.Print Hex(hDlg)
  If hDlg = 0& Then Exit Sub
  hSta = FindWindowEx(hDlg, 0&, "Static", vbNullString)
  hSta = FindWindowEx(hDlg, hSta, "Static", vbNullString)
  If hSta = 0& Then Exit Sub
  GetWindowText hSta, buf, Len(buf)
  s = Left$(buf, InStr(buf, vbNullChar) - 1&)
  If InStr(s, "不適切な区切り文字が指定されているようです") Then
    hBtn = FindWindowEx(hDlg, 0&, "Button", "はい(&Y)")
    SendMessage hDlg, WM_COMMAND, &H6, hBtn 'はい(&Y)ボタンクリック
    'hBtn = FindWindowEx(hDlg, 0&, "Button", "いいえ(&N)")
    'SendMessage hDlg, WM_COMMAND, &H7, hBtn 'いいえ(&N)ボタンクリック
  End If
End Sub

Private Function FindChawChawWindow() As Long
'ちゃうちゃう！のウィンドウハンドル取得
  Dim TimeLimit As Date
  Dim h As Long
  
  h = 0& '初期化
  TimeLimit = DateAdd("s", 2, Now())  'ループの制限時間:2秒
  Do
    h = FindWindowEx(0&, 0&, vbNullString, "ちゃうちゃう！")
    If Now() > TimeLimit Then Exit Do  '制限時間を過ぎたら脱ループ
    DoEvents
  Loop While h = 0&
  FindChawChawWindow = h
End Function

Private Function OperateSaveAsDialog(ByVal FilePath As String) As Long
'名前を付けて保存ダイアログ制御
  Dim TimeLimit As Date
  Dim hDlg As Long
  Dim hBtn As Long
  Dim ret As Long
  
  ret = -1& '初期化
  TimeLimit = DateAdd("s", 5, Now())  'ループの制限時間:5秒
  Do
    hDlg = FindWindowEx(0&, 0&, "#32770", "Save As")
    If Now() > TimeLimit Then Exit Do  '制限時間を過ぎたら脱ループ
    DoEvents
  Loop While hDlg = 0&
  If hDlg = 0& Then GoTo FncErr:
  hBtn = FindWindowEx(hDlg, 0&, "Button", "保存(&S)")
  If hBtn = 0& Then GoTo FncErr:
  Sleep 500&
  SendDlgItemMessage hDlg, &H47C, WM_SETTEXT, 0&, FilePath 'ファイルパスセット
  'SendMessage hDlg, WM_COMMAND, &H1, hBtn '保存ボタンクリック
  PostMessage hDlg, WM_COMMAND, &H1, hBtn '保存ボタンクリック

FncExit:
  OperateSaveAsDialog = ret
  Exit Function
  
FncErr:
  ret = 0&
  GoTo FncExit:
End Function

上記コードを動作させる条件として、事前に下記2点の作業を行っておく必要があります。

・事前にライセンス登録(無料)をし、起動時にダイアログが表示されないようにする。
・事前に”比較の設定”をしておく。

また、上記コードはあくまでも”無理やり“ちゃうちゃう！の操作を行っているもので、その動作の正確性は一切保証できませんので、予めご了承ください。

上記コードを実行すると、元のファイルと同じ場所に「[ChawChawed](元のファイル名).rtf」という形で比較結果が保存されます。

上記”Sample“のように複数のファイルの比較を連続して行う場合には、上記コードが有効に使えるかもしれません。
上記ではサンプルとしてテキストファイルを使用していますが、Wordで開ける文書であれば良いので、テキストファイルでなくても問題ありません。

実は上記コードは数年前に書いたものなのですが、今日ファイルの整理をしていたらたまたま出てきて、Windows 7で動かしてみたら問題無く動いたので、ほぼそのままブログに載せることにしました。

碌に修正や動作確認をしていませんので、結構穴があるだろうと思います。
一応コードを書いた環境であるWindows XP + Word 2003とWindows 7 + Word 2010での動作は確認しましたが、それ以外の環境では動作確認を行っていません。

また、64ビット環境ではテストしていませんので、64ビット版のWordや64ビット版のちゃうちゃう！でコードを実行する際には、必要に応じてコードを修正する必要があります。

■ 関連Webページ

・テキスト比較ソフト「ちゃうちゃう！」がバージョンアップされました。
//www.ka-net.org/blog/?p=4724
・2つの文書を比較するWordマクロ
//www.ka-net.org/blog/?p=4734
・ちゃうちゃう！ 2.0を操作するWordマクロ
//www.ka-net.org/blog/?p=4931