【VBA】WinMergeでファイルを自動比較＆HTMLレポート出力｜AIより手軽

Option Explicit

Private Const 削除する末尾の文字数 As Long = 0
Private Const レポートの文頭 As String = "【Title】Diff★"
Private Const MAX_WAIT_SECONDS As Long = 30

Private Sub WinMergeでファイルの差分を出力する()
	Dim exe As String: exe = ThisWorkbook.Path & "\" & "WinMergeU.exe"

	Dim root As String
	root = ThisWorkbook.Path

	' 比較フォルダの設定
	Dim folderSRC As String: folderSRC = root & "\" & "旧ファイル"
	Dim folderDST As String: folderDST = root & "\" & "新ファイル"
	' HTMLレポート出力フォルダ
	Dim folderOutput As String: folderOutput = root

	' --- 変数・オブジェクト ---
	Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
	Dim fileDst As Object, fileSrc As Object
	Dim fileFound As Boolean
	Dim startTime As Double
	Dim fileSizeAtStart As Long

	' フォルダ存在チェック
	If Not fso.FolderExists(folderSRC) Then
		MsgBox "フォルダが見つかりません。パスを確認してください。" & vbCrLf & folderSRC, vbCritical
		Set fso = Nothing: Exit Sub
	End If
	If Not fso.FolderExists(folderDST) Then
		MsgBox "フォルダが見つかりません。パスを確認してください。" & vbCrLf & folderDST, vbCritical
		Set fso = Nothing: Exit Sub
	End If
	' 出力フォルダがなければ作成
	If Not fso.folderExists(folderOutput) Then fso.CreateFolder folderOutput

	' dstフォルダ内のファイルを1つずつ処理
	For Each fileDst In fso.GetFolder(folderDST).Files
		fileFound = False

		' 1) 比較キーを作成（例：末尾2文字削除 → "aaa.xlsx" -> "aaa"）
		Dim dstNameOnly As String, dstN As String
		dstNameOnly = fso.GetBaseName(fileDst.Name)
		dstN = dstNameOnly
		If 削除する末尾の文字数 > 0 Then
			dstN = Left(dstNameOnly, Len(dstNameOnly) - 削除する末尾の文字数)
		End If
		dstN = StrConv(dstN, vbNarrow)
		dstN = StrConv(dstN, vbLowerCase)

		' 2) src側の一致探索
		For Each fileSrc In fso.GetFolder(folderSRC).Files
			Dim srcNameOnly As String, srcN As String
			srcNameOnly = fso.GetBaseName(fileSrc.Name)
			srcN = srcNameOnly
			If 削除する末尾の文字数 > 0 Then
				srcN = Left(srcNameOnly, Len(srcNameOnly) - 削除する末尾の文字数)
			End If
			srcN = StrConv(srcN, vbNarrow)
			srcN = StrConv(srcN, vbLowerCase)

			If srcN = dstN Then
				fileFound = True
				Exit For
			End If
		Next fileSrc

		If Not fileFound Then
			Debug.Print fileDst.Name & " ・・・一致するファイルが src フォルダにない"
		Else
			' レポートパス
			Dim reportPath As String
			reportPath = folderOutput & "\" & レポートの文頭 & dstN & ".html"

			' 既存ならスキップ
			If Dir(reportPath) <> "" Then
				Debug.Print "Skip: " & fileDst.Name & " ・・・すでにあり"
				GoTo continue
			End If

			' WinMerge CLI を実行
			Dim q As String, exeQ As String, dstQ As String, srcQ As String, repoQ As String
			q = Chr(34)
			exeQ = q & exe & q
			dstQ = q & fileDst.Path & q
			srcQ = q & fileSrc.Path & q
			repoQ = q & reportPath & q

			Dim cmd As String
			cmd = exeQ & " /r /e /xq /ul /ur /minimize /or " & repoQ & " " & dstQ & " " & srcQ

			Dim sh As Object: Set sh = CreateObject("WScript.Shell")
			On Error Resume Next
			sh.Run cmd, 0, False
			If Err.Number <> 0 Then Debug.Print Err.Description
			On Error GoTo 0
			Set sh = Nothing

			' --- 待機ループ（サイズ安定で完了判定） ---
			startTime = Timer
			fileSizeAtStart = 0
			Do
				If Dir(reportPath) <> "" Then
					fileSizeAtStart = fso.GetFile(reportPath).Size
					If fileSizeAtStart > 0 Then
						Application.Wait Now + TimeValue("00:00:02")
						If fso.GetFile(reportPath).Size = fileSizeAtStart Then
							Debug.Print fileDst.Name & " ・レポート作成完了を確認。"
							Exit Do
						End If
					End If
				End If
				If Timer - startTime >= MAX_WAIT_SECONDS Then
					Debug.Print fileDst.Name & " ・レポート作成がタイムアウトしました。"
					Exit Do
				End If
				DoEvents
			Loop
		End If
continue:
	Next fileDst

	Set fso = Nothing
	MsgBox "WinMergeの比較処理が終了しました。", vbInformation
End Sub