【VBA】コードの差分を出す

Option Explicit

' VBAコード（モジュール/クラス/フォーム/ThisWorkbook/シート等）をテキストとして一括書き出し
Public Sub VBA書き出し()
    Dim srcPath As String
    Dim outRoot As String
    Dim outDir As String
    Dim wb As Workbook
    Dim vbProj As VBIDE.VBProject
    Dim vbComp As VBIDE.VBComponent
    Dim ext As String
    Dim exportPath As String
    Dim baseName As String
    
    On Error GoTo EH
    
    '--- 1) 対象ファイル選択
    srcPath = PickExcelFile()
    If Len(srcPath) = 0 Then Exit Sub
    
    '--- 2) 出力先フォルダ選択
    outRoot = PickFolder()
    If Len(outRoot) = 0 Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 対象ブックを開く（読み取り専用推奨）
    Set wb = Application.Workbooks.Open(Filename:=srcPath, ReadOnly:=True, UpdateLinks:=0, AddToMru:=False)
    
    ' 出力フォルダ（ブック名_日時）
    baseName = GetFileBaseName(srcPath)
    outDir = EnsureTrailingSlash(outRoot) & baseName & "_" & Format(Now, "yyyymmdd_HHMMSS")
    CreateFolderIfNotExists outDir
    
    Set vbProj = wb.VBProject
    
    '--- 3) 書き出し
    For Each vbComp In vbProj.VBComponents
        ext = ComponentExtension(vbComp.Type)
        exportPath = EnsureTrailingSlash(outDir) & SafeFileName(vbComp.Name) & ext
        
        ' 同名があれば上書き（念のため削除）
        If Dir(exportPath, vbNormal) <> "" Then Kill exportPath
        
        vbComp.Export exportPath
    Next vbComp
    
    ' ブックは保存せず閉じる
    wb.Close SaveChanges:=False
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    '--- 4) 完了メッセージ
    MsgBox "VBAコードの書き出しが完了しました。" & vbCrLf & "出力先: " & outDir, vbInformation, "完了"
    Exit Sub

EH:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    ' 可能なら閉じる
    On Error Resume Next
    If Not wb Is Nothing Then wb.Close SaveChanges:=False
    On Error GoTo 0
    
    MsgBox "エラーが発生しました。" & vbCrLf & "内容: " & Err.Description, vbExclamation, "エラー"
End Sub

'========================
' ファイル選択（xlsm/xlsb等）
'========================
Private Function PickExcelFile() As String
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    With fd
        .Title = "VBAを書き出すExcelファイルを選択してください"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm; *.xlsb", 1
        .Filters.Add "Macro Enabled", "*.xlsm; *.xlsb", 2
        If .Show <> -1 Then
            PickExcelFile = ""
        Else
            PickExcelFile = .SelectedItems(1)
        End If
    End With
End Function

'========================
' 出力先フォルダ選択
'========================
Private Function PickFolder() As String
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    With fd
        .Title = "出力先フォルダを選択してください"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            PickFolder = ""
        Else
            PickFolder = .SelectedItems(1)
        End If
    End With
End Function

'========================
' VBComponent Type → 拡張子
'========================
Private Function ComponentExtension(ByVal compType As Long) As String
    Select Case compType
        Case 1 ' vbext_ct_StdModule
            ComponentExtension = ".bas"
        Case 2 ' vbext_ct_ClassModule
            ComponentExtension = ".cls"
        Case 3 ' vbext_ct_MSForm
            ComponentExtension = ".frm"
        Case 100 ' vbext_ct_Document
            ComponentExtension = ".cls"
        Case Else
            ComponentExtension = ".txt"
    End Select
End Function

'========================
' ユーティリティ
'========================
Private Function EnsureTrailingSlash(ByVal path As String) As String
    If Right$(path, 1) = "\" Then
        EnsureTrailingSlash = path
    Else
        EnsureTrailingSlash = path & "\"
    End If
End Function

Private Sub CreateFolderIfNotExists(ByVal folderPath As String)
    If Dir(folderPath, vbDirectory) = "" Then
        MkDir folderPath
    End If
End Sub

Private Function GetFileBaseName(ByVal fullPath As String) As String
    Dim f As String
    f = Mid$(fullPath, InStrRev(fullPath, "\") + 1)
    If InStrRev(f, ".") > 0 Then
        GetFileBaseName = Left$(f, InStrRev(f, ".") - 1)
    Else
        GetFileBaseName = f
    End If
End Function

Private Function SafeFileName(ByVal s As String) As String
    ' Windowsのファイル名に使えない文字を置換
    Dim badChars As Variant, i As Long
    badChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    SafeFileName = s
    For i = LBound(badChars) To UBound(badChars)
        SafeFileName = Replace(SafeFileName, badChars(i), "_")
    Next i
End Function