Access97のテーブル、クエリー、フォームなどのフィールドや構成をエクセルなどに移す方法

Access97のあるひとつのmdbの中にあるテーブル、クエリー、フォーム、レポート、マクロ、モジュールの構成をエクセルなどに洗い出したいのですが。

ツールの解析→データベースの解析でエクセルファイルに出力という方法を見つけました。
しかし、他にももっと効率の良い方法や、どこかからツールをダウンロードして洗い出しができるであるとか、何かあったら教えてもらいたいです。
お願いします。

No.2 回答者： noname#4564 回答日時： 2003/01/12 08:59

参考URLで紹介されている、「Access オブジェクトをテキストファイルに変換する方法」を工夫すれば比較的簡単にできるかもしれません。

参考URL：http://www.f3.dion.ne.jp/~element/msaccess/AcTip …

この回答へのお礼

回答ありがとうございます。
参考にしてみます。

お礼日時：2003/01/15 21:36

No.1 回答者： noname#4564 回答日時： 2003/01/11 23:35

HotDocumentとかはどうですか？私も使ったことはありませんが。

Vecterを探せば、よいものがあるかもしれません。

既存のツールでは不満、自分の使い勝手をよりよく（痒いところに手が届くように）したい、ということでしたら、手間は掛かりますが、自前でツールを書くのが一番かもしれません。

参考までに、以前に作ったExcel出力プログラムの一部を抜粋します。
(この掲示板はタグが使えないので、インデントが潰れて *** 死ぬほど *** 読みにくいですが、興味がおありでしたら頑張って読んでみてください)

Option Compare Database
Option Explicit

Public Function fncObjListExcelOutPut(ByVal strDbName As String, _
ByVal strOutPutPath As String, _
ByVal blnDscrptnOutPut As Boolean, _
ByVal blnDbFullPathOutPut As Boolean, _
ByVal blnLinkFullPathOutPut As Boolean, _
ByVal lngMode As Long) As Boolean

'**********************************************************************************************
'
'機能概要：　指定データベース内のオブジェクト一覧をExcelシートに出力する。
'
'引　　数：　strOutPutPath 出力先ファイル名(フルパス)
'
' blnDscrptnOutPut オブジェクトの「説明」(Description)プロパティの出力有無。
' blnDbFullPathOutPut Databaseのフルパス出力有無。
' blnLinkFullPathOutPut リンクテーブル接続先のフルパス出力有無。
'
' lngMode 処理モード :
' pCstLngFileNewMake ファイルを新規作成。
' pCstLngFileExist ファイルがすでに存在。
'
'備　　考： 引数の妥当性検査は行わない。関数呼出側で事前にチェックすること。
'
'**********************************************************************************************

Dim ExlApp As Excel.Application
Dim ExlBook As Excel.Workbook
Dim ExlSheet As Excel.Worksheet
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSql As String
Dim strSqlWh As String
Dim strSqlOrder As String
Dim strMsg As String
Dim strOutPutDbPath As String
Dim i As Long
Dim lngCellsX As Long 'Excelシートのタテ座標
Dim lngSheetCount As Long
Dim blnRet As Boolean
Dim blnErrFlg As Boolean
Const lngAccObjTypeCount As Long = 6

'対象ファイルの存在を確認。
If Not ChkMdb(strDbName) Then
Beep
Call MsgBox("処理を中止します。", vbExclamation, "中止")
Exit Function
End If

'初期値。
blnErrFlg = False

If blnDbFullPathOutPut Then
'フルパスを表示。
strOutPutDbPath = strDbName
Else
'ファイル名のみ。
strOutPutDbPath = Dir(strDbName)
End If

strSql = "SELECT"
strSql = strSql & " COUNT (*)"
strSql = strSql & " FROM"
strSql = strSql & " [tblObject]"
strSql = strSql & " WHERE"
strSql = strSql & " [ImportFlg] = TRUE"

DoCmd.Hourglass True

#If DEBUG_MODE Then
#Else
On Error GoTo Err_Line
#End If


Set db = CurrentDb
Set rs = db.OpenRecordset(strSql, dbOpenSnapshot)

