【PowerPoint】pdfとして保存する【VBA】

これのppt版

Call ppShape非表示にする("shp余白", False)

これは↓のものがある前提なので、ない時はこの行をコメントアウトして下さい。

Option Explicit

Sub PDF化()
  
  On Error GoTo Err
  With ActivePresentation
    Dim ppPath: ppPath = .Path
    Dim ppName: ppName = .Name
    
    
    Dim pdfPath
    pdfPath = ppPath & "\" & 拡張子変換(ppName, "pdf")
    
    Do Until ファイル存在確認(pdfPath) = False
      pdfPath = 追番付与(pdfPath)
    Loop
    
    'pdfタブに表示されるppt詳細プロパティの値をファイル名に変更する
    .BuiltInDocumentProperties.Item(1).Value = 拡張子変換(ppName, "pdf")
    
    Call ppShape非表示にする("shp余白", False)
    
    .SaveAs _
      FileName:=pdfPath, _
      FileFormat:=ppSaveAsPDF
      
'      https://docs.microsoft.com/ja-jp/office/vba/api/powerpoint.presentation.exportasfixedformat
'    こっちの方法でやると詳細プロパティ問題は起こらないが画像がぼやけることがある
'    .ExportAsFixedFormat _
'      Path:=pdfPath, _
'      FixedFormatType:=ppFixedFormatTypePDF, _
'      PrintHiddenSlides:=msoFalse

  End With
  
  Call ppShape非表示にする("shp余白", True)
  
  ' pdf保存する時に付随して開くオプションがわからないのでWSで開く
  Call FileOpen_WScriptShell(pdfPath)
Err:
  Select Case Err.Number
    Case Is = 1004: MsgBox "プレゼンテーションを保存後実行してください。"
  End Select
End Sub

Private Function 追番付与(TargetPath)
  Dim buf1, ub, buf2
  buf1 = Split(TargetPath, ".")
  ub = UBound(buf1)
  
  buf2 = buf1(ub - 1)
  If InStr(buf2, "▲") = 0 Then   'すでに▲があるか否かで分岐
    buf2 = buf2 & "▲1"           'なければ▲1を付与
  Else
    buf2 = Split(buf2, "▲")      'あるなら▲までで区切ってその後をインクリメントする
    buf2(1) = buf2(1) + 1
    buf2 = Join(buf2, "▲")       '分割したものを戻す
  End If
  
  buf1(ub - 1) = buf2             '拡張子以前を元の形にまとめ直す
  追番付与 = Join(buf1, ".")      '分割したものを戻す
End Function

Private Function 拡張子変換(Target, 指定拡張子)
  Dim buf, ub
  buf = Split(Target, ".")
  ub = UBound(buf)
  buf(ub) = 指定拡張子
  拡張子変換 = Join(buf, ".")
End Function

Private Function ファイル存在確認(TargetPath) As Boolean
  Dim flg As Boolean
  If Dir(TargetPath) <> "" Then
    flg = True
  Else
    flg = False
  End If
  ファイル存在確認 = flg
End Function

Sub FileOpen_WScriptShell(ByVal strFile As String)
    Dim wsh As Object
    Set wsh = CreateObject("Wscript.Shell")
    strFile = """" & strFile & """"
    wsh.Run strFile, 1
    Set wsh = Nothing
End Sub