Go to Qiita Advent Calendar Top
LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@codebreaker4423

XML差分比較VBA

Posted at 
' ==========================================
' Module1: modMain - メイン処理
' ==========================================

Option Explicit

' オプション設定を保持する型
Public Type CompareOptions
    IgnoreWhitespace As Boolean
    IgnoreCase As Boolean
    NormalizeXml As Boolean
End Type

' ファイル選択ダイアログを表示
Public Function SelectFile() As String
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    With fd
        .Title = "XMLファイルを選択してください"
        .Filters.Clear
        .Filters.Add "XMLファイル", "*.xml"
        .Filters.Add "すべてのファイル", "*.*"
        .AllowMultiSelect = False
        
        If .Show = -1 Then
            SelectFile = .SelectedItems(1)
        Else
            SelectFile = ""
        End If
    End With
    
    Set fd = Nothing
End Function

' メイン比較処理
Public Sub ExecuteComparison(filePath1 As String, filePath2 As String, options As CompareOptions)
    On Error GoTo ErrorHandler
    
    Dim file1Content As Collection
    Dim file2Content As Collection
    Dim diffResults As Collection
    Dim ws As Worksheet
    
    ' 画面更新を停止
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' ファイル存在チェック
    If Not FileExists(filePath1) Then
        MsgBox "比較元ファイルが見つかりません: " & filePath1, vbCritical
        Exit Sub
    End If
    
    If Not FileExists(filePath2) Then
        MsgBox "比較先ファイルが見つかりません: " & filePath2, vbCritical
        Exit Sub
    End If
    
    ' ファイルサイズチェック（10MB以上は警告）
    If GetFileSize(filePath1) > 10485760 Or GetFileSize(filePath2) > 10485760 Then
        If MsgBox("ファイルサイズが大きいため、処理に時間がかかる可能性があります。続行しますか？", _
                  vbQuestion + vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If
    
    ' XML妥当性チェック
    If Not ValidateXml(filePath1) Then
        MsgBox "比較元ファイルは有効なXMLではありません。", vbExclamation
    End If
    
    If Not ValidateXml(filePath2) Then
        MsgBox "比較先ファイルは有効なXMLではありません。", vbExclamation
    End If
    
    ' ファイル読み込み
    Set file1Content = ReadXmlFile(filePath1)
    Set file2Content = ReadXmlFile(filePath2)
    
    ' オプション適用
    Set file1Content = ApplyOptions(file1Content, options)
    Set file2Content = ApplyOptions(file2Content, options)
    
    ' 差分比較実行
    Set diffResults = CompareFiles(file1Content, file2Content)
    
    ' 結果シート作成
    Set ws = CreateResultSheet()
    
    ' 結果表示
    DisplayDifferences ws, diffResults, filePath1, filePath2
    
    ' ナビゲーションボタン追加
    AddNavigationButtons ws
    
    ' 完了メッセージ
    MsgBox "比較が完了しました。" & vbCrLf & _
           "結果シート「XML比較結果」を確認してください。", vbInformation
    
    ' 画面更新を再開
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    Exit Sub
    
ErrorHandler:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical
End Sub

' ==========================================
' Module2: modXmlParser - XML解析処理
' ==========================================

' XMLファイルを読み込み
Public Function ReadXmlFile(filePath As String) As Collection
    On Error GoTo ErrorHandler
    
    Dim stream As Object
    Dim content As String
    Dim lines() As String
    Dim result As New Collection
    Dim i As Long
    
    ' ADODB.Streamを使用してUTF-8対応
    Set stream = CreateObject("ADODB.Stream")
    
    With stream
        .Charset = "UTF-8"
        .Open
        .LoadFromFile filePath
        content = .ReadText
        .Close
    End With
    
    ' 行ごとに分割
    lines = Split(content, vbLf)
    
    For i = LBound(lines) To UBound(lines)
        ' vbCrを除去
        lines(i) = Replace(lines(i), vbCr, "")
        result.Add lines(i)
    Next i
    
    Set ReadXmlFile = result
    Set stream = Nothing
    Exit Function
    
ErrorHandler:
    ' エラー時は通常の読み込みを試行
    Dim fileNum As Integer
    fileNum = FreeFile
    Open filePath For Input As #fileNum
    
    Set result = New Collection
    Do While Not EOF(fileNum)
        Dim line As String
        Line Input #fileNum, line
        result.Add line
    Loop
    Close #fileNum
    
    Set ReadXmlFile = result
End Function

' XMLの妥当性チェック
Public Function ValidateXml(filePath As String) As Boolean
    On Error Resume Next
    
    Dim xmlDoc As Object
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    
    xmlDoc.Async = False
    xmlDoc.Load filePath
    
    ValidateXml = (xmlDoc.parseError.ErrorCode = 0)
    Set xmlDoc = Nothing
End Function

' XMLフォーマットを正規化
Public Function NormalizeXml(xmlContent As Collection) As Collection
    Dim xmlDoc As Object
    Dim result As New Collection
    Dim lines() As String
    Dim i As Long
    Dim tempFile As String
    
    On Error GoTo ErrorHandler
    
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    
    ' Collectionを文字列に結合
    Dim fullContent As String
    Dim item As Variant
    For Each item In xmlContent
        fullContent = fullContent & item & vbCrLf
    Next item
    
    ' XMLとして読み込み
    xmlDoc.LoadXML fullContent
    
    ' インデント付きで出力
    Dim formattedXml As String
    formattedXml = xmlDoc.XML
    
    ' 再度行に分割
    lines = Split(formattedXml, vbLf)
    For i = LBound(lines) To UBound(lines)
        lines(i) = Replace(lines(i), vbCr, "")
        result.Add lines(i)
    Next i
    
    Set NormalizeXml = result
    Set xmlDoc = Nothing
    Exit Function
    
ErrorHandler:
    ' エラー時は元のコレクションを返す
    Set NormalizeXml = xmlContent
End Function

' ==========================================
' Module3: modCompare - 差分比較処理
' ==========================================

' 差分情報を保持する型
Public Type DiffLine
    LineNumber1 As Long
    LineNumber2 As Long
    Content1 As String
    Content2 As String
    DiffType As String
    IsMatch As Boolean
End Type

' ファイルを比較
Public Function CompareFiles(file1Content As Collection, file2Content As Collection) As Collection
    Dim result As New Collection
    Dim i As Long, j As Long
    Dim maxLen As Long
    Dim diff As DiffLine
    
    ' 最大行数を取得
    maxLen = IIf(file1Content.Count > file2Content.Count, file1Content.Count, file2Content.Count)
    
    For i = 1 To maxLen
        diff.LineNumber1 = i
        diff.LineNumber2 = i
        
        ' 比較元の内容取得
        If i <= file1Content.Count Then
            diff.Content1 = file1Content(i)
        Else
            diff.Content1 = ""
        End If
        
        ' 比較先の内容取得
        If i <= file2Content.Count Then
            diff.Content2 = file2Content(i)
        Else
            diff.Content2 = ""
        End If
        
        ' 差分タイプを判定
        If diff.Content1 = diff.Content2 Then
            diff.DiffType = "同一"
            diff.IsMatch = True
        ElseIf diff.Content1 = "" Then
            diff.DiffType = "追加"
            diff.IsMatch = False
        ElseIf diff.Content2 = "" Then
            diff.DiffType = "削除"
            diff.IsMatch = False
        Else
            diff.DiffType = "変更"
            diff.IsMatch = False
        End If
        
        result.Add diff
    Next i
    
    Set CompareFiles = result
End Function

' オプションを適用
Public Function ApplyOptions(content As Collection, options As CompareOptions) As Collection
    Dim result As New Collection
    Dim item As Variant
    Dim processedLine As String
    
    For Each item In content
        processedLine = CStr(item)
        
        ' 空白行を無視
        If options.IgnoreWhitespace Then
            If Trim(processedLine) = "" Then
                GoTo NextItem
            End If
            processedLine = Trim(processedLine)
        End If
        
        ' 大文字小文字を無視
        If options.IgnoreCase Then
            processedLine = LCase(processedLine)
        End If
        
        result.Add processedLine
NextItem:
    Next item
    
    ' XMLの正規化
    If options.NormalizeXml Then
        Set result = NormalizeXml(result)
    End If
    
    Set ApplyOptions = result
End Function

' ==========================================
' Module4: modDisplay - 結果表示処理
' ==========================================

' 結果シートを作成
Public Function CreateResultSheet() As Worksheet
    Dim ws As Worksheet
    Dim sheetName As String
    
    sheetName = "XML比較結果"
    
    ' 既存シートを削除
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets(sheetName).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    ' 新規シート作成
    Set ws = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets(1))
    ws.Name = sheetName
    
    Set CreateResultSheet = ws