If rs.Fields(0).Value = 0 Then
DoCmd.Hourglass False
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing

strMsg = "一覧表に出力するオブジェクトを選択してください。"
strMsg = strMsg & vbCrLf & "処理を中止します。"
Beep
Call MsgBox(strMsg, vbExclamation, "中止")

'オブジェクト選択画面を開く。
Call Forms("frmMain").cmdSelectObj_Click
Exit Function
End If

rs.Close

Call SysCmd(acSysCmdSetStatus, "Excel Bookの準備中です・・・。")

'Excelのインスタンスを生成。
Set ExlApp = CreateObject("Excel.Application.8")

'確認メッセージを抑止。(Accessでいうところの DoCmd.SetWarnings False とおなじ趣旨)
ExlApp.DisplayAlerts = False

If lngMode = pCstLngFileNewMake Then
'新規ワークブックを生成
Set ExlBook = ExlApp.Workbooks.Add()
ElseIf lngMode = pCstLngFileExist Then
'既存ワークブックを参照
Set ExlBook = ExlApp.Workbooks.Open(strOutPutPath, , False)
End If

lngSheetCount = ExlBook.Worksheets.Count

'ワークシートに不足があれば追加し、ワークシート名を変更。
If lngSheetCount < lngAccObjTypeCount Then
Call SysCmd(acSysCmdSetStatus, "Sheetを追加しています・・・。 ( Sheet " & CStr(i) & " )")
For i = lngSheetCount + 1 To lngAccObjTypeCount
Set ExlSheet = ExlBook.Worksheets.Add
Next
End If

Call SysCmd(acSysCmdSetStatus, "Excel Sheetの準備中です・・・。")

On Error Resume Next 'Sheet名が重複するエラーは無視して続行。(強引！)
For i = 1 To lngAccObjTypeCount
Set ExlSheet = ExlBook.Worksheets(i)
If i = acTable + 1 Then
ExlSheet.Name = "Table"
ElseIf i = acQuery + 1 Then
ExlSheet.Name = "Query"
ElseIf i = acForm + 1 Then
ExlSheet.Name = "Form"
ElseIf i = acReport + 1 Then
ExlSheet.Name = "Report"
ElseIf i = acMacro + 1 Then
ExlSheet.Name = "Macro"
ElseIf i = acModule + 1 Then
ExlSheet.Name = "Module"
End If
Next
On Error GoTo 0

#If DEBUG_MODE Then
#Else
On Error GoTo Err_Line
#End If

'標題の設定
'**** Cells(タテ、ヨコ)の形式で参照すること。 ****

Set ExlSheet = ExlBook.Worksheets("Table")
If ExlSheet.StandardWidth < 16 Then
ExlSheet.StandardWidth = 16
End If
ExlSheet.Cells(1, 1).Value = "データベース :"
ExlSheet.Cells(1, 2).Value = strOutPutDbPath
ExlSheet.Cells(2, 1).Value = "テーブル名"
ExlSheet.Cells(2, 2).Value = "リンク先"
ExlSheet.Cells(2, 3).Value = "作成日時"
ExlSheet.Cells(2, 4).Value = "更新日時"
ExlSheet.Cells(2, 5).Value = "説明"

Set ExlSheet = ExlBook.Worksheets("Query")
If ExlSheet.StandardWidth < 16 Then
ExlSheet.StandardWidth = 16
End If
ExlSheet.Cells(1, 1).Value = "データベース :"
ExlSheet.Cells(1, 2).Value = strOutPutDbPath
ExlSheet.Cells(2, 1).Value = "クエリー名"
ExlSheet.Cells(2, 2).Value = "作成日時"
ExlSheet.Cells(2, 3).Value = "更新日時"
ExlSheet.Cells(2, 4).Value = "説明"

Set ExlSheet = ExlBook.Worksheets("Form")
If ExlSheet.StandardWidth < 16 Then
ExlSheet.StandardWidth = 16
End If
ExlSheet.Cells(1, 1).Value = "データベース :"
ExlSheet.Cells(1, 2).Value = strOutPutDbPath
ExlSheet.Cells(2, 1).Value = "フォーム名"
ExlSheet.Cells(2, 2).Value = "作成日時"
ExlSheet.Cells(2, 3).Value = "更新日時"
ExlSheet.Cells(2, 4).Value = "説明"

