﻿Option Explicit

Public Sub CreateComparisonTable()
    Dim oldPath As String, newPath As String, folder As String, output As String
    On Error GoTo Failed
    oldPath = RC_PickFile("改正前の旧規程を選択")
    If Len(oldPath) = 0 Then Exit Sub
    newPath = RC_PickFile("改正後の新規程を選択")
    If Len(newPath) = 0 Then Exit Sub
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "出力先フォルダーを選択"
        If .Show <> -1 Then Exit Sub
        folder = .SelectedItems(1)
    End With
    output = RC_RunFiles(oldPath, newPath, folder)
    RC_ShowOutput output
    MsgBox "作成しました:" & vbCrLf & output, vbInformation
    Exit Sub
Failed:
    MsgBox "作成できませんでした。正常完了していません。" & vbCrLf & Err.Description, vbCritical
End Sub

Public Sub RC_ShowOutput(ByVal output As String)
    Dim doc As Document
    Set doc = Application.Documents.Open(output)
    doc.Activate
    With doc.ActiveWindow.View
        .TableGridlines = False
        .ShowAll = False
        .ShowParagraphs = False
    End With
End Sub

Private Function RC_PickFile(ByVal title As String, Optional ByVal pattern As String = "*.docx;*.doc") As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = title: .AllowMultiSelect = False
        .Filters.Clear: .Filters.Add "対象ファイル", pattern
        If .Show = -1 Then RC_PickFile = .SelectedItems(1)
    End With
End Function

' ファイル選択不要の検証/社内カスタマイズ用経路。既存ファイルに上書きしない。
Public Function RC_RunFiles(ByVal oldPath As String, ByVal newPath As String, ByVal outputFolder As String) As String
    Dim olds As Object, news As Object, pairs As Collection, issues As Collection
    Dim doc As Document, base As String, fso As Object, oldUpdating As Boolean
    Dim savedErr As Long, savedDesc As String, stage As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    oldUpdating = Application.ScreenUpdating
    On Error GoTo Failed
    stage = "入力検証"
    If Not fso.FileExists(oldPath) Then Err.Raise vbObjectError + 150, , "旧規程がありません: " & oldPath
    If Not fso.FileExists(newPath) Then Err.Raise vbObjectError + 151, , "新規程がありません: " & newPath
    If Not fso.FolderExists(outputFolder) Then Err.Raise vbObjectError + 152, , "出力先フォルダーがありません: " & outputFolder
    If StrComp(fso.GetAbsolutePathName(oldPath), fso.GetAbsolutePathName(newPath), vbTextCompare) = 0 Then
        ' 同一ファイル比較も有効。変更ゼロの回帰テスト経路。
    End If
    Application.ScreenUpdating = False
    Set issues = New Collection
    stage = "旧規程解析": Set olds = RC_ReadDocument(oldPath, issues)
    stage = "新規程解析": Set news = RC_ReadDocument(newPath, issues)
    stage = "条・項・号の対応付け"
    Set pairs = RC_Align(news("articles"), olds("articles"), issues, "本則")
    stage = "Word生成"
    Set doc = RC_OutputDocument(pairs, news, olds, issues)
    base = RC_UniqueBase(outputFolder, "新旧対照表_" & Format$(Now, "yyyymmdd_hhnnss"))
    stage = "Word保存"
    doc.SaveAs2 FileName:=base & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    doc.Close SaveChanges:=wdDoNotSaveChanges: Set doc = Nothing
    Application.ScreenUpdating = oldUpdating
    RC_RunFiles = base & ".docx"
    Exit Function
Failed:
    savedErr = Err.Number: savedDesc = "工程: " & stage & vbCrLf & Err.Description
    On Error Resume Next
    If Not doc Is Nothing Then doc.Close SaveChanges:=wdDoNotSaveChanges
    Application.ScreenUpdating = oldUpdating
    If fso.FolderExists(outputFolder) Then
        base = RC_UniqueBase(outputFolder, "実行失敗_" & Format$(Now, "yyyymmdd_hhnnss"))
        RC_WriteText base & ".txt", "正常完了していません。" & vbCrLf & savedDesc & vbCrLf & "未処理範囲: 失敗した工程以降。保存済みのdocxがある場合も不完全な成果物として扱ってください。" & vbCrLf & "旧: " & oldPath & vbCrLf & "新: " & newPath
    End If
    On Error GoTo 0
    Err.Raise savedErr, "RC_RunFiles", savedDesc
End Function

Public Function RC_UniqueBase(ByVal folder As String, ByVal stem As String) As String
    Dim fso As Object, candidate As String, i As Long
    Set fso = CreateObject("Scripting.FileSystemObject")
    candidate = fso.BuildPath(folder, stem)
    Do While fso.FileExists(candidate & ".docx") Or fso.FileExists(candidate & ".txt")
        i = i + 1: candidate = fso.BuildPath(folder, stem & "_" & i)
    Loop
    RC_UniqueBase = candidate
End Function


' 実行失敗時のログを保存する共通処理。
Public Sub RC_WriteText(ByVal path As String, ByVal text As String)
    Dim fso As Object, stream As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set stream = fso.CreateTextFile(path, False, True)
    stream.Write text
    stream.Close
End Sub
