Excel VBA PDFに名前を付けて保存(印刷)する

このチュートリアルでは、Excel VBAでPDFへの保存/印刷を行う方法を説明します。

PDFへの印刷

以下はActiveSheetをPDFに印刷する簡単なプロシージャです。

Sub SimplePrintToPDF()

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="demo.pdf", Quality:=xlQualityStandard, _
  IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True

End Sub

また、ActiveSheetをPDFに印刷する関数もエラー処理も含めて作ってみました。

Sub PrintPDF()
    Call Save_PDF
End Sub


Function Save_PDF() As Boolean 
    Dim Thissheet As String, ThisFile As String, PathName As String
    Dim SvAs As String

Application.ScreenUpdating = False

'保存するファイル名を取得する
    Thissheet = ActiveSheet.Name
    ThisFile = ActiveWorkbook.Name
    PathName = ActiveWorkbook.Path
    SvAs = PathName & "\" & Thissheet & ".pdf"

'印刷品質を設定する
    On Error Resume Next
    ActiveSheet.PageSetup.PrintQuality = 600
    Err.Clear
    On Error GoTo 0

'保存する情報の詳細を設定する
    On Error GoTo RefLibError
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SvAs, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True
    On Error GoTo 0
    
SaveOnly:
    MsgBox "このシートのコピーは、PDFファイルとして正常に保存されました。" & vbCrLf & vbCrLf & SvAs & _
        "保存されたPDFファイルの内容を確認し、ドキュメントに問題がある場合は、印刷パラメータを調整してもう一度やり直してください。"
        
    Save_PDF = True
    GoTo EndMacro
    
RefLibError:
    MsgBox "PDFを保存できません。参照ライブラリが見つかりませんでした。"
    Save_PDF = False
EndMacro:
Application.ScreenUpdating = True
End Function

この関数は、PDFへの印刷が成功したかどうかをTRUEまたはFALSEで返します。

PDFを保存してメール送信する関数

この関数は、ActiveSheetをPDFとして保存し、（オプションで）PDFをメールに添付します（Outlookがインストールされていることが前提です）。

Sub Test_Save_PDF()
    Call Send_PDF("SendEmail")
End Sub


Function Send_PDF(Optional action As String = "SaveOnly") As Boolean
    Dim Thissheet As String, ThisFile As String, PathName As String
    Dim SvAs As String

Application.ScreenUpdating = False

'ファイルの保存名を取得する
    Thissheet = ActiveSheet.Name
    ThisFile = ActiveWorkbook.Name
    PathName = ActiveWorkbook.Path
    SvAs = PathName & "\" & Thissheet & ".pdf"

'印刷品質を設定する
    On Error Resume Next
    ActiveSheet.PageSetup.PrintQuality = 600
    Err.Clear
    On Error GoTo 0

'保存する情報の詳細を設定する 
    On Error GoTo RefLibError
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SvAs, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True
    On Error GoTo 0
    
'メールを送信する
    If action = "SendEmail" Then
        On Error GoTo SaveOnly
        Set olApp = CreateObject("Outlook.Application")
        Set olEmail = olApp.CreateItem(olMailItem)
        
        With olEmail
            .Subject = Thissheet & ".pdf"
            .Attachements.Add SvAs
            .Display
        End With
        On Error GoTo 0
        GoTo EndMacro
    End If
    
SaveOnly:
    MsgBox "このシートのコピーは、PDFファイルとして正常に保存されました。" & vbCrLf & vbCrLf & SvAs & _
        "保存されたPDFファイルの内容を確認し、ドキュメントに問題がある場合は、印刷パラメータを調整してもう一度やり直してください。" 
    Send_PDF = True
    GoTo EndMacro
    
RefLibError:
    MsgBox "PDFを保存できません。参照ライブラリが見つかりませんでした。" 
    Send_PDF = False
EndMacro:
Application.ScreenUpdating = True 
End Function