Set ExlSheet = ExlBook.Worksheets("Report")
If ExlSheet.StandardWidth < 16 Then
ExlSheet.StandardWidth = 16
End If
ExlSheet.Cells(1, 1).Value = "データベース :"
ExlSheet.Cells(1, 2).Value = strOutPutDbPath
ExlSheet.Cells(2, 1).Value = "レポート名"
ExlSheet.Cells(2, 2).Value = "作成日時"
ExlSheet.Cells(2, 3).Value = "更新日時"
ExlSheet.Cells(2, 4).Value = "説明"

Set ExlSheet = ExlBook.Worksheets("Macro")
If ExlSheet.StandardWidth < 16 Then
ExlSheet.StandardWidth = 16
End If
ExlSheet.Cells(1, 1).Value = "データベース :"
ExlSheet.Cells(1, 2).Value = strOutPutDbPath
ExlSheet.Cells(2, 1).Value = "マクロ名"
ExlSheet.Cells(2, 2).Value = "作成日時"
ExlSheet.Cells(2, 3).Value = "更新日時"
ExlSheet.Cells(2, 4).Value = "説明"

Set ExlSheet = ExlBook.Worksheets("Module")
If ExlSheet.StandardWidth < 16 Then
ExlSheet.StandardWidth = 16
End If
ExlSheet.Cells(1, 1).Value = "データベース :"
ExlSheet.Cells(1, 2).Value = strOutPutDbPath
ExlSheet.Cells(2, 1).Value = "モジュール名"
ExlSheet.Cells(2, 2).Value = "作成日時"
ExlSheet.Cells(2, 3).Value = "更新日時"
ExlSheet.Cells(2, 4).Value = "説明"


'ワークブックを保存。
If lngMode = pCstLngFileNewMake Then
'新規ワークブックの場合
ExlBook.SaveAs (strOutPutPath)
ElseIf lngMode = pCstLngFileExist Then
'既存ワークブックの場合
ExlBook.Save
End If

ExlBook.Save

'オブジェクトの「説明」プロパティを取得。
If blnDscrptnOutPut Then
blnRet = fncMakeDescriptionList(strDbName, pCstIntAllObj)
If Not blnRet Then
Exit Function
End If
End If

Call SysCmd(acSysCmdSetStatus, "Excel Sheetの準備中です・・・。")

DoCmd.Hourglass True

strSql = "SELECT"
strSql = strSql & " *"
strSql = strSql & " FROM"
strSql = strSql & " [tblObject]"
strSql = strSql & " WHERE"
strSql = strSql & " ("
strSql = strSql & " [Type] = "

'WHERE句のつづき。
strSqlOrder = ") AND"
strSqlOrder = strSqlOrder & " [ImportFlg] = True"
strSqlOrder = strSqlOrder & " ORDER BY"
strSqlOrder = strSqlOrder & " [Type],"
strSqlOrder = strSqlOrder & " [Name]"

For i = acTable To acModule
If i = acTable Then
strSqlWh = CStr(pCstLngTbl) & " OR [Type] = " & CStr(pCstLngLnkTbl)
Set ExlSheet = ExlBook.Worksheets("Table")
Call SysCmd(acSysCmdSetStatus, "Excel Sheetを編集しています・・・。 ( Table )")
ElseIf i = acQuery Then
strSqlWh = CStr(pCstLngQry)
Set ExlSheet = ExlBook.Worksheets("Query")
Call SysCmd(acSysCmdSetStatus, "Excel Sheetを編集しています・・・。 ( Query )")
ElseIf i = acForm Then
strSqlWh = CStr(pCstLngFrm)
Set ExlSheet = ExlBook.Worksheets("Form")
Call SysCmd(acSysCmdSetStatus, "Excel Sheetを編集しています・・・。 ( Form )")
ElseIf i = acReport Then
strSqlWh = CStr(pCstLngRpt)
Set ExlSheet = ExlBook.Worksheets("Report")
Call SysCmd(acSysCmdSetStatus, "Excel Sheetを編集しています・・・。 ( Report )")
ElseIf i = acMacro Then
strSqlWh = CStr(pCstLngMcr)
Set ExlSheet = ExlBook.Worksheets("Macro")
Call SysCmd(acSysCmdSetStatus, "Excel Sheetを編集しています・・・。 ( Macro )")
ElseIf i = acModule Then
strSqlWh = CStr(pCstLngMdl)
Set ExlSheet = ExlBook.Worksheets("Module")
Call SysCmd(acSysCmdSetStatus, "Excel Sheetを編集しています・・・。 ( Module )")
End If
Set rs = db.OpenRecordset(strSql & strSqlWh & strSqlOrder, dbOpenSnapshot)