End Function

' 差分結果を表示
Public Sub DisplayDifferences(ws As Worksheet, diffResults As Collection, filePath1 As String, filePath2 As String)
    Dim i As Long
    Dim rowIndex As Long
    Dim diff As DiffLine
    Dim changeCount As Long, addCount As Long, deleteCount As Long
    Dim dataArray() As Variant
    Dim arrayIndex As Long
    
    ' 配列を準備（高速化のため）
    ReDim dataArray(1 To diffResults.Count, 1 To 5)
    
    ' データを配列に格納
    arrayIndex = 0
    For i = 1 To diffResults.Count
        diff = diffResults(i)
        arrayIndex = arrayIndex + 1
        
        dataArray(arrayIndex, 1) = IIf(diff.Content1 <> "", diff.LineNumber1, "")
        dataArray(arrayIndex, 2) = diff.Content1
        dataArray(arrayIndex, 3) = diff.DiffType
        dataArray(arrayIndex, 4) = diff.Content2
        dataArray(arrayIndex, 5) = IIf(diff.Content2 <> "", diff.LineNumber2, "")
        
        ' カウント
        Select Case diff.DiffType
            Case "変更": changeCount = changeCount + 1
            Case "追加": addCount = addCount + 1
            Case "削除": deleteCount = deleteCount + 1
        End Select
    Next i
    
    With ws
        ' サマリーセクション
        .Range("A1").Value = "XML差分比較結果"
        .Range("A1").Font.Bold = True
        .Range("A1").Font.Size = 14
        
        .Range("A2").Value = "比較元: " & filePath1
        .Range("A3").Value = "比較先: " & filePath2
        .Range("A4").Value = "総行数: " & diffResults.Count & " | 変更: " & changeCount & " | 追加: " & addCount & " | 削除: " & deleteCount
        .Range("A4").Font.Bold = True
        
        ' ヘッダー行
        rowIndex = 6
        .Cells(rowIndex, 1).Value = "行番号(元)"
        .Cells(rowIndex, 2).Value = "比較元ファイル"
        .Cells(rowIndex, 3).Value = "差分状態"
        .Cells(rowIndex, 4).Value = "比較先ファイル"
        .Cells(rowIndex, 5).Value = "行番号(先)"
        
        .Range(.Cells(rowIndex, 1), .Cells(rowIndex, 5)).Font.Bold = True
        .Range(.Cells(rowIndex, 1), .Cells(rowIndex, 5)).Interior.Color = RGB(200, 200, 200)
        
        ' データを一括で書き込み
        rowIndex = 7
        .Range(.Cells(rowIndex, 1), .Cells(rowIndex + diffResults.Count - 1, 5)).Value = dataArray
        
        ' 色付け処理
        For i = 1 To diffResults.Count
            diff = diffResults(i)
            rowIndex = 6 + i
            
            Select Case diff.DiffType
                Case "変更"
                    .Range(.Cells(rowIndex, 1), .Cells(rowIndex, 5)).Interior.Color = RGB(255, 255, 153) ' 黄色
                Case "追加"
                    .Range(.Cells(rowIndex, 1), .Cells(rowIndex, 5)).Interior.Color = RGB(198, 239, 206) ' 緑色
                Case "削除"
                    .Range(.Cells(rowIndex, 1), .Cells(rowIndex, 5)).Interior.Color = RGB(255, 199, 206) ' 赤色
            End Select
        Next i
        
        ' 列幅調整
        .Columns("A:A").ColumnWidth = 12
        .Columns("B:B").ColumnWidth = 60
        .Columns("C:C").ColumnWidth = 12
        .Columns("D:D").ColumnWidth = 60
        .Columns("E:E").ColumnWidth = 12
        
        ' フリーズペイン
        .Range("A7").Select
        ActiveWindow.FreezePanes = True
    End With
