VBAを用いた指定したディレクトリ配下の全てパワーポイントファイルをPDFに一括変換

やりたいこと

VBAを用いた指定したディレクトリ配下の全てパワーポイントファイルをPDFに一括変換しましたため、
そのメモを残ります。

指定したディレクトリ配下に、子フォルダが多くて、その中のパワーポイントファイルをPDFに変換したいです。
大量のフォルダ配下にパワーポイントファイルがあるため、一括変換をできれば楽かなと思います。

例：
指定したディレクトリ
　　└ フォルダA
       └ A1.pptx
       └ A2.pptx 
       └ A3.pptx
　　└ フォルダB
       └ B1.pptx
       └ B2.pptx 
       └ B3.pptx
　　└ フォルダC
       └ フォルダD
           └ D1.pptx
           └ D2.pptx 
           └ D3.pptx
       └ フォルダE
           └ E1.pptx
           └ E2.pptx 
           └ E3.pptx

VBA初心者のため、グーグルで既存のVBAツールがあるかを検索してみましたが、指定したディレクトリ直下のpptxファイルであれば、一括変換できますが、上記のような、少し複雑の階層になっている場合、うまく変換することができないです。

一括変換用VBA

なので、既存のVBAツールをベースに、上記の複雑の階層でも、変換できるようにしました。

既存のVBAツールは、以下の記事をご参照ください
【Excel VBA】複数のパワーポイントファイルをPDFに一括変換

修正後のソースコード：

Dim buf As String, cnt As Long
Dim ws As Worksheet
Dim i As Integer, LastRow As Integer
Dim Path As String, PPT As Object
Dim dir_path As String, file_name As String, ppt_path As String, pdf_file As String, target_file As String
Dim dot As Long
Dim dot1 As Long
Dim dir_path1 As String

'対象ディレクトリを設定する
Sub get_filename()
    'ここに変換対象ディレクトリを設定する
    '例：GetFileList ("C:\Users\test\Desktop\vba")
    GetFileList ("○○○○")
End Sub

'対象ファイルを一括変換する
Sub ppt_pdf_save_ALL()
   Set ws = Worksheets("Sheet1")
   dir_path = ThisWorkbook.Path
   LastRow = ws.Cells(Rows.Count, 3).End(xlUp).Row 'C列の最終行
   Set PPT = CreateObject("PowerPoint.Application")
   For i = 3 To LastRow
       target_file = ws.Cells(i, "C") 'C列にファイル名
       ppt_path = target_file
       
       dot1 = InStrRev(target_file, "\")
       dir_path1 = Left(target_file, dot1)

       target_file1 = Mid(target_file, dot1 + 1)
       dot = InStrRev(target_file1, ".")
       file_name = Left(target_file1, dot - 1) '拡張子より前のファイル名を取得
       
       '変換対象ファイルと同じディレクトリにPDFファイルを生成する
       pdf_file = dir_path1 & file_name & ".pdf"
       With PPT.Presentations.Open(ppt_path)
         .SaveAs Filename:=pdf_file, FileFormat:=32
         .Close
       End With
   Next
   PPT.Quit
   Set PPT = Nothing


dot = InStrRev(target_file, ".")
file_name = Left(target_file, dot - 1) '拡張子より前のファイル名を取得
End Sub

'指定したディレクトリ配下の全pptxファイルを検索する
'サブフォルダまで確認
Function GetFileList(ByVal argDir As String) As String()
  Dim i As Long
  Dim aryDir() As String
  Dim aryFile() As String
  Dim strName As String

  ReDim aryDir(i)
  aryDir(i) = argDir '引数のフォルダを配列の先頭に入れる
 
  'まずは、指定フォルダ以下の全サブフォルダを取得し、配列aryDirに入れます。
  i = 0
  Do
    strName = Dir(aryDir(i) & "\", vbDirectory)
    Do While strName <> ""
      If GetAttr(aryDir(i) & "\" & strName) And vbDirectory Then
        If strName <> "." And strName <> ".." Then
          ReDim Preserve aryDir(UBound(aryDir) + 1)
          aryDir(UBound(aryDir)) = aryDir(i) & "\" & strName
        End If
      End If
      strName = Dir()
    Loop
    i = i + 1
    If i > UBound(aryDir) Then Exit Do
  Loop
 
  '配列aryDirの全フォルダについて、ファイルを取得し、配列aryFileに入れます。
  ReDim aryFile(0)
  For i = 0 To UBound(aryDir)
    strName = Dir(aryDir(i) & "\*.pptx", vbNormal + vbHidden + vbReadOnly + vbSystem)
    Do While strName <> ""
    cnt = cnt + 1
   Cells(cnt + 2, 3) = aryDir(i) + "\" + strName 'C列にファイル名を取得
      If aryFile(0) <> "" Then
        ReDim Preserve aryFile(UBound(aryFile) + 1)
      End If
      aryFile(UBound(aryFile)) = aryDir(i) & "\" & strName
      strName = Dir()
    Loop
  Next
  GetFileList = aryFile
End Function

このVBAツールを利用する時、get_filenameメソッドに対象ディレクトリを設定することが必要です。