Excel VBAを使用してAccessのレポートをPDFとして効率的に出力する方法

Dim accessApp As Object
Dim dbPath As String
Dim reportName As String
Dim outputFilePath As String

Sub OpenAccessDatabase()
    ' Accessアプリケーションを起動
    Set accessApp = CreateObject("Access.Application")

    ' データベースのパスを設定
    dbPath = "C:\path\to\your\database.accdb"

    ' データベースを開く
    accessApp.OpenCurrentDatabase dbPath
End Sub

Sub SetOutputFilePath()
    ' レポート名を設定
    reportName = "YourReportName"

    ' 出力ファイルのパスを設定
    outputFilePath = "C:\path\to\output\folder\" & reportName & ".pdf"
End Sub

Sub ConnectToAccessDatabase()
    ' Accessアプリケーションを起動
    Set accessApp = CreateObject("Access.Application")

    ' データベースのパスを設定
    dbPath = "C:\path\to\your\database.accdb"

    ' データベースを開く
    accessApp.OpenCurrentDatabase dbPath, False
    ' データベースを非表示に設定
    accessApp.Visible = False
End Sub

Sub CheckReportObject()
    Dim reportExists As Boolean
    reportName = "YourReportName"

    ' レポートの存在を確認
    reportExists = False
    For Each obj In accessApp.CurrentProject.AllReports
        If obj.Name = reportName Then
            reportExists = True
            Exit For
        End If
    Next obj

    If Not reportExists Then
        MsgBox "指定されたレポートが見つかりません: " & reportName
        Exit Sub
    End If
End Sub

Sub VerifyConnection()
    If accessApp Is Nothing Then
        MsgBox "Accessデータベースへの接続に失敗しました。"
    Else
        MsgBox "Accessデータベースに正常に接続されました。"
    End If
End Sub

Sub SelectReport()
    ' 出力するレポートの名前を設定
    reportName = "YourReportName"

    ' レポートが存在するか確認
    Dim reportExists As Boolean
    reportExists = False
    For Each obj In accessApp.CurrentProject.AllReports
        If obj.Name = reportName Then
            reportExists = True
            Exit For
        End If
    Next obj

    If Not reportExists Then
        MsgBox "指定されたレポートが見つかりません: " & reportName
        Exit Sub
    End If
End Sub

Sub SetPDFOutputSettings()
    ' 出力ファイルのパスを設定
    outputFilePath = "C:\path\to\output\folder\" & reportName & ".pdf"

    ' 出力先フォルダが存在するか確認し、なければ作成
    If Dir("C:\path\to\output\folder", vbDirectory) = "" Then
        MkDir "C:\path\to\output\folder"
    End If
End Sub

Sub SetDynamicFileName()
    ' 現在の日付と時刻を取得
    Dim currentDate As String
    currentDate = Format(Now, "yyyymmdd_hhnnss")

    ' 出力ファイル名に日付と時刻を含める
    outputFilePath = "C:\path\to\output\folder\" & reportName & "_" & currentDate & ".pdf"
End Sub

Sub ExportReportToPDF()
    ' Accessアプリケーションを起動してデータベースに接続
    ConnectToAccessDatabase

    ' レポートの選択と設定
    SelectReport
    SetPDFOutputSettings

    ' PDF出力の実行
    On Error GoTo ErrorHandler
    accessApp.DoCmd.OutputTo acOutputReport, reportName, acFormatPDF, outputFilePath

    ' 完了メッセージ
    MsgBox "レポートのPDF出力が完了しました: " & outputFilePath

    ' Accessアプリケーションを終了
    accessApp.Quit
    Set accessApp = Nothing

    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description
    accessApp.Quit
    Set accessApp = Nothing
End Sub

Sub BasicErrorHandling()
    On Error GoTo ErrorHandler

    ' エラーが発生する可能性のあるコード
    Dim result As Double
    result = 1 / 0 ' これはエラーを引き起こします

    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description