End Sub

' ナビゲーションボタンを追加
Public Sub AddNavigationButtons(ws As Worksheet)
    Dim btn As Button
    
    On Error Resume Next
    ' 既存ボタンを削除
    ws.Buttons.Delete
    On Error GoTo 0
    
    ' 次の差分ボタン
    Set btn = ws.Buttons.Add(10, 10, 100, 25)
    btn.Text = "次の差分 ▼"
    btn.OnAction = "NextDifference"
    
    ' 前の差分ボタン
    Set btn = ws.Buttons.Add(120, 10, 100, 25)
    btn.Text = "前の差分 ▲"
    btn.OnAction = "PreviousDifference"
End Sub

' 次の差分へ移動
Public Sub NextDifference()
    Dim ws As Worksheet
    Dim currentRow As Long
    Dim lastRow As Long
    Dim i As Long
    
    Set ws = ActiveSheet
    currentRow = ActiveCell.Row
    lastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
    
    For i = currentRow + 1 To lastRow
        If ws.Cells(i, 3).Value <> "同一" And ws.Cells(i, 3).Value <> "" Then
            ws.Cells(i, 2).Select
            Exit Sub
        End If
    Next i
    
    MsgBox "これ以上差分はありません。", vbInformation
End Sub

' 前の差分へ移動
Public Sub PreviousDifference()
    Dim ws As Worksheet
    Dim currentRow As Long
    Dim i As Long
    
    Set ws = ActiveSheet
    currentRow = ActiveCell.Row
    
    For i = currentRow - 1 To 7 Step -1
        If ws.Cells(i, 3).Value <> "同一" And ws.Cells(i, 3).Value <> "" Then
            ws.Cells(i, 2).Select
            Exit Sub
        End If
    Next i
    
    MsgBox "これ以上差分はありません。", vbInformation
