Microsoft Access のクエリ SQL を Excel に一括エクスポート＆シンタックスハイライト（前回のブラッシュアップ版）

Pretty Print

主要節や JOIN/ON での改行規則、括弧に応じたインデント調整、三連以上改行の抑止で読みやすさ最適化。

色分け

文字列 '...' / "..."、日付 #...#、識別子 [...] の除外範囲を先に抽出 → その外側のみを対象に分類ハイライト。

主要句（太字濃色）/補助句/関数（直後に ( 条件）/数値/演算子などをレイヤー順に適用。

運用性

InputBox による開始位置指定、TOC 自動生成、既定シート削除で成果物を見やすく整理。

一時ファイル書込テストでフォルダ権限の問題を前倒し検知。

Option Compare Database
Option Explicit

' ========= ユーザー調整用オプション =========
Private Const OPT_INCLUDE_SYSTEM_QUERIES As Boolean = False  ' MSys/一時(~名)のクエリも含めるか
Private Const OPT_INCLUDE_ACTION_QUERIES As Boolean = False  ' INSERT/UPDATE/DELETE/DDL のクエリも含めるか
Private Const OPT_SHEET_FONT_NAME As String = "Consolas"     ' 出力Excelのフォント名（等幅フォント推奨）
Private Const OPT_SHEET_FONT_SIZE As Long = 10               ' フォントサイズ
Private Const OPT_SQL_COL_WIDTH As Double = 120              ' SQL表示列（B列）の幅
Private Const OPT_ENABLE_SYNTAX_COLOR As Boolean = True      ' シンタックスハイライトを適用するか
Private Const OPT_INDENT_SPACES As Long = 2                  ' SQL整形時のインデント幅（スペース数）
' ============================================

' ?? エントリポイント（このサブを実行）
Public Sub ExportAllQuerySQLs()
    On Error GoTo ErrHandler

    Dim dao_データベース As DAO.Database
    Dim qdf_定義 As DAO.QueryDef
    Dim app_Excel As Object, wbk_ブック As Object, wst_TOC As Object, wst_作業 As Object
    Dim str_保存先フォルダ As String, str_保存パス As String
    Dim col_対象クエリ名 As Collection
    Dim lng_インデックス As Long, lng_追加数 As Long
    Dim col_エラーログ As Collection
    Dim lng_開始位置 As Long, str_入力値 As String
    Dim lng_エラー番号 As Long, str_エラー説明 As String

    Set dao_データベース = CurrentDb
    Set col_対象クエリ名 = New Collection
    Set col_エラーログ = New Collection

    '  保存先フォルダ（Downloads）取得
    str_保存先フォルダ = GetDownloadsPath()
    If Len(str_保存先フォルダ) = 0 Then
        MsgBox "Downloads フォルダを特定できませんでした。USERPROFILE 環境変数をご確認ください。", vbExclamation
        Exit Sub
    End If
    str_保存パス = str_保存先フォルダ & "\QuerySQLExport_" & Format(Now, "yyyymmdd_hhnnss") & ".xlsx"
    ' 出力フォルダの存在と書き込み権限をチェック
    If Dir(str_保存先フォルダ, vbDirectory) = "" Then
        MsgBox "指定された保存先フォルダが存在しません: " & str_保存先フォルダ, vbCritical
        GoTo Cleanup
    End If
    Dim str_テストファイル As String
    str_テストファイル = str_保存先フォルダ & "\__AccessExportTest.tmp"
    On Error Resume Next
    Open str_テストファイル For Output As #1
    If Err.Number <> 0 Then
        On Error GoTo 0
        MsgBox "保存先フォルダに書き込むことができません。" & vbCrLf & "フォルダのアクセス権限をご確認ください: " & str_保存先フォルダ, vbCritical
        GoTo Cleanup
    End If
    Close #1
    Kill str_テストファイル
    On Error GoTo 0

    '  対象クエリ抽出（条件に合致するクエリをコレクションに追加）
    For Each qdf_定義 In dao_データベース.QueryDefs
        If IsTargetQuery(qdf_定義) Then
            col_対象クエリ名.Add qdf_定義.Name
        End If
    Next

    If col_対象クエリ名.Count = 0 Then
        MsgBox "出力対象のクエリ（SQLを持つもの）が見つかりませんでした。", vbInformation
        Exit Sub
    End If

    ' 開始位置の指定（オプション）
    lng_開始位置 = 1
    str_入力値 = InputBox("エクスポートを開始するクエリ番号 (1～" & col_対象クエリ名.Count & " ) を入力してください:", "開始位置の指定", "1")
    If str_入力値 = "" Then
        Exit Sub    ' ユーザーがキャンセル
    End If
    If Not IsNumeric(str_入力値) Then
        MsgBox "開始位置には数値を入力してください。", vbExclamation
        Exit Sub
    End If
    ' 小数や区切り文字が入力された場合は無効
    If InStr(str_入力値, ".") > 0 Or InStr(str_入力値, ",") > 0 Then
        MsgBox "開始位置には整数を入力してください。", vbExclamation
        Exit Sub
    End If
    On Error Resume Next
    lng_開始位置 = CLng(str_入力値)
    If Err.Number <> 0 Then
        Err.Clear: On Error GoTo 0
        MsgBox "開始位置の指定が不正です。", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    If lng_開始位置 < 1 Or lng_開始位置 > col_対象クエリ名.Count Then
        MsgBox "1～" & col_対象クエリ名.Count & " の範囲で開始位置を指定してください。", vbExclamation
        Exit Sub
    End If
    ' 進捗バーを開始位置に合わせて設定
    SysCmd acSysCmdInitMeter, "クエリのSQLをExcelへ出力中…", (col_対象クエリ名.Count - lng_開始位置 + 1)

    '  Excel起動（遅延バインディング）
    On Error Resume Next
    Set app_Excel = CreateObject("Excel.Application")
    On Error GoTo ErrHandler
    If app_Excel Is Nothing Then
        MsgBox "Excel を起動できませんでした。インストール状況をご確認ください。", vbCritical
        GoTo Cleanup
    End If
    app_Excel.Visible = False
    Set wbk_ブック = app_Excel.Workbooks.Add

    '  TOC（目次）シート作成
    Set wst_TOC = wbk_ブック.Sheets(1)
    wst_TOC.Name = "TOC"
    InitSheetStyle wst_TOC
    WriteTOCHeader wst_TOC

    lng_追加数 = 0

    '  各クエリの処理ループ
    For lng_インデックス = lng_開始位置 To col_対象クエリ名.Count
        Dim str_クエリ名 As String, str_SQL本文 As String, str_SQL整形 As String
        Dim str_パラメータ一覧 As String, str_シート名 As String

        str_クエリ名 = CStr(col_対象クエリ名(lng_インデックス))
        On Error Resume Next
        str_SQL本文 = dao_データベース.QueryDefs(str_クエリ名).SQL
        lng_エラー番号 = Err.Number: str_エラー説明 = Err.Description
        On Error GoTo 0
        If lng_エラー番号 <> 0 Then
            LogError col_エラーログ, str_クエリ名, "SQL取得時にエラー発生: (" & lng_エラー番号 & ") " & str_エラー説明
            Err.Clear
            On Error GoTo ErrHandler
            GoTo NextLoop
        End If
        If Len(Trim$(str_SQL本文)) = 0 Then
            LogError col_エラーログ, str_クエリ名, "SQL が空、または取得できませんでした。"
            On Error GoTo ErrHandler
            GoTo NextLoop
        End If
        On Error GoTo ErrHandler

        '  整形（Pretty Print）
        str_SQL整形 = FormatSQLPretty(str_SQL本文)
        str_パラメータ一覧 = GetQueryParametersInfo(dao_データベース.QueryDefs(str_クエリ名))

        ' ? シート生成と初期化
        str_シート名 = MakeSafeUniqueSheetName(wbk_ブック, str_クエリ名)
        On Error Resume Next
        Set wst_作業 = wbk_ブック.Sheets.Add(After:=wbk_ブック.Sheets(wbk_ブック.Sheets.Count))
        lng_エラー番号 = Err.Number: str_エラー説明 = Err.Description
        On Error GoTo 0
        If lng_エラー番号 <> 0 Then
            LogError col_エラーログ, str_クエリ名, "シート追加時にエラー発生: (" & lng_エラー番号 & ") " & str_エラー説明
            Err.Clear
            On Error GoTo ErrHandler
            GoTo NextLoop
        End If
        On Error Resume Next
        wst_作業.Name = str_シート名
        lng_エラー番号 = Err.Number: str_エラー説明 = Err.Description
        On Error GoTo 0
        If lng_エラー番号 <> 0 Then
            LogError col_エラーログ, str_クエリ名, "シート名設定時にエラー発生: (" & lng_エラー番号 & ") " & str_エラー説明
            Err.Clear
            app_Excel.DisplayAlerts = False
            wst_作業.Delete
            app_Excel.DisplayAlerts = True
            On Error GoTo ErrHandler
            GoTo NextLoop
        End If
        On Error GoTo ErrHandler
        InitSheetStyle wst_作業

        '  書き込み（メタ情報 + 整形SQL）
        With wst_作業
            .Cells(1, 1).Value = "Query Name"
            .Cells(1, 2).Value = str_クエリ名
            .Cells(2, 1).Value = "Created"
            .Cells(2, 2).Value = Now
            .Cells(3, 1).Value = "Parameters"
            .Cells(3, 2).Value = IIf(str_パラメータ一覧 = "", "(none)", str_パラメータ一覧)

            .Cells(5, 1).Value = "SQL (formatted)"
            .Cells(6, 2).Value = str_SQL整形   ' フォーマット済みSQL本文はB6セルから表示
            .Columns("A:A").ColumnWidth = 25
            .Columns("B:B").ColumnWidth = OPT_SQL_COL_WIDTH
            .Columns("B:B").WrapText = True
            .Columns("B:B").VerticalAlignment = -4160   ' 上詰め (xlVAlignTop)
        End With

        '  エディタ風シンタックスハイライト（色分け）
        If OPT_ENABLE_SYNTAX_COLOR Then
            On Error Resume Next    ' 部分書式設定失敗を吸収
            ColorizeSqlEditorStyle wst_作業.Cells(6, 2)
            On Error GoTo ErrHandler
        End If

        '  TOCシートに追記（ハイパーリンクで目次追加）
        On Error Resume Next
        AppendTOC wst_TOC, str_クエリ名, wst_作業.Name
        If Err.Number <> 0 Then
            LogError col_エラーログ, str_クエリ名, "TOC追記時にエラー発生: (" & Err.Number & ") " & Err.Description
            Err.Clear
        End If
        On Error GoTo ErrHandler

        lng_追加数 = lng_追加数 + 1
        SysCmd acSysCmdUpdateMeter, lng_追加数
NextLoop:
    Next lng_インデックス

    ' 空シート削除（デフォルトの "Sheet*" シートを削除）
    On Error Resume Next
    Dim wst_削除候補 As Object
    app_Excel.DisplayAlerts = False
    For Each wst_削除候補 In wbk_ブック.Sheets
        If wst_削除候補.Name Like "Sheet*" Then wst_削除候補.Delete
    Next wst_削除候補
    app_Excel.DisplayAlerts = True
    On Error GoTo ErrHandler

    '  保存（正常完了時）
    wbk_ブック.SaveAs str_保存パス
    wbk_ブック.Close SaveChanges:=False
    app_Excel.Quit

    SysCmd acSysCmdClearStatus
    If col_エラーログ.Count > 0 Then
        MsgBox "一部のクエリでエラーが発生しました。" & vbCrLf & _
               "保存先: " & str_保存パス & vbCrLf & vbCrLf & JoinErrors(col_エラーログ), vbExclamation
    Else
        MsgBox "クエリのSQLを整形し、Excelに出力しました！" & vbCrLf & "保存先: " & str_保存パス, vbInformation
    End If
    Exit Sub

ErrHandler:
    SysCmd acSysCmdClearStatus
    On Error Resume Next
    If Not wbk_ブック Is Nothing Then
        If lng_追加数 > 0 Then wbk_ブック.SaveAs str_保存パス
        wbk_ブック.Close False
    End If
    If Not app_Excel Is Nothing Then app_Excel.Quit
    If lng_追加数 > 0 Then
        MsgBox "処理中にエラーが発生しました: " & Err.Number & " - " & Err.Description & vbCrLf & _
               "(途中までの結果を保存しました: " & str_保存パス & ")", vbCritical
    Else
        MsgBox "処理中にエラーが発生しました: " & Err.Number & " - " & Err.Description, vbCritical
    End If
Cleanup:
End Sub

' ====== ユーティリティ関数／判定処理 ======

' Downloadsフォルダのパス取得
Private Function GetDownloadsPath() As String
    Dim str_ユーザルート As String
    str_ユーザルート = Environ$("USERPROFILE")
    If Len(str_ユーザルート) = 0 Then
        GetDownloadsPath = ""
    Else
        GetDownloadsPath = str_ユーザルート & "\Downloads"
    End If
End Function

' 対象クエリ判定（SQLを持つ選択クエリか？）
Private Function IsTargetQuery(qdf_クエリ定義 As DAO.QueryDef) As Boolean
    On Error GoTo SafeNo   ' .SQLアクセスでエラーとなるものは対象外
    Dim str_名前 As String, str_sql小文字 As String
    str_名前 = Nz(qdf_クエリ定義.Name, "")
    ' システムテーブル系・一時クエリ除外
    If Not OPT_INCLUDE_SYSTEM_QUERIES Then
        If Left$(str_名前, 1) = "~" Or Left$(str_名前, 4) = "MSys" Then GoTo SafeNo
    End If
    ' SQL文が空のQueryDefは対象外
    str_sql小文字 = LCase$(Trim$(Nz(qdf_クエリ定義.SQL, "")))
    If Len(str_sql小文字) = 0 Then GoTo SafeNo
    ' アクション系（追加/更新/削除/DDLクエリ）は対象外（オプションによる）
    If Not OPT_INCLUDE_ACTION_QUERIES Then
        If InStr(str_sql小文字, " insert ") > 0 Or Left$(str_sql小文字, 6) = "insert" Then GoTo SafeNo
        If InStr(str_sql小文字, " update ") > 0 Or Left$(str_sql小文字, 6) = "update" Then GoTo SafeNo
        If InStr(str_sql小文字, " delete ") > 0 Or Left$(str_sql小文字, 6) = "delete" Then GoTo SafeNo
        If InStr(str_sql小文字, " create ") > 0 Or InStr(str_sql小文字, " alter ") > 0 Or InStr(str_sql小文字, " drop ") > 0 Then GoTo SafeNo
    End If
    ' SELECT/UNION/TRANSFORM/PARAMETERSクエリを対象とする
    If Left$(str_sql小文字, 6) = "select" _
       Or InStr(str_sql小文字, " union ") > 0 _
       Or Left$(str_sql小文字, 9) = "transform" _
       Or Left$(str_sql小文字, 10) = "parameters" Then
        IsTargetQuery = True
        Exit Function
    End If
SafeNo:
    IsTargetQuery = False
End Function

' シート名の禁止文字・長さ・重複に対応した安全な名前を生成
Private Function MakeSafeUniqueSheetName(obj_ブック As Object, str_基底名 As String) As String
    Dim str_作業名 As String, var_禁止文字 As Variant, lng_I As Long, str_候補 As String, lng_連番 As Long
    var_禁止文字 = Array("/", "\", "*", "[", "]", ":", "?", Chr$(34))  ' シート名に使えない文字
    str_作業名 = str_基底名
    For lng_I = LBound(var_禁止文字) To UBound(var_禁止文字)
        str_作業名 = Replace$(str_作業名, var_禁止文字(lng_I), "_")
    Next
    str_作業名 = Trim$(str_作業名)
    If Len(str_作業名) = 0 Then str_作業名 = "Query"
    If Len(str_作業名) > 31 Then str_作業名 = Left$(str_作業名, 31)   ' 長過ぎる場合はカット

    str_候補 = str_作業名: lng_連番 = 1
    Do While SheetExists(obj_ブック, str_候補)
        lng_連番 = lng_連番 + 1
        ' 重複があれば末尾に連番を付加（31文字制限内に収める）
        str_候補 = Left$(str_作業名, 31 - Len(CStr(lng_連番))) & CStr(lng_連番)
        ' 連番が3桁を超える場合の調整（ "_001" の形式で付加）
        If lng_連番 > 999 Then str_候補 = Left$(str_作業名, 27) & "_" & Format(lng_連番, "000")
    Loop
    MakeSafeUniqueSheetName = str_候補
End Function

Private Function SheetExists(obj_ブック As Object, str_シート名 As String) As Boolean
    On Error Resume Next
    SheetExists = Not obj_ブック.Sheets(str_シート名) Is Nothing
    On Error GoTo 0
End Function

' クエリのパラメータ一覧文字列を取得（無い場合は空文字）
Private Function GetQueryParametersInfo(qdf_クエリ定義 As DAO.QueryDef) As String
    On Error GoTo NoParams
    Dim prm_パラメータ As DAO.Parameter, str_バッファ As String
    For Each prm_パラメータ In qdf_クエリ定義.Parameters
        str_バッファ = str_バッファ & prm_パラメータ.Name & " (Type=" & prm_パラメータ.Type & "); "
    Next
    If Len(str_バッファ) > 0 Then str_バッファ = Left$(str_バッファ, Len(str_バッファ) - 2)
    GetQueryParametersInfo = str_バッファ
    Exit Function
NoParams:
    GetQueryParametersInfo = ""
End Function

' 新規シートの初期スタイル設定
Private Sub InitSheetStyle(wst_対象 As Object)
    With wst_対象.Cells
        .Font.Name = OPT_SHEET_FONT_NAME
        .Font.Size = OPT_SHEET_FONT_SIZE
    End With
    wst_対象.Columns("A:B").HorizontalAlignment = -4131  ' xlLeft
    wst_対象.Columns("A:B").VerticalAlignment = -4160    ' xlTop
    wst_対象.Columns("A:A").ColumnWidth = 25
    wst_対象.Columns("B:B").ColumnWidth = OPT_SQL_COL_WIDTH
End Sub

' TOCシートのヘッダ行を書き込み
Private Sub WriteTOCHeader(wst_TOC対象 As Object)
    With wst_TOC対象
        InitSheetStyle wst_TOC対象
        .Cells(1, 1).Value = "Index"
        .Cells(1, 2).Value = "Query Name"
        .Cells(1, 3).Value = "Sheet"
        .Cells(1, 1).EntireRow.Font.Bold = True
        .Columns("A:C").ColumnWidth = 40
    End With
End Sub

' TOCシートへクエリ目次を追記（ハイパーリンクで該当シートA1へ）
Private Sub AppendTOC(wst_TOC対象 As Object, str_クエリ名 As String, str_シート名 As String)
    Dim lng_行 As Long
    lng_行 = wst_TOC対象.Cells(wst_TOC対象.Rows.Count, 1).End(-4162).Row + 1   ' xlUpで末尾を取得し次行へ
    If lng_行 < 2 Then lng_行 = 2
    wst_TOC対象.Cells(lng_行, 2).Value = str_クエリ名
    wst_TOC対象.Cells(lng_行, 3).Value = str_シート名
    wst_TOC対象.Hyperlinks.Add Anchor:=wst_TOC対象.Cells(lng_行, 1), Address:="", _
                       SubAddress:="'" & str_シート名 & "'!A1", TextToDisplay:="→ " & str_クエリ名
End Sub

' エラーログにメッセージを追加
Private Sub LogError(ByRef col_ログ As Collection, ByVal str_クエリ名 As String, ByVal str_メッセージ As String)
    col_ログ.Add "[" & str_クエリ名 & "] " & str_メッセージ
End Sub

Private Function JoinErrors(col_ログ As Collection) As String
    Dim lng_I As Long, arr_文字列() As String
    If col_ログ.Count = 0 Then
        JoinErrors = ""
    Else
        ReDim arr_文字列(1 To col_ログ.Count)
        For lng_I = 1 To col_ログ.Count
            arr_文字列(lng_I) = CStr(col_ログ(lng_I))
        Next
        JoinErrors = Join(arr_文字列, vbCrLf)
    End If
End Function


Private Function FormatSQLPretty(ByVal str_S As String) As String
    Dim lng_I As Long
    Dim str_Ch As String * 1
    Dim str_Out As String, str_Tok As String, str_TokUp As String
    Dim bln_InSQ As Boolean, bln_InDQ As Boolean

    ' 句の状態
    Dim bln_InSelect As Boolean
    Dim bln_InGroup As Boolean
    Dim bln_InOrder As Boolean
    Dim bln_InTransform As Boolean
    Dim bln_InPivot As Boolean

    ' トップレベルのカンマ判定用：各句内の括弧深さ
    Dim lng_ParenDepthSelect As Long
    Dim lng_ParenDepthGroup As Long
    Dim lng_ParenDepthOrder As Long
    Dim lng_ParenDepthTransform As Long

    ' 2語句判定（GROUP BY / ORDER BY）
    Dim str_PendingWord As String
    Dim str_LastClause As String

    ' 見出し句でのみ使うインデント（JOINツリーを整える）
    Dim lng_Indent As Long

    ' 正規化
    str_S = Trim$(str_S)
    str_S = Replace$(Replace$(Replace$(str_S, vbCrLf, " "), vbCr, " "), vbLf, " ")
    Do While InStr(str_S, "  ") > 0: str_S = Replace$(str_S, "  ", " "): Loop

    For lng_I = 1 To Len(str_S)
        str_Ch = Mid$(str_S, lng_I, 1)

        ' クォート状態
        If str_Ch = "'" And Not bln_InDQ Then bln_InSQ = Not bln_InSQ
        If str_Ch = """" And Not bln_InSQ Then bln_InDQ = Not bln_InDQ

        ' 句ごとの括弧深さ（トップレベルカンマ制御用）
        If Not bln_InSQ And Not bln_InDQ Then
            If bln_InSelect Then
                If str_Ch = "(" Then lng_ParenDepthSelect = lng_ParenDepthSelect + 1
                If str_Ch = ")" And lng_ParenDepthSelect > 0 Then lng_ParenDepthSelect = lng_ParenDepthSelect - 1
            End If
            If bln_InGroup Then
                If str_Ch = "(" Then lng_ParenDepthGroup = lng_ParenDepthGroup + 1
                If str_Ch = ")" And lng_ParenDepthGroup > 0 Then lng_ParenDepthGroup = lng_ParenDepthGroup - 1
            End If
            If bln_InOrder Then
                If str_Ch = "(" Then lng_ParenDepthOrder = lng_ParenDepthOrder + 1
                If str_Ch = ")" And lng_ParenDepthOrder > 0 Then lng_ParenDepthOrder = lng_ParenDepthOrder - 1
            End If
            If bln_InTransform Then
                If str_Ch = "(" Then lng_ParenDepthTransform = lng_ParenDepthTransform + 1
                If str_Ch = ")" And lng_ParenDepthTransform > 0 Then lng_ParenDepthTransform = lng_ParenDepthTransform - 1
            End If

            ' 括弧でインデントは基本増やさない（SELECT~FROM間の( )に過反応しない設計）
            If str_Ch = ")" And Not (bln_InSelect Or bln_InGroup Or bln_InOrder Or bln_InTransform) Then
                If lng_Indent > 0 Then
                    lng_Indent = lng_Indent - 1
                    str_Out = RTrim$(str_Out) & vbCrLf & String$(lng_Indent * OPT_INDENT_SPACES, " ")
                End If
            End If
        End If

        str_Tok = str_Tok & str_Ch

        ' 区切り
        If (str_Ch = " " Or str_Ch = "," Or str_Ch = "(" Or str_Ch = ")" Or lng_I = Len(str_S)) Then
            str_TokUp = UCase$(Trim$(str_Tok))

            If Not bln_InSQ And Not bln_InDQ Then
                ' ===== 2語句：GROUP BY / ORDER BY =====
                If (str_PendingWord = "GROUP" And str_TokUp = "BY") Or (str_PendingWord = "ORDER" And str_TokUp = "BY") Then
                    str_Out = RTrim$(str_Out)
                    If Len(str_Out) > 0 Then str_Out = str_Out & vbCrLf
                    str_Out = str_Out & String$(lng_Indent * OPT_INDENT_SPACES, " ") & str_PendingWord & " BY"
                    str_LastClause = str_PendingWord & " BY"
                    bln_InGroup = (str_PendingWord = "GROUP")
                    bln_InOrder = (str_PendingWord = "ORDER")
                    bln_InSelect = False: bln_InTransform = False: bln_InPivot = False
                    str_PendingWord = ""
                ' ===== JOIN（INNER/LEFT/RIGHT の直後）=====
                ElseIf str_TokUp = "JOIN" Then
                    str_Out = RTrim$(str_Out)
                    If Len(str_Out) > 0 Then str_Out = str_Out & vbCrLf
                    str_Out = str_Out & String$(lng_Indent * OPT_INDENT_SPACES, " ") & "JOIN"
                    str_LastClause = "JOIN"
                ' ===== 句の開始（1語） =====
                ElseIf str_TokUp = "TRANSFORM" Or str_TokUp = "SELECT" Or str_TokUp = "FROM" Or _
                       str_TokUp = "WHERE" Or str_TokUp = "HAVING" Or _
                       str_TokUp = "UNION" Or str_TokUp = "UNION ALL" Or _
                       str_TokUp = "PIVOT" Or _
                       str_TokUp = "PARAMETERS" Or str_TokUp = "TRANSFORM" Or str_TokUp = "PIVOT" Then
                    str_Out = RTrim$(str_Out)
                    If Len(str_Out) > 0 Then str_Out = str_Out & vbCrLf
                    str_Out = str_Out & String$(lng_Indent * OPT_INDENT_SPACES, " ") & str_TokUp
                    str_LastClause = str_TokUp

                    ' 句フラグ
                    bln_InSelect = (str_TokUp = "SELECT")
                    bln_InTransform = (str_TokUp = "TRANSFORM")
                    bln_InPivot = (str_TokUp = "PIVOT")
                    If str_TokUp = "FROM" Or str_TokUp = "WHERE" Or str_TokUp = "HAVING" Or _
                       str_TokUp = "UNION" Or str_TokUp = "UNION ALL" Then
                        bln_InSelect = False: bln_InTransform = False: bln_InGroup = False: bln_InOrder = False: bln_InPivot = False
                    End If

                    ' 括弧深さリセット（句をまたぐ）
                    If bln_InSelect Then lng_ParenDepthSelect = 0
                    If bln_InTransform Then lng_ParenDepthTransform = 0
                    If bln_InGroup Then lng_ParenDepthGroup = 0
                    If bln_InOrder Then lng_ParenDepthOrder = 0

                ' ===== AND/OR は WHERE/HAVING で行頭 =====
                ElseIf (str_TokUp = "AND" Or str_TokUp = "OR") And (str_LastClause = "WHERE" Or str_LastClause = "HAVING") Then
                    str_Out = RTrim$(str_Out) & vbCrLf & String$(lng_Indent * OPT_INDENT_SPACES, " ") & str_TokUp

                ' ===== ON は JOIN条件の行頭 =====
                ElseIf str_TokUp = "ON" Then
                    str_Out = RTrim$(str_Out) & vbCrLf & String$(lng_Indent * OPT_INDENT_SPACES, " ") & "ON"

                ' ===== GROUP / ORDER は BY待ち =====
                ElseIf str_TokUp = "GROUP" Or str_TokUp = "ORDER" Then
                    str_PendingWord = str_TokUp
                    bln_InGroup = (str_TokUp = "GROUP") ' 仮置き（BY確定で正式ON）
                    bln_InOrder = (str_TokUp = "ORDER")

                ' ===== JOIN の前置詞（INNER/LEFT/RIGHT）はそのまま出力 =====
                ElseIf str_TokUp = "INNER" Or str_TokUp = "LEFT" Or str_TokUp = "RIGHT" Then
                    str_Out = AppendWithSpace(str_Out, str_TokUp)

                Else
                    ' 通常トークンはそのまま
                    str_Out = AppendWithSpace(str_Out, Trim$(str_Tok))
                End If
            Else
                ' クォート中は生出力
                str_Out = AppendWithSpace(str_Out, Trim$(str_Tok))
            End If

            ' 記号処理
            If str_Ch = "," Then
                Dim bln_Break As Boolean: bln_Break = True
                ' SELECT / GROUP BY / ORDER BY / TRANSFORM のトップレベルのみ改行
                If bln_InSelect And lng_ParenDepthSelect > 0 Then bln_Break = False
                If bln_InGroup And lng_ParenDepthGroup > 0 Then bln_Break = False
                If bln_InOrder And lng_ParenDepthOrder > 0 Then bln_Break = False
                If bln_InTransform And lng_ParenDepthTransform > 0 Then bln_Break = False

                If bln_Break And (bln_InSelect Or bln_InGroup Or bln_InOrder Or bln_InTransform) Then
                    str_Out = RTrim$(str_Out) & vbCrLf & String$(lng_Indent * OPT_INDENT_SPACES, " ")
                Else
                    str_Out = str_Out & " "
                End If

            ElseIf str_Ch = "(" Then
                ' 句中の( は改行を誘発しない（関数引数の集中を維持）
                str_Out = str_Out & " "

            ElseIf str_Ch = ")" Then
                str_Out = str_Out & " "

            Else
                str_Out = str_Out & " "
            End If

            ' 次へ
            str_Tok = ""
        End If
    Next lng_I

    ' 残りの保留（念のため）
    If Len(str_PendingWord) > 0 Then
        str_Out = RTrim$(str_Out) & vbCrLf & str_PendingWord
    End If

    ' 連続改行の圧縮
    str_Out = Trim$(str_Out)
    Do While InStr(str_Out, vbCrLf & vbCrLf & vbCrLf) > 0
        str_Out = Replace$(str_Out, vbCrLf & vbCrLf & vbCrLf, vbCrLf & vbCrLf)
    Loop

    FormatSQLPretty = str_Out
End Function


' 単語を末尾に追加（必要なときだけ空白を入れる）
Private Function AppendWithSpace(ByVal str_Base As String, ByVal str_Add As String) As String
    If Len(str_Add) = 0 Then
        AppendWithSpace = str_Base
    ElseIf Len(str_Base) = 0 Then
        AppendWithSpace = str_Add
    ElseIf Right$(str_Base, 1) = " " Or Right$(str_Base, 2) = vbCrLf Then
        AppendWithSpace = str_Base & str_Add
    Else
        AppendWithSpace = str_Base & " " & str_Add
    End If
End Function


' ====== エディタ風シンタックスハイライト（Excel上でSQLを色分け） ======

' 指定セル内のSQL文字列を色分け（主要句・補助句・関数・文字列リテラル・日付リテラル・識別子・数値・演算子）
Public Sub ColorizeSqlEditorStyle(ByVal obj_セル As Object)
    On Error GoTo SafeExit   ' 部分的な書式設定で稀に発生する例外に対処
    Dim str_本文 As String
    str_本文 = CStr(obj_セル.Value)
    If Len(str_本文) = 0 Then Exit Sub

    Dim col_除外範囲 As Collection
    Set col_除外範囲 = BuildExcludedRanges(str_本文)  ' クォート/日付/#囲み を色分け対象から除外

    ' 1) 主要句（濃い青＋太字）
    Dim arr_主要句 As Variant
    arr_主要句 = Array("PARAMETERS", "TRANSFORM", "PIVOT", _
                       "SELECT", "FROM", "WHERE", "GROUP BY", "HAVING", "ORDER BY", _
                       "INNER JOIN", "LEFT JOIN", "RIGHT JOIN", "JOIN", "ON", _
                       "UNION", "UNION ALL", "WITH OWNERACCESS OPTION")
    HighlightList obj_セル, str_本文, arr_主要句, col_除外範囲, RGB(0, 0, 160), True, False, False

    ' 2) 補助キーワード（青）
    Dim arr_補助 As Variant
    arr_補助 = Array("DISTINCT", "DISTINCTROW", "TOP", "AS", _
                     "BETWEEN", "IN", "LIKE", "NOT", "IS NULL", "IS NOT NULL", _
                     "TRUE", "FALSE", "ALL")
    HighlightList obj_セル, str_本文, arr_補助, col_除外範囲, RGB(0, 0, 192), False, False, False

    ' 3) 関数名（紫：直後に"("があるもの）
    Dim arr_関数 As Variant
    arr_関数 = Array("SUM", "COUNT", "MIN", "MAX", "AVG", "ROUND", _
                     "NZ", "IIF", "SWITCH", "CHOOSE", _
                     "DATE", "TIME", "NOW", "DATEADD", "DATEDIFF", "DATESERIAL", "TIMESERIAL", _
                     "FORMAT", "LEN", "MID", "LEFT", "RIGHT", "VAL", "STR", "CSTR", "CLNG", "CDATE", "CBOOL", "ISNULL", "ABS")
    HighlightList obj_セル, str_本文, arr_関数, col_除外範囲, RGB(128, 0, 128), False, False, True

    ' 4) 文字列リテラル（"..." および '...'）→ 緑
    ColorQuotedLiterals obj_セル, str_本文, """", RGB(0, 128, 0)    ' ダブルクォート囲み
    ColorQuotedLiterals obj_セル, str_本文, "'", RGB(0, 128, 0)     ' シングルクォート囲み

    ' 5) 日付リテラル（#...#）→ ティール（深緑青色）
    ColorHashDateLiterals obj_セル, str_本文, RGB(0, 128, 128)

    ' 6) 角括弧囲み識別子 [Field] / [Table] → 茶色
    ColorBracketIdentifiers obj_セル, str_本文, RGB(128, 64, 0)

    ' 7) 数値リテラル（整数/小数/指数表記）→ 橙色
    ColorNumbers obj_セル, str_本文, col_除外範囲, RGB(255, 128, 0)

    ' 8) 演算子（=, <>, <=, >=, +, -, *, /, & など）→ グレー
    ColorOperators obj_セル, str_本文, col_除外範囲, RGB(96, 96, 96)
SafeExit:
End Sub

' --- 色分け処理の下請け ---

Private Sub HighlightList(ByVal obj_セル As Object, ByVal str_本文 As String, _
                          ByVal arr_対象 As Variant, ByVal col_除外範囲 As Collection, _
                          ByVal lng_色 As Long, ByVal bln_太字 As Boolean, ByVal bln_イタリック As Boolean, _
                          ByVal bln_直後に括弧要件 As Boolean)
    Dim lng_I As Long
    For lng_I = LBound(arr_対象) To UBound(arr_対象)
        HighlightOne obj_セル, str_本文, CStr(arr_対象(lng_I)), col_除外範囲, lng_色, bln_太字, bln_イタリック, bln_直後に括弧要件
    Next
End Sub

Private Sub HighlightOne(ByVal obj_セル As Object, ByVal str_本文 As String, ByVal str_キーワード As String, _
                         ByVal col_除外範囲 As Collection, ByVal lng_色 As Long, _
                         ByVal bln_太字 As Boolean, ByVal bln_イタリック As Boolean, _
                         ByVal bln_直後に括弧要件 As Boolean)
    Dim lng_位置 As Long, lng_長さ As Long, lng_開始 As Long
    lng_長さ = Len(str_キーワード)
    lng_開始 = 1
    Do
        lng_位置 = InStr(lng_開始, str_本文, str_キーワード, vbTextCompare)
        If lng_位置 = 0 Then Exit Do

        If IsWholeWord(str_本文, lng_位置, lng_長さ) Then
            If Not IsInsideExcluded(lng_位置, lng_長さ, col_除外範囲) Then
                If Not bln_直後に括弧要件 Or HasParenAfter(str_本文, lng_位置 + lng_長さ) Then
                    With obj_セル.Characters(Start:=lng_位置, length:=lng_長さ).Font
                        .Color = lng_色
                        .Bold = bln_太字
                        .Italic = bln_イタリック
                    End With
                End If
            End If
        End If
        lng_開始 = lng_位置 + lng_長さ
    Loop
End Sub

Private Function HasParenAfter(ByVal str_本文 As String, ByVal lng_開始 As Long) As Boolean
    Dim lng_j As Long, str_c As String
    For lng_j = lng_開始 To Len(str_本文)
        str_c = Mid$(str_本文, lng_j, 1)
        If str_c <> " " And str_c <> vbTab Then
            HasParenAfter = (str_c = "(")
            Exit Function
        End If
    Next
End Function

' --- 文字列リテラルの色付け ---
Private Sub ColorQuotedLiterals(ByVal obj_セル As Object, ByVal str_本文 As String, _
                                ByVal str_クォート As String, ByVal lng_色 As Long)
    Dim lng_j As Long, lng_開始 As Long
    Dim bln_中 As Boolean, str_c As String
    For lng_j = 1 To Len(str_本文)
        str_c = Mid$(str_本文, lng_j, 1)
        If str_c = str_クォート Then
            If Not bln_中 Then
                lng_開始 = lng_j: bln_中 = True
            Else
                Call ColorRange(obj_セル, lng_開始, lng_j - lng_開始 + 1, lng_色)
                bln_中 = False
            End If
        End If
    Next lng_j
End Sub

Private Sub ColorHashDateLiterals(ByVal obj_セル As Object, ByVal str_本文 As String, ByVal lng_色 As Long)
    Dim lng_j As Long, lng_開始 As Long
    Dim bln_中 As Boolean, str_c As String
    For lng_j = 1 To Len(str_本文)
        str_c = Mid$(str_本文, lng_j, 1)
        If str_c = "#" Then
            If Not bln_中 Then
                lng_開始 = lng_j: bln_中 = True
            Else
                Call ColorRange(obj_セル, lng_開始, lng_j - lng_開始 + 1, lng_色)
                bln_中 = False
            End If
        End If
    Next lng_j
End Sub

Private Sub ColorBracketIdentifiers(ByVal obj_セル As Object, ByVal str_本文 As String, ByVal lng_色 As Long)
    Dim lng_j As Long, lng_開始 As Long
    Dim bln_角括弧中 As Boolean, str_c As String
    For lng_j = 1 To Len(str_本文)
        str_c = Mid$(str_本文, lng_j, 1)
        If str_c = "[" Then
            lng_開始 = lng_j: bln_角括弧中 = True
        End If
        If str_c = "]" And bln_角括弧中 Then
            Call ColorRange(obj_セル, lng_開始, lng_j - lng_開始 + 1, lng_色)
            bln_角括弧中 = False
        End If
    Next lng_j
End Sub

Private Sub ColorNumbers(ByVal obj_セル As Object, ByVal str_本文 As String, ByVal col_除外範囲 As Collection, ByVal lng_色 As Long)
    Dim obj_RegEx As Object
    Set obj_RegEx = CreateObject("VBScript.RegExp")
    obj_RegEx.Pattern = "(\b\d+(\.\d+)?([Ee][+-]?\d+)?\b)"
    obj_RegEx.Global = True
    Dim obj_Matches As Object, obj_m As Object
    If obj_RegEx.Test(str_本文) Then
        Set obj_Matches = obj_RegEx.Execute(str_本文)
        For Each obj_m In obj_Matches
            If Not IsInsideExcluded(obj_m.FirstIndex + 1, obj_m.length, col_除外範囲) Then   ' FirstIndexは0始まり
                Call ColorRange(obj_セル, obj_m.FirstIndex + 1, obj_m.length, lng_色)
            End If
        Next
    End If
End Sub

Private Sub ColorOperators(ByVal obj_セル As Object, ByVal str_本文 As String, ByVal col_除外範囲 As Collection, ByVal lng_色 As Long)
    Dim arr_演算子 As Variant
    arr_演算子 = Array("=", "<>", "<=", ">=", "<", ">", "+", "-", "*", "/", "&")
    Dim var_演算子 As Variant, lng_位置 As Long
    For Each var_演算子 In arr_演算子
        lng_位置 = 1
        Do
            lng_位置 = InStr(lng_位置, str_本文, var_演算子)
            If lng_位置 = 0 Then Exit Do
            ' 前後とも英数字でない（演算子として独立）場合のみ着色
            If lng_位置 > 1 And lng_位置 < Len(str_本文) Then
                If Not ((Mid$(str_本文, lng_位置 - 1, 1) Like "[0-9A-Za-z]") Or (Mid$(str_本文, lng_位置 + 1, 1) Like "[0-9A-Za-z]")) Then
                    If Not IsInsideExcluded(lng_位置, Len(var_演算子), col_除外範囲) Then
                        Call ColorRange(obj_セル, lng_位置, Len(var_演算子), lng_色)
                    End If
                End If
            End If
            lng_位置 = lng_位置 + Len(var_演算子)
        Loop
    Next var_演算子
End Sub

' === 色付けユーティリティ ===

Private Function BuildExcludedRanges(ByVal str_本文 As String) As Collection
    Dim col_範囲 As New Collection
    ' シングル/ダブルクォート、#で囲まれた範囲、[]で囲まれた範囲を収集
    Dim lng_I As Long, str_c As String, bln_SQ As Boolean, bln_DQ As Boolean, bln_Hash As Boolean, bln_Bracket As Boolean
    Dim lng_SQ開始 As Long, lng_DQ開始 As Long, lng_Hash開始 As Long, lng_Bracket開始 As Long
    For lng_I = 1 To Len(str_本文)
        str_c = Mid$(str_本文, lng_I, 1)
        If str_c = "'" Then
            If Not bln_DQ Then
                If Not bln_SQ Then
                    lng_SQ開始 = lng_I: bln_SQ = True
                Else
                    col_範囲.Add Array(lng_SQ開始, lng_I - lng_SQ開始 + 1)
                    bln_SQ = False
                End If
            End If
        ElseIf str_c = """" Then
            If Not bln_SQ Then
                If Not bln_DQ Then
                    lng_DQ開始 = lng_I: bln_DQ = True
                Else
                    col_範囲.Add Array(lng_DQ開始, lng_I - lng_DQ開始 + 1)
                    bln_DQ = False
                End If
            End If
        ElseIf str_c = "#" Then
            If Not bln_SQ And Not bln_DQ Then
                If Not bln_Hash Then
                    lng_Hash開始 = lng_I: bln_Hash = True
                Else
                    col_範囲.Add Array(lng_Hash開始, lng_I - lng_Hash開始 + 1)
                    bln_Hash = False
                End If
            End If
        ElseIf str_c = "[" Then
            If Not bln_SQ And Not bln_DQ Then
                lng_Bracket開始 = lng_I: bln_Bracket = True
            End If
        ElseIf str_c = "]" Then
            If bln_Bracket And Not bln_SQ And Not bln_DQ Then
                col_範囲.Add Array(lng_Bracket開始, lng_I - lng_Bracket開始 + 1)
                bln_Bracket = False
            End If
        End If
    Next lng_I
    Set BuildExcludedRanges = col_範囲
End Function

Private Function IsInsideExcluded(ByVal lng_位置 As Long, ByVal lng_長さ As Long, ByVal col_除外範囲 As Collection) As Boolean
    Dim var_項目 As Variant
    For Each var_項目 In col_除外範囲
        Dim lng_開始 As Long, lng_幅 As Long
        lng_開始 = var_項目(1): lng_幅 = var_項目(2)
        If lng_位置 >= lng_開始 And lng_位置 < lng_開始 + lng_幅 _
           Or (lng_位置 + lng_長さ - 1 >= lng_開始 And lng_位置 + lng_長さ - 1 < lng_開始 + lng_幅) _
           Or (lng_位置 < lng_開始 And lng_位置 + lng_長さ - 1 >= lng_開始 + lng_幅 - 1) Then
            IsInsideExcluded = True
            Exit Function
        End If
    Next
    IsInsideExcluded = False
End Function

Private Function IsWholeWord(ByVal str_本文 As String, ByVal lng_位置 As Long, ByVal lng_長さ As Long) As Boolean
    Dim str_前 As String, str_後 As String
    str_前 = ""
    str_後 = ""
    If lng_位置 > 1 Then str_前 = Mid$(str_本文, lng_位置 - 1, 1)
    If lng_位置 + lng_長さ <= Len(str_本文) Then str_後 = Mid$(str_本文, lng_位置 + lng_長さ, 1)
    ' 前後が英数字またはアンダースコアでない場合、その単語は独立している
    If (str_前 = "" Or str_前 Like "[!0-9A-Za-z_]" Or str_前 Like Space(1)) _
       And (str_後 = "" Or str_後 Like "[!0-9A-Za-z_]" Or str_後 Like Space(1)) Then
        IsWholeWord = True
    Else
        IsWholeWord = False
    End If
End Function

Private Sub ColorRange(ByVal obj_セル As Object, ByVal lng_開始 As Long, ByVal lng_長さ As Long, ByVal lng_色 As Long)
    With obj_セル.Characters(Start:=lng_開始, length:=lng_長さ).Font
        .Color = lng_色
        .Bold = False
        .Italic = False
    End With
End Sub


' =========================
' 参照設定ユーティリティ
' =========================

' 入口：必要な参照を一括で有効化（既にあるものはスキップ）
Public Sub EnsureReferencesForExport()
    On Error GoTo ErrHandler
    Dim col_ログ As Collection: Set col_ログ = New Collection
    
    ' 必須：ACEDAO（DAOの型解決を安定させる）
    EnsureRefGUID "{4AC9E1DA-5BAD-4AC7-86E3-24F4CDCECA28}", 1, 0, _
                  "Microsoft Office Access database engine Object Library (ACEDAO)", col_ログ
    
    ' 推奨：VBScript 正規表現（将来早期バインドに切替える場合に有用）
    EnsureRefGUID "{3F4DACA7-160D-11D2-A8E9-00104B365C9F}", 5, 5, _
                  "Microsoft VBScript Regular Expressions 5.5", col_ログ
    
    ' 任意：Scripting Runtime（Dictionary/FSOを使う拡張がある場合）
    EnsureRefGUID "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0, _
                  "Microsoft Scripting Runtime", col_ログ
    
    ' 情報表示
    Dim str_メッセージ As String
    str_メッセージ = "参照設定の確認・追加が完了しました。" & vbCrLf & vbCrLf & JoinLog(col_ログ)
    MsgBox str_メッセージ, vbInformation, "EnsureReferencesForExport"
    Exit Sub
    
ErrHandler:
    MsgBox "参照設定の処理でエラーが発生しました: " & Err.Number & " - " & Err.Description, vbCritical
End Sub

' 指定GUID/バージョンの参照が無ければ追加
Private Sub EnsureRefGUID(ByVal str_GUID As String, ByVal lng_メジャー As Long, ByVal lng_マイナー As Long, _
                          ByVal str_名称 As String, ByRef col_ログ As Collection)
    On Error GoTo AddRef
    Dim ref_参照 As Reference
    For Each ref_参照 In Application.References
        If StrComp(ref_参照.guid, str_GUID, vbTextCompare) = 0 Then
            ' 既に同GUIDの参照がある（バージョン違いでも可とみなす）
            col_ログ.Add "?? 既に有効: " & str_名称 & "  (GUID=" & str_GUID & ")"
            Exit Sub
        End If
    Next ref_参照
    
AddRef:
    On Error GoTo Fail
    Application.References.AddFromGuid str_GUID, lng_メジャー, lng_マイナー
    col_ログ.Add "? 追加: " & str_名称 & "  (GUID=" & str_GUID & ", v" & lng_メジャー & "." & lng_マイナー & ")"
    Exit Sub
    
Fail:
    col_ログ.Add "? 追加失敗: " & str_名称 & "  (GUID=" & str_GUID & ", v" & lng_メジャー & "." & lng_マイナー & ") - " & Err.Description
    Err.Clear
End Sub

' ログ整形
Private Function JoinLog(col_ログ As Collection) As String
    If col_ログ Is Nothing Or col_ログ.Count = 0 Then
        JoinLog = "（変更なし）"
    Else
        Dim lng_I As Long, arr_文字列() As String
        ReDim arr_文字列(1 To col_ログ.Count)
        For lng_I = 1 To col_ログ.Count
            arr_文字列(lng_I) = CStr(col_ログ(lng_I))
        Next
        JoinLog = Join(arr_文字列, vbCrLf)
    End If
End Function