【Access】自分だけの備忘録

データベースのシステムを構築した時に組んだVBAですが、自分が見ればなんとなく思い出して、同じような仕組みができるという内容の

ココに注意

本当に自分だけの備忘録

的なブログ記事になります。皆さんの参考にはならないかもしれません。

パラメータからCSVファイルを出力

CSVファイルを出力するのに、クエリにパラメータを設定すると、入力を求められる。
めんどくさいので自動化したい。その時の物です。
エクスポートの定義は手動でやらないとダメですね。

Private Sub web_output_Click()

Const TBL_NAME = "web_pdf_output"
Const RPT_NAME = "repo_web_pdf_output"
Const TBL_NAME0 = "web_pdf_output0"
Const RPT_NAME0 = "repo_web_pdf_output0"
Const PDF_PATH = "D:\NTT\"

Dim Rs As ADODB.Recordset
Set Rs = New ADODB.Recordset

Dim rs0 As ADODB.Recordset
Set rs0 = New ADODB.Recordset

Dim dbs As Database
Dim qdf As QueryDef

Dim myStr As String

DoCmd.SetWarnings False
DoCmd.OpenQuery "repo_all_chage_pdf", acViewNormal
DoCmd.OpenQuery "repo_all_chage_pdf0", acViewNormal

Do While True
myStr = InputBox("yyyymmの形式を入力してください。")

'---(1)キャンセルしたとき
If StrPtr(myStr) = 0 Then
MsgBox "キャンセルします"
Exit Sub

'---(2)空欄のまま［OK］したとき
ElseIf myStr = "" Then
MsgBox "未入力です", vbExclamation

'---(3)入力文字が6文字より長いとき
ElseIf Len(myStr) > 6 Then
MsgBox "文字が長すぎます", vbExclamation

Else
'---(4)入力文字が6文字以内のとき
MsgBox "入力された文字列は「" & myStr & "」です"
GoTo Nextjob
End If
Loop

Nextjob:

Rs.Open "SELECT DISTINCT FID FROM web_pdf_output", CurrentProject.Connection, adOpenStatic, adLockReadOnly

Do Until Rs.EOF

DoCmd.OpenReport RPT_NAME, acViewPreview, , "FID=" & Rs!FID, acWindowNormal
DoCmd.OutputTo acOutputReport, RPT_NAME, acFormatPDF, PDF_PATH & Rs!FID & "0000" & myStr & ".PDF"
DoCmd.Close
Rs.MoveNext
Loop

rs0.Open "SELECT DISTINCT ID FROM web_pdf_output0", CurrentProject.Connection, adOpenStatic, adLockReadOnly

Do Until rs0.EOF

DoCmd.OpenReport RPT_NAME0, acViewPreview, , "ID=" & rs0!ID, acWindowNormal
DoCmd.OutputTo acOutputReport, RPT_NAME0, acFormatPDF, PDF_PATH & rs0!ID & myStr & ".PDF"
DoCmd.Close
rs0.MoveNext
Loop
rs0.Close

DoCmd.SetWarnings False
DoCmd.DeleteObject acTable, "web_renkei_csv"
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("output_web_data")
With qdf
.Parameters("tsuki") = myStr
.Execute
End With

DoCmd.TransferText _
TransferType:=acExportDelim, _
specificationname:="Web_renkei_csv エクスポート定義", _
TableName:="web_renkei_csv", _
FileName:="D:\NTT\webdatajoy_" & Format(Date, "yyyymmdd") & ".txt"

End Sub

PDFファイルをグループ毎に出力

テーブルデータと、レポート、出力先をいれて処理するVBA
参照設定で、Microsoft ActiveX Data Objects 2.8 Libraryにチェックを入れる事。

下記の参考は、FIDというグループにてPDFファイルを作成している。

Private Sub web_output_Click()

Const TBL_NAME = "web_pdf_output"
Const RPT_NAME = "repo_all_chage"
Const PDF_PATH = "D:\PDFDATA\"

Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset

rs.Open "SELECT DISTINCT FID FROM web_pdf_output", CurrentProject.Connection, adOpenStatic, adLockReadOnly
Do Until rs.EOF

