クエリの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