lngCellsX = 3
If i = acTable Then
'テーブルの場合。
With ExlSheet
Do Until rs.EOF
.Cells(lngCellsX, 1).Value = rs.Fields("Name").Value
If blnLinkFullPathOutPut Then
'接続先をフルパスで出力。
.Cells(lngCellsX, 2).Value = rs.Fields("Database").Value
Else
'ファイル名のみ。
.Cells(lngCellsX, 2).Value = fncFileName(rs.Fields("Database").Value)
End If
.Cells(lngCellsX, 3).Value = rs.Fields("DateCreate").Value
.Cells(lngCellsX, 4).Value = rs.Fields("DateUpdate").Value
.Cells(lngCellsX, 5).Value = rs.Fields("Description").Value
rs.MoveNext
lngCellsX = lngCellsX + 1
Loop
rs.Close
End With
Else
'その他のオブジェクトの場合。
With ExlSheet
Do Until rs.EOF
.Cells(lngCellsX, 1).Value = rs.Fields("Name").Value
.Cells(lngCellsX, 2).Value = rs.Fields("DateCreate").Value
.Cells(lngCellsX, 3).Value = rs.Fields("DateUpdate").Value
.Cells(lngCellsX, 4).Value = rs.Fields("Description").Value
rs.MoveNext
lngCellsX = lngCellsX + 1
Loop
rs.Close
End With
End If
Call SysCmd(acSysCmdSetStatus, "Excel Sheetを編集しています・・・。")
Next

Set rs = Nothing
db.Close

Call SysCmd(acSysCmdSetStatus, "Excel Bookを保存しています・・・。")

ExlBook.Save
ExlBook.Close
ExlApp.Quit

Call SysCmd(acSysCmdClearStatus)

Exit_Line:

Set ExlSheet = Nothing
Set ExlBook = Nothing
Set ExlApp = Nothing

Set db = Nothing
DoCmd.Hourglass False