End Sub

' ==========================================
' Module5: modUtility - ユーティリティ関数
' ==========================================

' ファイルの存在確認
Public Function FileExists(filePath As String) As Boolean
    FileExists = (Dir(filePath) <> "")
End Function

' ファイルサイズを取得（バイト単位）
Public Function GetFileSize(filePath As String) As Long
    On Error Resume Next
    GetFileSize = FileLen(filePath)
    On Error GoTo 0
End Function

' エラーメッセージ表示
Public Sub ShowError(message As String)
    MsgBox message, vbCritical, "エラー"
End Sub

' ==========================================
' UserForm1: frmXmlCompare - メイン操作画面
' ==========================================

' ユーザーフォームのコード
' フォームには以下のコントロールを配置してください：
' - txtFilePath1 (TextBox)
' - txtFilePath2 (TextBox)
' - btnBrowse1 (CommandButton)
' - btnBrowse2 (CommandButton)
' - chkIgnoreWhitespace (CheckBox)
' - chkIgnoreCase (CheckBox)
' - chkNormalizeXml (CheckBox)
' - btnCompare (CommandButton)
' - btnClear (CommandButton)
' - btnClose (CommandButton)
' - lblStatus (Label)

Private Sub UserForm_Initialize()
    Me.Caption = "XML差分比較ツール"
    
    ' デフォルト設定
    chkIgnoreWhitespace.Value = False
    chkIgnoreCase.Value = False
    chkNormalizeXml.Value = False
    
    lblStatus.Caption = "ファイルを選択して比較を実行してください。"
End Sub

Private Sub btnBrowse1_Click()
    Dim filePath As String
    filePath = SelectFile()
    
    If filePath <> "" Then
        txtFilePath1.Text = filePath
    End If
End Sub

Private Sub btnBrowse2_Click()
    Dim filePath As String
    filePath = SelectFile()
    
    If filePath <> "" Then
        txtFilePath2.Text = filePath
    End If
End Sub

Private Sub btnCompare_Click()
    Dim options As CompareOptions
    
    ' 入力チェック
    If Trim(txtFilePath1.Text) = "" Then
        MsgBox "比較元ファイルを選択してください。", vbExclamation
        Exit Sub
    End If
    
    If Trim(txtFilePath2.Text) = "" Then
        MsgBox "比較先ファイルを選択してください。", vbExclamation
        Exit Sub
    End If
    
    ' オプション設定
    options.IgnoreWhitespace = chkIgnoreWhitespace.Value
    options.IgnoreCase = chkIgnoreCase.Value
    options.NormalizeXml = chkNormalizeXml.Value
    
    ' ステータス更新
    lblStatus.Caption = "比較処理中..."
    DoEvents
    
    ' 比較実行
    ExecuteComparison txtFilePath1.Text, txtFilePath2.Text, options
    
    ' ステータス更新
    lblStatus.Caption = "比較完了"
End Sub

Private Sub btnClear_Click()
    txtFilePath1.Text = ""
    txtFilePath2.Text = ""
    chkIgnoreWhitespace.Value = False
    chkIgnoreCase.Value = False
    chkNormalizeXml.Value = False
    lblStatus.Caption = "ファイルを選択して比較を実行してください。"
End Sub

Private Sub btnClose_Click()
    Unload Me
End Sub

' ==========================================
' フォーム起動用プロシージャ（標準モジュールに配置）
' ==========================================

Public Sub ShowXmlCompareForm()
    frmXmlCompare.Show
End Sub
0
0
0

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
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?