End Sub

Sub ConnectToAccessDatabase()
    On Error GoTo ConnectionError

    Set accessApp = CreateObject("Access.Application")
    dbPath = "C:\path\to\your\database.accdb"
    accessApp.OpenCurrentDatabase dbPath, False
    accessApp.Visible = False

    Exit Sub

ConnectionError:
    MsgBox "データベースへの接続に失敗しました: " & Err.Description
    Set accessApp = Nothing
End Sub

Sub ExportReportToPDF()
    On Error GoTo ExportError

    ConnectToAccessDatabase
    SelectReport
    SetPDFOutputSettings

    accessApp.DoCmd.OutputTo acOutputReport, reportName, acFormatPDF, outputFilePath
    MsgBox "レポートのPDF出力が完了しました: " & outputFilePath

    accessApp.Quit
    Set accessApp = Nothing
    Exit Sub

ExportError:
    MsgBox "PDF出力中にエラーが発生しました: " & Err.Description
    accessApp.Quit
    Set accessApp = Nothing
End Sub

Sub LogError(errorMessage As String)
    Dim logFile As String
    logFile = "C:\path\to\log\error_log.txt"

    Dim fileNumber As Integer
    fileNumber = FreeFile

    Open logFile For Append As #fileNumber
    Print #fileNumber, Now & " - " & errorMessage
    Close #fileNumber
End Sub

Sub ExportReportToPDF()
    On Error GoTo ExportError

    ConnectToAccessDatabase
    SelectReport
    SetPDFOutputSettings

    accessApp.DoCmd.OutputTo acOutputReport, reportName, acFormatPDF, outputFilePath
    MsgBox "レポートのPDF出力が完了しました: " & outputFilePath

    accessApp.Quit
    Set accessApp = Nothing
    Exit Sub

ExportError:
    LogError "PDF出力中にエラーが発生しました: " & Err.Description
    MsgBox "PDF出力中にエラーが発生しました: " & Err.Description
    accessApp.Quit
    Set accessApp = Nothing
End Sub

Sub ExportMultipleReportsToPDF()
    Dim reportNames As Variant
    Dim report As Variant
    reportNames = Array("Report1", "Report2", "Report3") ' 出力するレポート名の配列

    On Error GoTo ExportError

    ConnectToAccessDatabase

    For Each report In reportNames
        reportName = report
        SetPDFOutputSettings
        accessApp.DoCmd.OutputTo acOutputReport, reportName, acFormatPDF, outputFilePath
    Next report

    MsgBox "すべてのレポートのPDF出力が完了しました。"

    accessApp.Quit
    Set accessApp = Nothing
    Exit Sub

ExportError:
    LogError "複数レポートのPDF出力中にエラーが発生しました: " & Err.Description
    MsgBox "エラーが発生しました: " & Err.Description
    accessApp.Quit
    Set accessApp = Nothing
End Sub

Sub ExportFilteredReportToPDF()
    Dim filterCriteria As String
    filterCriteria = "[FieldName] = 'Criteria'" ' フィルタ条件を設定

    On Error GoTo ExportError

    ConnectToAccessDatabase
    SelectReport
    SetPDFOutputSettings

    ' フィルタを適用してPDF出力
    accessApp.DoCmd.OpenReport reportName, acViewPreview, , filterCriteria
    accessApp.DoCmd.OutputTo acOutputReport, reportName, acFormatPDF, outputFilePath

    MsgBox "フィルタ適用後のレポートのPDF出力が完了しました: " & outputFilePath

    accessApp.Quit
    Set accessApp = Nothing
    Exit Sub

ExportError:
    LogError "フィルタ適用レポートのPDF出力中にエラーが発生しました: " & Err.Description
    MsgBox "エラーが発生しました: " & Err.Description
    accessApp.Quit
    Set accessApp = Nothing
End Sub