これは、VBScript で行う方法です。あまり役に立たないかもしれませんが、始めるきっかけになるかもしれません。「Adobe PDF」という名前のプリンターとして PDF メーカー (adobe acrobat) が必要です。
'PDF_WILDCARD = "*.pdf"
'PrnName = "Adobe PDF"
Sub PrintToPDF(ReportName As String, TempPath As String, _
OutputName As String, OutputDir As String, _
Optional RPTOrientation As Integer = 1)
Dim rpt As Report
Dim NewFileName As String, TempFileName As String
'--- Printer Set Up ---
DoCmd.OpenReport ReportName, View:=acViewPreview, WindowMode:=acHidden
Set rpt = Reports(ReportName)
Set rpt.Printer = Application.Printers(PrnName)
'Set up orientation
If RPTOrientation = 1 Then
rpt.Printer.Orientation = acPRORPortrait
Else
rpt.Printer.Orientation = acPRORLandscape
End If
'--- Print ---
'Print (open) and close the actual report without saving changes
DoCmd.OpenReport ReportName, View:=acViewNormal, WindowMode:=acHidden
' Wait until file is fully created
Call waitForFile(TempPath, ReportName & PDF_EXT)
'DoCmd.Close acReport, ReportName, acSaveNo
DoCmd.Close acReport, ReportName
TempFileName = TempPath & ReportName & PDF_EXT 'default pdf file name
NewFileName = OutputDir & OutputName & PDF_EXT 'new file name
'Trap errors caused by COM interface
On Error GoTo Err_File
FileCopy TempFileName, NewFileName
'Delete all PDFs in the TempPath
'(which is why you should assign it to a pdf directory)
On Error GoTo Err_File
Kill TempPath & PDF_WILDCARD
Exit_pdfTest:
Set rpt = Nothing
Exit Sub
Err_File: ' Error-handling routine while copying file
Select Case Err.Number ' Evaluate error number.
Case 53, 70 ' "Permission denied" and "File Not Found" msgs
' Wait 3 seconds.
Debug.Print "Error " & Err.Number & ": " & Err.Description & vbCr & "Please wait a few seconds and click OK", vbInformation, "Copy File Command"
Call sleep(2, False)
Resume
Case Else
MsgBox Err.Number & ": " & Err.Description
Resume Exit_pdfTest
End Select
Resume
End Sub
Sub waitForFile(ByVal pathName As String, ByVal tempfile As String)
With Application.FileSearch
.NewSearch
.LookIn = pathName
.SearchSubFolders = True
.filename = tempfile
.MatchTextExactly = True
'.FileType = msoFileTypeAllFiles
End With
Do While True
With Application.FileSearch
If .Execute() > 0 Then
Exit Do
End If
End With
Loop
End Sub
Public Sub sleep(seconds As Single, EventEnable As Boolean)
On Error GoTo errSleep
Dim oldTimer As Single
oldTimer = Timer
Do While (Timer - oldTimer) < seconds
If EventEnable Then DoEvents
Loop
errSleep:
Err.Clear
End Sub