LoginSignup
8

More than 3 years have passed since last update.

VBAからWinMergeを起動するマクロをアップグレードしました。

Last updated at Posted at 2020-01-13

はじめに

以前VBAからWinMergeを起動する方法でExcelからWinMergeを起動して差分を確認するマクロを書いたのですが、改良を加えました。

Excelイメージ

以下のように比較したいファイルのフルパスが左右に並んだExcelになります。(フォーマットは固定です。)
キャプチャ.PNG

コード

CompareWinMerge
'### 選択している行でWinMergeを起動する処理 ###
Sub ExecWinMerge()
    '現在の選択セル
    Dim target As Range: Set target = Selection
    '入力したセルの数が10より多い場合はエラーメッセージを出力して終了
    If (target.Count > 10) Then
        MsgBox "一度に比較できるファイルは10までです。" & vbCrLf & "処理を中止しました。", vbCritical
        End
    End If
    'ループ処理
    For Each r In target
        '実行処理の呼び出し
        Call ExecLoop(r)
    Next r
End Sub



'### WinMergeの起動を自動で実行する処理 ###
Sub AutoExecWinMerge()
    '実行の中止に使用
    Application.EnableCancelKey = xlErrorHandler
    '実行中にエラーが発生した場合のジャンプ処理
    On Error GoTo MyError

    '現在の選択セル
    Dim target As Range: Set target = Selection
    '比較したいセルの選択(入力がない場合はエラーメッセージが表示される)
    Set target = Application.InputBox("自動確認するセルを選択してください。(デフォルトは現在の選択範囲)", "実行確認", target.Address, Type:=8)
    'ループ処理
    For Each r In target
        '選択セルのセルの色を一時的に退避
        Dim targetColor As Long: targetColor = r.Interior.ColorIndex
        '選択セルの色の変更
        r.Interior.ColorIndex = 6
        '実行処理の呼び出し
        Call ExecLoop(r)
        '時間停止
        Application.Wait Now + TimeValue("00:00:2")
        'WinMerge起動・結果
        Dim rc As Long: rc = Shell("taskkill /IM WinMergeU.exe", vbMinimizedFocus)
        '選択セルの色を退避した色に戻す
        r.Interior.ColorIndex = targetColor
        '時間停止
        Application.Wait Now + TimeValue("00:00:1")
    Next r
    MsgBox "全ての差分を自動確認しました。" & ":[" & target.Count & "]", vbInformation

'実行中止時の処理
MyError:
    Select Case Err.Number
    '0(正常終了)の場合は何もしない
    Case 0
    'Escキーが押下された場合
    Case 18
        If MsgBox("マクロを終了しますか?", 292) = vbNo Then
            DoEvents
            Resume
        End If
    'その他のエラー
    Case Else
            MsgBox "予期しないエラーが発生しました" & vbCrLf & Err.Description, vbCritical
    End Select
End Sub



'### ループでWinMergeを実行する処理 ###
Private Sub ExecLoop(target As Variant)
    '選択セル(WinMerge比較)の行番号
    Dim targetRow As Long: targetRow = target.Row
    '選択セル(WinMerge比較)と同じ行の対象ファイル1
    Dim targetFile1 As String: targetFile1 = Cells(targetRow, 2)
    '対象ファイル1の行をアクティブにする(ウィンドウ上に表示するため)
    Cells(targetRow, 2).Activate
    '選択セル(WinMerge比較)と同じ行の対象ファイル2
    Dim targetFile2 As String: targetFile2 = Cells(targetRow, 3)
    'WinMergeの実行ファイル 起動オプション(/e Escで終了 /s 1つのウィンドウで開く)
    Dim winExeFile As String: winExeFile = "C:\PROGRA~1\WinMerge\WinMergeU.exe /e /s"
    '実行時の引数を結合した文字列
    '例)C:\PROGRA~1\WinMerge\WinMergeU.exe C:\vbaSample\before\test1.txt C:\vbaSample\after\test1.txt
    Dim exeStr As String: exeStr = winExeFile & " " & targetFile1 & " " & targetFile2
    'WinMerge起動・結果
    Dim rc As Long: rc = Shell(exeStr, vbNormalFocus)
    'エラー処理
    If rc = 0 Then MsgBox "起動に失敗しました"
End Sub

改良した点

複数セルを選択している場合に複数のタブを開けるように改良

前回は1つの行のみを対象にWinMergeの起動実行を行っていましたが、複数のファイル比較を行いたい場合に何度も起動→終了→セル移動を行うのは面倒だと考えたたため、複数のファイル比較が同時に行えるように改良しました。
具体的には選択範囲に対してWinMergeの起動をループ内で処理することで実現しています。
また、複数ファイルを開く際にはウィンドウごとではなく、WinMergeのウィンドウ内のタブごとで開くようにしています。

選択範囲に対して自動でWinMergeを起動&終了する処理を追加

上記で起動→終了→セル移動を行う数自体は減りましたが、それでも手を動かす必要があったため、どうせなら完全に自動化しようと思い改良を行いました。
上記のコードにWinMergeの起動の終了や待ち時間の設定を追加することで実現しています。
また、実行中に処理が中断したくなった場合にはEscキーを押下することで処理の中断を行えるようにしています。

おわりに

本当は上記の改良のに加えて、起動したWinMergeのウィンドウをスクロール自動でスクロールさせることができないかと思ったのですが、調べた限りではVBAからはできなさそうです。
というか情報が出てこなかった。。。
方法をご存知の方いらっしゃったらご教示いただければと思います。

参考

・マクロの実行中にEscキーで処理を中断した際の制御
https://www.moug.net/tech/exvba/0150018.html
 →waitさせている時間が短いと上手く中止できないことがあります。。。

※2020/1/15 追記

コードに誤っていた点があったため修正しました。
■誤り
自動実行完了後に出力される正常完了のメッセージボックスをEscキーorクリックで閉じた場合に、エラーメッセージのボックスるが出力される。
MyError:の中のエラーハンドリングが誤っており、正常終了(0)の場合でもエラーメッセージを出力していたので、Case分で分岐させて正常終了の場合には何もしないように修正しました。
+αで宣言しているが使用していない変数があったため削除。

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
8