pdfName = rs!FID
DoCmd.OpenReport RPT_NAME, acViewPreview, , "FID=" & rs!FID, acWindowNormal
DoCmd.OutputTo acOutputReport, RPT_NAME, acFormatPDF, PDF_PATH & rs!FID & ".PDF"
DoCmd.Close
rs.MoveNext

Loop

End Sub

●FIDが０の場合は、PDFにしない。そして、ファイルに任意の文字列を加えた場合のVBA

Private Sub web_output_Click()

Const TBL_NAME = "web_pdf_output"
Const RPT_NAME = "repo_web_pdf_output"
Const PDF_PATH = "D:\NTT\"

Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset

Dim myStr As String

Do While True
myStr = InputBox("yyyymmの形式を入力してください。")

'---(1)キャンセルしたとき
If StrPtr(myStr) = 0 Then
MsgBox "キャンセルします"
Exit Sub

'---(2)空欄のまま［OK］したとき
ElseIf myStr = "" Then
MsgBox "未入力です", vbExclamation

'---(3)入力文字が6文字より長いとき
ElseIf Len(myStr) > 6 Then
MsgBox "文字が長すぎます", vbExclamation

Else
'---(4)入力文字が6文字以内のとき
MsgBox "入力された文字列は「" & myStr & "」です"
GoTo Nextjob
End If
Loop

Nextjob:

rs.Open "SELECT DISTINCT FID FROM web_pdf_output", CurrentProject.Connection, adOpenStatic, adLockReadOnly

Do Until rs.EOF

If rs!FID = 0 Then
GoTo Continue
Else
pdfName = rs!FID
DoCmd.OpenReport RPT_NAME, acViewPreview, , "FID=" & rs!FID, acWindowNormal
DoCmd.OutputTo acOutputReport, RPT_NAME, acFormatPDF, PDF_PATH & rs!FID & myStr & ".PDF"
DoCmd.Close
End If
Continue:
rs.MoveNext
Loop

End Sub

PDFファイルを個別とグループ別に出力

なんとか、グループ毎には出力する方法を考えてできたが、個別も同時に出力したい場合の方法を記す。

すべてを、２種類用意すればいいってことです。レコードセットも２種類オープンする。

Private Sub web_output_Click()

Const TBL_NAME = "web_pdf_output"
Const RPT_NAME = "repo_web_pdf_output"
Const TBL_NAME0 = "web_pdf_output0"
Const RPT_NAME0 = "repo_web_pdf_output0"
Const PDF_PATH = "D:\NTT\"

Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset

Dim rs0 As ADODB.Recordset
Set rs0 = New ADODB.Recordset

Dim myStr As String

Do While True
myStr = InputBox("yyyymmの形式を入力してください。")

'---(1)キャンセルしたとき
If StrPtr(myStr) = 0 Then
MsgBox "キャンセルします"
Exit Sub

'---(2)空欄のまま［OK］したとき
ElseIf myStr = "" Then
MsgBox "未入力です", vbExclamation

'---(3)入力文字が6文字より長いとき
ElseIf Len(myStr) > 6 Then
MsgBox "文字が長すぎます", vbExclamation

Else
'---(4)入力文字が6文字以内のとき
MsgBox "入力された文字列は「" & myStr & "」です"
GoTo Nextjob
End If
Loop

Nextjob:

rs.Open "SELECT DISTINCT FID FROM web_pdf_output", CurrentProject.Connection, adOpenStatic, adLockReadOnly

Do Until rs.EOF

DoCmd.OpenReport RPT_NAME, acViewPreview, , "FID=" & rs!FID, acWindowNormal
DoCmd.OutputTo acOutputReport, RPT_NAME, acFormatPDF, PDF_PATH & rs!FID & "0000" & myStr & ".PDF"
DoCmd.Close
rs.MoveNext
Loop

rs0.Open "SELECT DISTINCT ID FROM web_pdf_output0", CurrentProject.Connection, adOpenStatic, adLockReadOnly

Do Until rs0.EOF

End Sub