クエリのSQLを一括出力する関数

テーブル定義と同じ要領で。
パラメータに関する調査をするところで、クエリ自体に不備が
ある場合はエラーが出ますが、その情報も出力しています。
(お掃除が苦手な方向け)

Public Function DumpQueryDef(sDBFileName As String) As Boolean
  Dim db As DAO.Database
  Dim qdf As DAO.QueryDef
  Dim fs As FileSystemObject
  Dim ts As TextStream
  Dim sPath As String
  Dim buf As String
  Dim prm As DAO.Parameter
  Dim qtype As String
  Set fs = New FileSystemObject
  On Error GoTo Trap
    If Dir(sDBFileName) = "" Then
    DumpQueryDef = False
    Exit Function
  End If
  
  Set db = DBEngine.OpenDatabase(sDBFileName, , True)
  sPath = Left(db.Name, InStrRev(db.Name, ".") - 1)
  If Dir(sPath, vbDirectory) = "" Then MkDir sPath
  If Dir(sPath & "\QueryDefs", vbDirectory) = "" Then MkDir sPath & "\QueryDefs"
  sPath = sPath & "\QueryDefs"
  For Each qdf In db.QueryDefs
    Select Case qdf.Type
    
    Case dbQAction
    qtype = "アクションクエリ"
    Case dbQAppend
      qtype = "追加クエリ"
    Case dbQCompound
      qtype = "複合クエリ"
    Case dbQCrosstab
      qtype = "クロス集計クエリ"
    Case dbQDDL
      qtype = "DDLクエリ"
    Case dbQDelete
      qtype = "削除クエリ"
    Case dbQMakeTable
      qtype = "テーブル作成クエリ"
    Case dbQProcedure
      qtype = "ストアドプロシージャ実行"
    Case dbQSelect
      qtype = "選択クエリ"
    Case dbQSetOperation
      qtype = "ユニオンクエリ"
    Case dbQSPTBulk
      qtype = "一括操作クエリ"
    Case dbQSQLPassThrough
      qtype = "SQL パススルー クエリ(" & qdf.Connect & ")"
    Case dbQUpdate
      qtype = "更新クエリ"
    End Select
    
    Set ts = fs.CreateTextFile(sPath & "\" & qtype & "_" & qdf.Name & ".txt", True)
    ts.WriteLine qdf.Name & vbTab & "クエリの種類:" & qtype
    buf = qdf.SQL
    '//ToDo:SQLの整形
    buf = Replace(buf, "SELECT ", "SELECT " & vbCrLf & vbTab, , , vbBinaryCompare) 'SELECT
    buf = Replace(buf, ", ", vbCrLf & vbTab & ", ", , , vbBinaryCompare) 'デリミタ
'   buf = Replace(buf, "FROM ", "FROM " & vbCrLf & vbTab, , , vbBinaryCompare) 'FROM
    buf = Replace(buf, "LEFT JOIN ", vbCrLf & "LEFT JOIN ", , , vbBinaryCompare) 'LEFT JOIN
    buf = Replace(buf, "INNER JOIN ", vbCrLf & "INNER JOIN ", , , vbBinaryCompare) 'INNER JOIN
    buf = Replace(buf, "RIGHT JOIN ", vbCrLf & "RIGHT JOIN ", , , vbBinaryCompare) 'RIGHT JOIN
    buf = Replace(buf, "GROUP BY ", "GROUP BY " & vbCrLf & vbTab, , , vbBinaryCompare) 'GROUP BY
    buf = Replace(buf, "WHERE ", "WHERE " & vbCrLf & vbTab, , , vbBinaryCompare) 'WHERE
    buf = Replace(buf, "ORDER BY ", "ORDER BY " & vbCrLf & vbTab, , , vbBinaryCompare) 'ORDER BY
    buf = Replace(buf, " AND ", " " & vbCrLf & "AND ", , , vbBinaryCompare)
    buf = Replace(buf, " OR ", " " & vbCrLf & "OR ", , , vbBinaryCompare)
    
    ts.WriteLine buf
    On Error GoTo PRM_Err
    If qdf.Parameters.Count > 0 Then
      ts.WriteLine "パラメータ名" & vbTab & "型" & vbTab & "値"
      For Each prm In qdf.Parameters
        ts.WriteLine prm.Name & vbTab & prm.Type & vbTab & prm.Value
      Next prm
    End If
rp:
    On Error GoTo Trap
    ts.Close
  Next qdf
  
  DumpQueryDef = True
  Exit Function
Trap:
  DumpQueryDef = False
  Exit Function
PRM_Err:
ts.WriteLine Err.Number & Err.Description
Resume rp
End Function