![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?e8efa67)
A 回答 (2件)
- 最新から表示
- 回答順に表示
No.2
- 回答日時:
参考URLで紹介されている、「Access オブジェクトをテキストファイルに変換する方法」を工夫すれば比較的簡単にできるかもしれません。
参考URL:http://www.f3.dion.ne.jp/~element/msaccess/AcTip …
No.1
- 回答日時:
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
この回答へのお礼
お礼日時:2003/01/13 01:03
回答ありがとうございます。
まだアクセスでプログラミングできるところまで学習が進んでないので
ソースの理解はできなかったですが、HotDocumentというものがあることを知りました。参考にしてみます。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・ゆるやかでぃべーと タイムマシンを破壊すべきか。
- ・「I love you」 をかっこよく翻訳してみてください
- ・歩いた自慢大会
- ・許せない心理テスト
- ・字面がカッコいい英単語
- ・昔のあなたへのアドバイス
- ・かっこよく答えてください!!
- ・あなたが好きな本屋さんを教えてください
- ・スタッフと宿泊客が全員斜め上を行くホテルのレビュー
- ・【大喜利】【投稿~8/27】 こんなガソリンスタンド二度と来るか!なぜそう思った?
- ・これ何て呼びますか Part2
- ・人生で一番思い出に残ってる靴
- ・【お題】動物のキャッチフレーズ
- ・【お題】甲子園での思い出の残し方
- ・ゆるやかでぃべーと すべての高校生はアルバイトをするべきだ。
- ・「それ、メッセージ花火でわざわざ伝えること?」
- ・自分用のお土産
- ・人生で一番お金がなかったとき
- ・一番好きなみそ汁の具材は?
- ・泣きながら食べたご飯の思い出
- ・ちょっと先の未来クイズ第1問
- ・ゴリラ向け動画サイト「ウホウホ動画」にありがちなこと
- ・初めて自分の家と他人の家が違う、と意識した時
- ・単二電池
- ・チョコミントアイス
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
SQLPLUSで結果を画面に表示しない
-
AccessからExcelのファイルを起...
-
Accessのレポート出力をWordに...
-
mysqlのCSV出力について
-
Oracleでインスタンスを複数に...
-
動的にSPOOLファイルのファイル...
-
dmpファイルをインポートせずに...
-
オブジェクトブラウザについて
-
「○○○.ldb」のAccess レコード ...
-
共有フォルダに誰が何にアクセ...
-
【Excel】[Expression.Error] ...
-
Access2007でldbファイルが...
-
#1062 - '0' は索引 'PRIMARY' ...
-
Batch: フォルダ内の特定のファ...
-
月が変わったら自動でシートが...
-
Dream weaverで、誤ってファイ...
-
TSVのファイルをACCESSにインポ...
-
Accessでリンクテーブルのパス変更
-
Excelデータをテキストファイル...
-
アクセスでcsvに出力した際、頭...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
SQLPLUSで結果を画面に表示しない
-
selectした結果の余計な余白を...
-
AccessからExcelのファイルを起...
-
ORACLEから各テーブルをCSV形式...
-
動的にSPOOLファイルのファイル...
-
Oracleでインスタンスを複数に...
-
Accessのレポート出力をWordに...
-
ストアドプロシージャの出力に...
-
DB2のコマンドラインexportで複...
-
dmpファイルをインポートせずに...
-
PLSQLでファイルに書き込みをし...
-
mod_plsql使用時のDBMS_OUTPUT....
-
レポートをpdfに変換する方法
-
SQL*PLUSで 定期的にSQLを発行...
-
SQLServer2005でSELECTした結果...
-
『ALTER SYSTEM』と『ALTER DAT...
-
DB2にspoolコマンドみたいなの...
-
batファイルからsql文実行
-
SPOOLのログについて
-
SQL*PLUSでファイルからDELETE文
おすすめ情報