If Not blnErrFlg Then
Beep
If MsgBox("処理が完了しました♪" & vbCrLf & "Excel Bookを開きますか？", vbYesNo, "完了") = vbNo Then
Exit Function
End If
Call Shell("""Excel.EXE"" """ & strOutPutPath & """", vbMaximizedFocus)
Else
Err.Clear
End If
Exit Function

Err_Line:

blnErrFlg = True
Call SysCmd(acSysCmdClearStatus)
DoCmd.Hourglass False
Beep
Call MsgBox(CStr(Err.Number) & ":" & vbCrLf & Err.Description _
& vbCrLf & vbCrLf & "エラーが発生しました。処理を中止します。", _
vbCritical, "確認")
Err.Clear
GoTo Exit_Line
End Function

Public Function fncTblListExcelOutPut(ByVal strDbName As String, _
ByVal strOutPutPath As String, _
ByVal blnDscrptnOutPut As Boolean, _
ByVal blnDbFullPathOutPut As Boolean, _
ByVal lngMode As Long) As Boolean

'**********************************************************************************************
'
'機能概要：　指定データベース内のテーブル定義一覧をExcelシートに出力する。
'
'引　　数：　strOutPutPath 出力先ファイル名(フルパス)
'
' blnDscrptnOutPut オブジェクトの「説明」(Description)プロパティの出力有無。
' blnDbFullPathOutPut Databaseのフルパス出力有無。
'
' lngMode 処理モード :
' pCstLngFileNewMake ファイルを新規作成。
' pCstLngFileExist ファイルがすでに存在。
'
'備　　考： 引数の妥当性検査は行わない。関数呼出側で事前にチェックすること。
'
'**********************************************************************************************

Dim ExlApp As Excel.Application
Dim ExlBook As Excel.Workbook
Dim ExlSheet As Excel.Worksheet
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsFieldsWk As DAO.Recordset
Dim rsIndexWk As DAO.Recordset
Dim rsIndexFieldsWk As DAO.Recordset
Dim strSql As String
Dim strSqlWh As String
Dim strSqlOrder As String
Dim strMsg As String
Dim strOutPutDbPath As String
Dim i As Long
Dim lngTableNumber As Long
Dim lngCellsX As Long 'Excelシートのタテ座標
Dim lngSheetCount As Long
Dim lngTblDefsCount As Long
Dim blnRet As Boolean
Dim blnErrFlg As Boolean

'対象ファイルの存在を確認。
If Not ChkMdb(strDbName) Then
Beep
Call MsgBox("処理を中止します。", vbExclamation, "中止")
Exit Function
End If

'初期値。
blnErrFlg = False

If blnDbFullPathOutPut Then
'フルパスを表示。
strOutPutDbPath = strDbName
Else
'ファイル名のみ。
strOutPutDbPath = Dir(strDbName)
End If

strSql = "SELECT"
strSql = strSql & " COUNT (*)"
strSql = strSql & " FROM"
strSql = strSql & " [tblObject]"
strSql = strSql & " WHERE"
'strSql = strSql & " ("
strSql = strSql & " [Type] = " & CStr(pCstLngTbl)
'strSql = strSql & " OR"
'strSql = strSql & " [Type] = " & CStr(pCstLngLnkTbl)
'strSql = strSql & " )"
strSql = strSql & " AND"
strSql = strSql & " [ImportFlg] = TRUE"

DoCmd.Hourglass True

#If DEBUG_MODE Then
#Else
On Error GoTo Err_Line
#End If


Set db = CurrentDb
Set rs = db.OpenRecordset(strSql, dbOpenSnapshot)

lngTblDefsCount = rs.Fields(0).Value
If lngTblDefsCount = 0 Then
DoCmd.Hourglass False
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing

strMsg = "一覧表に出力するテーブルを選択してください。"
strMsg = strMsg & vbCrLf & "処理を中止します。"
Beep
Call MsgBox(strMsg, vbExclamation, "中止")

'オブジェクト選択画面を開く。
Call Forms("frmMain").cmdSelectObj_Click
Exit Function
End If

rs.Close

'オブジェクトの「説明」プロパティを取得。
If blnDscrptnOutPut Then
blnRet = fncMakeDescriptionList(strDbName, pCstIntTblOnly)
If Not blnRet Then
Exit Function
End If
End If

DoCmd.Hourglass True

blnRet = fncMakeTblDefLst(strDbName)

DoCmd.Hourglass True

Call SysCmd(acSysCmdSetStatus, "Excel Bookの準備中です・・・。")

'Excelのインスタンスを生成。
Set ExlApp = CreateObject("Excel.Application.8")

'確認メッセージを抑止。(Accessでいうところの DoCmd.SetWarnings False とおなじ趣旨)
ExlApp.DisplayAlerts = False

If lngMode = pCstLngFileNewMake Then
'新規ワークブックを生成
Set ExlBook = ExlApp.Workbooks.Add()
ElseIf lngMode = pCstLngFileExist Then
'既存ワークブックを参照
Set ExlBook = ExlApp.Workbooks.Open(strOutPutPath, , False)
End If

'ワークブックを保存。
If lngMode = pCstLngFileNewMake Then
'新規ワークブックの場合
ExlBook.SaveAs (strOutPutPath)
ElseIf lngMode = pCstLngFileExist Then
'既存ワークブックの場合
ExlBook.Save
End If

lngSheetCount = ExlBook.Worksheets.Count

'ワークシートに不足があれば追加。
If lngSheetCount < lngTblDefsCount Then
Call SysCmd(acSysCmdSetStatus, "Sheetを追加しています・・・。 ( Sheet " & CStr(i) & " )")
For i = lngSheetCount + 1 To lngTblDefsCount
Set ExlSheet = ExlBook.Worksheets.Add
Next
End If

ExlBook.Save

Call SysCmd(acSysCmdSetStatus, "Excel Sheetの準備中です・・・。")

strSql = "SELECT"
strSql = strSql & " [tblNameWk].*,"
strSql = strSql & " [tblObject].[DateCreate],"
strSql = strSql & " [tblObject].[DateUpdate],"
strSql = strSql & " [tblObject].[Description]"
strSql = strSql & " FROM"
strSql = strSql & " [tblNameWk]"
strSql = strSql & " INNER JOIN"
strSql = strSql & " [tblObject]"
strSql = strSql & " ON"
strSql = strSql & " [tblNameWk].[TblName] = [tblObject].[Name]"
strSql = strSql & " WHERE"
strSql = strSql & " [tblObject].[Type] = 1"
strSql = strSql & " AND"
strSql = strSql & " [tblObject].[ImportFlg] = True"
strSql = strSql & " ORDER BY"
strSql = strSql & " [TblID]"

Set rs = db.OpenRecordset(strSql, dbOpenSnapshot)

With rs
Do Until .EOF
If lngTableNumber Mod 10 = 0 Then
ExlBook.Save
End If

lngTableNumber = .Fields("TblID").Value

Call SysCmd(acSysCmdSetStatus, _
"Excel Sheetを編集しています・・・。 ( " _
& CStr(lngTableNumber) & "/ " & CStr(lngTblDefsCount) & " )")

Set ExlSheet = ExlBook.Worksheets(lngTableNumber)

'2001 10/07 Sheet名をTable名に変更。(Excel Sheetの名前付け規則に反する場合のエラーは無視)
On Error Resume Next
ExlSheet.Name = .Fields("TblName").Value
On Error GoTo 0

#If DEBUG_MODE Then
#Else
On Error GoTo Err_Line
#End If

If ExlSheet.StandardWidth < 16 Then
ExlSheet.StandardWidth = 16
End If
ExlSheet.Cells(1, 1).Value = "データベース :"
ExlSheet.Cells(1, 2).Value = strOutPutDbPath
ExlSheet.Cells(2, 1).Value = "テーブル名 : "
ExlSheet.Cells(2, 2).Value = .Fields("TblName").Value
ExlSheet.Cells(3, 1).Value = "作成日時 :"
ExlSheet.Cells(3, 2).Value = .Fields("DateCreate").Value
ExlSheet.Cells(4, 1).Value = "更新日時 :"
ExlSheet.Cells(4, 2).Value = .Fields("DateUpdate").Value
ExlSheet.Cells(5, 1).Value = "説明"
ExlSheet.Cells(5, 2).Value = .Fields("Description").Value
ExlSheet.Cells(7, 1).Value = "フィールド"
ExlSheet.Cells(8, 2).Value = "フィールド名"
ExlSheet.Cells(8, 3).Value = "データ型"
ExlSheet.Cells(8, 4).Value = "サイズ"
ExlSheet.Cells(8, 5).Value = "説明"

'各フィールド情報の書き込み。
strSql = "SELECT"
strSql = strSql & " *"
strSql = strSql & " FROM"
strSql = strSql & " [tblDefWk]"
strSql = strSql & " WHERE"
strSql = strSql & " [TblID] =" & CStr(lngTableNumber)

Set rsFieldsWk = db.OpenRecordset(strSql, dbOpenSnapshot)

lngCellsX = 9
Do Until rsFieldsWk.EOF
ExlSheet.Cells(lngCellsX, 2).Value = rsFieldsWk.Fields("FieldName").Value
ExlSheet.Cells(lngCellsX, 3).Value = rsFieldsWk.Fields("TypeName").Value
ExlSheet.Cells(lngCellsX, 4).Value = rsFieldsWk.Fields("FieldSize").Value
ExlSheet.Cells(lngCellsX, 5).Value = rsFieldsWk.Fields("Description").Value
rsFieldsWk.MoveNext
lngCellsX = lngCellsX + 1
Loop

'インデックス情報の取得、書き込み。
strSql = "SELECT"
strSql = strSql & " *"
strSql = strSql & " FROM"
strSql = strSql & " [tblIdxWk]"
strSql = strSql & " WHERE"
strSql = strSql & " [TblID] =" & CStr(lngTableNumber)
strSql = strSql & " ORDER BY"
strSql = strSql & " [IndexNum]"

Set rsIndexWk = db.OpenRecordset(strSql, dbOpenSnapshot)

ExlSheet.Cells(lngCellsX + 2, 1).Value = "インデックス"

lngCellsX = lngCellsX + 2

Do Until rsIndexWk.EOF
ExlSheet.Cells(lngCellsX + 1, 2).Value = "インデックス名 :"
ExlSheet.Cells(lngCellsX + 2, 3).Value = "主キー"
ExlSheet.Cells(lngCellsX + 3, 3).Value = "固有インデックス"
ExlSheet.Cells(lngCellsX + 4, 3).Value = "Null無視"
ExlSheet.Cells(lngCellsX + 5, 3).Value = "フィールド :"

ExlSheet.Cells(lngCellsX + 1, 3).Value = rsIndexWk.Fields("IndexName").Value
ExlSheet.Cells(lngCellsX + 2, 4).Value = IIf(rsIndexWk.Fields("Primary").Value, "◎", "")
ExlSheet.Cells(lngCellsX + 3, 4).Value = rsIndexWk.Fields("Unique").Value
ExlSheet.Cells(lngCellsX + 4, 4).Value = rsIndexWk.Fields("IgnoreNulls").Value
lngCellsX = lngCellsX + 5

strSql = "SELECT"
strSql = strSql & " *"
strSql = strSql & " FROM"
strSql = strSql & " [tblIdxFieldsWk]"
strSql = strSql & " WHERE"
strSql = strSql & " [TblID] =" & CStr(lngTableNumber)
strSql = strSql & " AND"
strSql = strSql & " [IndexNum] =" & rsIndexWk.Fields("IndexNum").Value
strSql = strSql & " ORDER BY"
strSql = strSql & " [IndexNum],"
strSql = strSql & " [FieldNum]"

Set rsIndexFieldsWk = db.OpenRecordset(strSql, dbOpenSnapshot)

Do Until rsIndexFieldsWk.EOF
ExlSheet.Cells(lngCellsX, 4).Value = rsIndexFieldsWk.Fields("FieldName").Value
lngCellsX = lngCellsX + 1
rsIndexFieldsWk.MoveNext
Loop
lngCellsX = lngCellsX - 1

rsIndexWk.MoveNext
lngCellsX = lngCellsX + 1
Loop
.MoveNext
Loop
.Close
rsFieldsWk.Close
rsIndexWk.Close
rsIndexFieldsWk.Close
End With


Call SysCmd(acSysCmdSetStatus, "Excel Bookを保存しています・・・。")

ExlBook.Save
ExlBook.Close
ExlApp.Quit

Call SysCmd(acSysCmdClearStatus)

Exit_Line:

Set rs = Nothing
Set rsFieldsWk = Nothing
Set rsIndexWk = Nothing
Set rsIndexFieldsWk = Nothing
Set ExlSheet = Nothing
Set ExlBook = Nothing
Set ExlApp = Nothing

Set db = Nothing
DoCmd.Hourglass False

If Not blnErrFlg Then
Beep
If MsgBox("処理が完了しました♪" & vbCrLf & "Excel Bookを開きますか？", vbYesNo, "完了") = vbNo Then
Exit Function
End If
Call Shell("""Excel.EXE"" """ & strOutPutPath & """", vbMaximizedFocus)
Else
Err.Clear
End If
Exit Function

Err_Line:

blnErrFlg = True
Call SysCmd(acSysCmdClearStatus)
DoCmd.Hourglass False
Beep
Call MsgBox(CStr(Err.Number) & ":" & vbCrLf & Err.Description _
& vbCrLf & vbCrLf & "エラーが発生しました。処理を中止します。", _
vbCritical, "確認")
Err.Clear
Call fncTerminateExcel(ExlBook, ExlApp)
GoTo Exit_Line
End Function

Public Function fncTerminateExcel(ByRef ExlBook As Excel.Workbook, _
ByRef ExlApp As Excel.Application)
'fncTblListExcelOutPut 関数の実行中にエラーとなった場合、開いているExcelを閉じる。
On Error Resume Next
ExlBook.Close
ExlApp.Quit
On Error GoTo 0
End Function

Public Function ChkExcelFile(ByVal strPath As String, _
ByVal strFileName As String, _
ByVal strTaskID As String) As Long

'**********************************************************************************************
'
'機能概要：　差分入出力先パス、ファイルの確認。
'
'引　　数：　strPath 入出力先パス
' strFileName 入出力先ファイル
' strTaskID 実行する処理の区分。(下記)
'
' pCstStrMakeObjLst オブジェクト一覧表出力。
' ↑
' 現状ではこの引数は意味がないが、将来、機能拡張も想定されるため、残す。
'
'戻 り 値：　pCstLngPathInVld 入出力先のパスが無効。処理を中止します。
' pCstLngFileNewMake ファイルが存在しない。新規作成します。
' (差分抽出処理の場合のみ。取り込み処理の場合は、ファイルが
' なければ、当然実行できないので、pCstLngPathInVldを返し、以下の処理
' を中止)
'
' pCstLngFileExist ファイルが存在する。出力の場合は、上書き確認メッセージを出力します。
' pCstLngFileInVld ファイルが Excel ではない場合。処理を中止します。
'
'備　　考： 引数の妥当性検査は行わない。関数呼出側で事前にチェックすること。
' パスが無効な場合、呼出元でエラー処理されるため、フォルダの存在有無判定は行わない。
'
'**********************************************************************************************

Dim lngRet As Long

If Right$(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If

#If DEBUG_MODE Then
#Else
On Error GoTo Err_Line
#End If


If LCase(Right$(strFileName, 4)) <> ".xls" Then
'ファイルが Excel ではない場合。処理を中止します。
Beep
Call MsgBox(Mid$(strFileName, 2) & vbCrLf & "はExcelのファイルではありません。" _
& vbCrLf & "処理を中止します。", vbExclamation, "中止")
ChkExcelFile = pCstLngFileInVld
Exit Function
End If

If Len(Dir(strPath & strFileName)) = 0 Then
'ファイルが存在しない。
If strTaskID = pCstStrMakeObjLst Then
'オブジェクト一覧表出力。
'新規作成します。
Beep
lngRet = MsgBox("一覧表出力先ファイルが見つかりません。" _
& vbCrLf & "新規作成しますか？", vbExclamation + vbYesNo, "確認")
If lngRet = vbYes Then
ChkExcelFile = pCstLngFileNewMake
Exit Function
Else
Beep
Call MsgBox("処理を中止します。", vbExclamation, "中止")
ChkExcelFile = pCstLngPathInVld
Exit Function
End If
End If
Else
'ファイルが存在する。上書き確認メッセージを出力。
If strTaskID = pCstStrMakeObjLst Then
'オブジェクト一覧表出力。
Beep
lngRet = MsgBox("一覧表出力先ファイルがすでに存在します。処理を続けますか？" _
& vbCrLf & "(現在の内容は上書きされます)", vbExclamation + vbYesNo, "確認")
If lngRet = vbYes Then
ChkExcelFile = pCstLngFileExist
Exit Function
Else
Beep
Call MsgBox("処理を中止します。", vbExclamation, "中止")
ChkExcelFile = pCstLngPathInVld
Exit Function
End If
End If
End If

Exit Function

Err_Line:

Err.Clear
'入出力先のパスが無効。処理を中止します。
Beep
Call MsgBox("パスが無効です。処理を中止します。", vbExclamation, "中止")
ChkExcelFile = pCstLngPathInVld
Exit Function
End Function

この回答へのお礼

回答ありがとうございます。
まだアクセスでプログラミングできるところまで学習が進んでないので
ソースの理解はできなかったですが、HotDocumentというものがあることを知りました。参考にしてみます。

お礼日時：2003/01/13 01:03