2016年12月7日水曜日

EXCELから複数シートを小さいPDFにバッチで書き出す方法

EXCEL(2010)から標準のPDF保存ではサイズが大きくなり、メール添付に適さないための対策
(1)CubePDFを使用する http://www.cube-soft.jp/cubepdf/
(2)各シートの解像度が変わる場合(全列・全行を1ページに収める場合など)は、CubePDFで1シートづつ印刷して、CubePDF側のダイアログの設定で書き出したPDFに追記する
(Excel は複数シートを選択して印刷をかけた時、ページ毎の設定が異なっている場合に「1 ページ毎に印刷コマンドを実行する」と言う挙動を示す事があるため)
 -----株式会社キューブ・ソフトのサポートからのご教示による
 http://support.microsoft.com/kb/816935/ja
 http://okwave.jp/qa/q6118128.html

以上の条件に沿ったVBAのソースコードは下記

Public Function CubePDF書き出しsub(シート名配列 As Variant, 生成PDFファイルパス As String)
    Dim n As Integer
    Dim print_name As String
    Dim ws As Worksheet
    Dim cuHw As Long
    Dim cuHw2 As Long
    Dim シート名 As Variant
 
    print_name = Application.ActivePrinter '現在使用しているプリンター名を取得しておく
    n = 0
    For Each シート名 In シート名配列
        ThisWorkbook.Sheets(シート名).PrintOut ActivePrinter:="CubePDF"
        '個々のシートをCubePDFで印刷
     
        Sleep 5000 '印刷起動後5秒停止(原始的だが時間指定で待機)
        cuHw = 0
        Do  '「CubePDF 1.0.0RC8 (x86)」のダイアログのハンドルを取得するまでループ
            cuHw = FindWindow(vbNullString, "CubePDF 1.0.0RC8 (x86)")  'タイトルで指定
        Loop While cuHw = 0
        BringWindowToTop cuHw  
       '「CubePDF 1.0.0RC8 (x86)」のウィンドウをアクティブに(Windows7)
     
        Sleep 1000 '1秒停止
       '「CubePDF 1.0.0RC8 (x86)」のダイアログのファイル名パスに書き込み
       '(起動後に表示されるダイアログにパラメタを入力するテクニック)
       '感謝→ http://okwave.jp/qa/q8318460.html
        With CreateObject("Wscript.Shell")
            .SendKeys "{TAB}"
            .SendKeys "{TAB}"
            .SendKeys "{TAB}"
            .SendKeys "{TAB}"
            .SendKeys "{TAB}"
            .Run "%COMSPEC% /c echo " & 生成PDFファイルパス & "| clip", 0, True
            'クリップボードに生成PDFファイルパスをコピー
            .SendKeys "^v" '貼り付け
            .SendKeys "{ENTER}"
        End With
        If (n > 0) Then
          '2シート目以降は「CubePDF 確認」ダイアログのハンドルを取得するまでループ
          '(CubePDF側で「末尾に結合」の設定になっていることが必須)
            cuHw2 = 0
            Do
                cuHw2 = FindWindow(vbNullString, "CubePDF 確認")  'タイトルで指定
            Loop While cuHw2 = 0
            BringWindowToTop cuHw2 'ウィンドウをアクティブに(Windows7)
         
            Sleep 1000 '1秒停止
            With CreateObject("Wscript.Shell")
                .SendKeys "{ENTER}" '「CubePDF 確認」のダイアログのボタンを押す
            End With
        End If
        n = n + 1
    Next
    Application.ActivePrinter = print_name  'プリンター名を元に戻す
    CubePDF書き出しsub = 生成PDFファイルパス
End Function


0 件のコメント:

コメントを投稿