ACCESSのCSV出力に関して

質問

教えて下さい。

ACCESSであるテーブルのデータをCSV出力しようとして、以下のような記述をしました。

結果、問題なく出力されましたが、データだけでなく、項目も出力しようと考えています。

その際にはどのような記述をすれば良いでしょうか？

初歩的な質問で申し訳ありません。

教えて下さい。

《内容》

Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim stSQL As String
Dim stTBL As String

Dim myWSH As Object 'WScript
Dim myDesktopPath As String
Dim stPath As String 'フルパス

Dim objFSO As Object 'FileSystemObject
Dim fsoTS As Object 'TextStream
Dim tmp As Variant 'データ
Dim re As Variant 'データ件数
Dim stDocName As String

Const ForAppending = 8
stTBL = "t_合算" 'テーブル名

'開始メッセージ
stDocName = "「" & stTBL & ".CSV」 ファイルをデスクトップに作成します"
If MsgBox(stDocName, vbYesNo) = vbNo Then Exit Sub

'デスクトップパス取得
Set myWSH = CreateObject("WScript.Shell")
myDesktopPath = myWSH.SpecialFolders("Desktop")
Set myWSH = Nothing

'フルパス
stPath = myDesktopPath & "\" & stTBL & ".CSV"

'読み取り専用でセット
Set cnn = CurrentProject.Connection
stSQL = "SELECT * FROM " & stTBL
Set rst = cnn.Execute(stSQL)
If rst.EOF Then
stDocName = "出力するデータがありませんでした"
Else
'文字列データ格納 (全データ出力、カンマ区切り)
tmp = rst.GetString(adClipString, , ",", vbNewLine)
'出力
Set objFSO = CreateObject("Scripting.FileSystemObject")
With objFSO
If .FileExists(stPath) Then
'既存ファイル削除
Call .DeleteFile(stPath)
End If
Set fsoTS = .OpenTextFile(stPath, ForAppending, True)

'文字列一括書き出し
fsoTS.WriteLine tmp
re = fsoTS.Line - 2
End With
Set fsoTS = Nothing: Set objFSO = Nothing

stDocName = re & " 件の CSVデータを出力しました。"
End If

MsgBox stDocName, vbOKOnly

回答No.3

mitarashi · ベストアンサー

rs.GetStringというのは初めて見ました。ひとつ物知りになったお礼にフィールド名の取得を盛り込んでみました。
フィールド名はループで個々に取得するしかなさそうです。
Accessお仕着せのオートナンバーフィールドのあるデータで試験したところ、エクセルに読み込む時にエラーになって悩みました。バイナリエディタまで引っ張り出してみても分からない．．．。結局CSVファイルの頭にID...という文字があると、エクセルはSYLKファイルと判断してエラーを出すという事が分かりました。強行すればCSVとして開く事は可能でしたが。
Sub test()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim stSQL As String
Dim stTBL As String
Dim stPath As String 'フルパス
Dim objFSO As Object 'FileSystemObject
Dim fsoTS As Object 'TextStream
Dim tmp As Variant 'データ
Dim re As Variant 'データ件数
Dim stDocName As String
Dim buf As String
Dim i As Long

Const ForAppending = 8

stTBL = "Table1" 'テーブル名
'開始メッセージ
stDocName = "「" & stTBL & ".CSV」 ファイルをデスクトップに作成します"
If MsgBox(stDocName, vbYesNo) = vbNo Then Exit Sub
'フルパス
stPath = myDesktopPath & "\" & stTBL & ".CSV"
'読み取り専用でセット
Set cnn = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
stSQL = "SELECT * FROM " & stTBL
rst.Open stSQL, cnn, adOpenForwardOnly, adLockReadOnly
If rst.EOF Then
stDocName = "出力するデータがありませんでした"
Else
re = rst.RecordCount
For i = 0 To rst.Fields.Count - 1
If buf = "" Then
buf = rst.Fields(i).Name
Else
buf = buf & "," & rst.Fields(i).Name
End If
Next i
'文字列データ格納 (全データ出力、カンマ区切り)
tmp = rst.GetString(adClipString, , ",", vbNewLine)
tmp = buf & vbCrLf & tmp
'出力
Set objFSO = CreateObject("Scripting.FileSystemObject")
With objFSO
If .FileExists(stPath) Then
'既存ファイル削除
Call .DeleteFile(stPath)
End If
Set fsoTS = .OpenTextFile(stPath, ForAppending, True)
'文字列一括書き出し
fsoTS.WriteLine tmp
End With
Set fsoTS = Nothing: Set objFSO = Nothing
stDocName = re & " 件の CSVデータを出力しました。"
End If
MsgBox stDocName, vbOKOnly
End Sub

Function myDesktopPath() As String
Dim myWSH As Object 'WScript

'デスクトップパス取得
Set myWSH = CreateObject("WScript.Shell")
myDesktopPath = myWSH.SpecialFolders("Desktop")
Set myWSH = Nothing
End Function

お礼

mitarashi様、返事が遅くまって申し訳ありません。

教えて頂いたように記述したところ、問題なく項目を出力する事ができました。

ありがとうございました！

回答No.2

ShowMeHow

アクセスの機能を使うのが嫌なら、
ＡＤＯＸでテーブル情報は取得することも可能。
http://www.geocities.jp/cbc_vbnet/ADOX/table.html

回答No.1

ShowMeHow

出力用の仮テーブル作って、
transfertextをつかって、hasfieldnamesをtrueに設定する

のが簡単かな。

参考URL：

http://www.feedsoft.net/access/tips/tips92.html