Private Sub CommandButton3_Click()  'PPT削除
    Const CELL_FILE_PATH As String = "B3"
    ' ファイルパス取得
    Dim st As String        '変数を宣言する
    With Application.FileDialog(msoFileDialogFolderPicker)
 
        If .Show = True Then
            Range(CELL_FILE_PATH).Value = .SelectedItems(1)
 
            PPT削除して保存
 
        Else
            MsgBox "キャンセル実行"
        End If
 
    End With
 
End Sub
Sub PPT削除して保存()
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim strArray() As String
    Dim file_count As Long
    Dim path As String
    Dim PPT_app As Object
    Dim pptx_file As String
    Dim i As Long
    path = Sheets("Excel").Range("B3").Value
    file_count = 0
    Call get_files(path, FSO, file_count, strArray)
    If file_count = 0 Then
        MsgBox "pptファイルはありません"
        Exit Sub
    End If
    Set PPT_app = CreateObject("PowerPoint.Application")
    PPT_app.Visible = True
    For i = 0 To UBound(strArray)
        With PPT_app.Presentations.Open(strArray(i))
            pptx_file = strArray(i) & "x"
            .SaveAs Filename:=pptx_file
            .Close
        End With
        Kill strArray(i)        '元ファイル削除
    Next
    MsgBox "PPT変換し元ファイルは削除しています"
    PPT_app.Quit
 
End Sub
'拡張子が.pptのファイル名をサブフォルダも含めて取得する
Private Sub get_files(ByVal path As String, FSO As Object, file_count As Long, strArray() As String)
    Dim trgfolder As Object
    Dim myfiles As Object
    Dim myfile As Object
    Dim subfolders As Object
    Dim subfolder As Object
    Set trgfolder = FSO.getfolder(path)
    Set myfiles = trgfolder.files   'ファイル一覧取得
    For Each myfile In myfiles      '各ファイルを処理
        '拡張子が.pptのファイルを取得
        If LCase(Right(myfile.Name, 4)) = ".ppt" Then
            ReDim Preserve strArray(file_count)
            strArray(file_count) = path & "\" & myfile.Name
            file_count = file_count + 1
        End If
    Next
    Set subfolders = trgfolder.subfolders   'フォルダ一覧取得
    For Each subfolder In subfolders        '各サブフォルダを処理
        'サブフォルダ下のファイル名を取得
        Call get_files(path & "\" & subfolder.Name, FSO, file_count, strArray)
    Next
End Sub
 

UHJpdmF0ZSBTdWIgQ29tbWFuZEJ1dHRvbjNfQ2xpY2soKSAgJ1BQVOWJiumZpAogICAgQ29uc3QgQ0VMTF9GSUxFX1BBVEggQXMgU3RyaW5nID0gIkIzIgogICAgJyDjg5XjgqHjgqTjg6vjg5Hjgrnlj5blvpcKICAgIERpbSBzdCBBcyBTdHJpbmcgICAgICAgICflpInmlbDjgpLlrqPoqIDjgZnjgosKICAgIFdpdGggQXBwbGljYXRpb24uRmlsZURpYWxvZyhtc29GaWxlRGlhbG9nRm9sZGVyUGlja2VyKQoKICAgICAgICBJZiAuU2hvdyA9IFRydWUgVGhlbgogICAgICAgICAgICBSYW5nZShDRUxMX0ZJTEVfUEFUSCkuVmFsdWUgPSAuU2VsZWN0ZWRJdGVtcygxKQoKICAgICAgICAgICAgUFBU5YmK6Zmk44GX44Gm5L+d5a2YCgogICAgICAgIEVsc2UKICAgICAgICAgICAgTXNnQm94ICLjgq3jg6Pjg7Pjgrvjg6vlrp/ooYwiCiAgICAgICAgRW5kIElmCgogICAgRW5kIFdpdGgKCkVuZCBTdWIKU3ViIFBQVOWJiumZpOOBl+OBpuS/neWtmCgpCiAgICBEaW0gRlNPIEFzIE9iamVjdAogICAgU2V0IEZTTyA9IENyZWF0ZU9iamVjdCgiU2NyaXB0aW5nLkZpbGVTeXN0ZW1PYmplY3QiKQogICAgRGltIHN0ckFycmF5KCkgQXMgU3RyaW5nCiAgICBEaW0gZmlsZV9jb3VudCBBcyBMb25nCiAgICBEaW0gcGF0aCBBcyBTdHJpbmcKICAgIERpbSBQUFRfYXBwIEFzIE9iamVjdAogICAgRGltIHBwdHhfZmlsZSBBcyBTdHJpbmcKICAgIERpbSBpIEFzIExvbmcKICAgIHBhdGggPSBTaGVldHMoIkV4Y2VsIikuUmFuZ2UoIkIzIikuVmFsdWUKICAgIGZpbGVfY291bnQgPSAwCiAgICBDYWxsIGdldF9maWxlcyhwYXRoLCBGU08sIGZpbGVfY291bnQsIHN0ckFycmF5KQogICAgSWYgZmlsZV9jb3VudCA9IDAgVGhlbgogICAgICAgIE1zZ0JveCAicHB044OV44Kh44Kk44Or44Gv44GC44KK44G+44Gb44KTIgogICAgICAgIEV4aXQgU3ViCiAgICBFbmQgSWYKICAgIFNldCBQUFRfYXBwID0gQ3JlYXRlT2JqZWN0KCJQb3dlclBvaW50LkFwcGxpY2F0aW9uIikKICAgIFBQVF9hcHAuVmlzaWJsZSA9IFRydWUKICAgIEZvciBpID0gMCBUbyBVQm91bmQoc3RyQXJyYXkpCiAgICAgICAgV2l0aCBQUFRfYXBwLlByZXNlbnRhdGlvbnMuT3BlbihzdHJBcnJheShpKSkKICAgICAgICAgICAgcHB0eF9maWxlID0gc3RyQXJyYXkoaSkgJiAieCIKICAgICAgICAgICAgLlNhdmVBcyBGaWxlbmFtZTo9cHB0eF9maWxlCiAgICAgICAgICAgIC5DbG9zZQogICAgICAgIEVuZCBXaXRoCiAgICAgICAgS2lsbCBzdHJBcnJheShpKSAgICAgICAgJ+WFg+ODleOCoeOCpOODq+WJiumZpAogICAgTmV4dAogICAgTXNnQm94ICJQUFTlpInmj5vjgZflhYPjg5XjgqHjgqTjg6vjga/liYrpmaTjgZfjgabjgYTjgb7jgZkiCiAgICBQUFRfYXBwLlF1aXQKCkVuZCBTdWIKJ+aLoeW8teWtkOOBjC5wcHTjga7jg5XjgqHjgqTjg6vlkI3jgpLjgrXjg5bjg5Xjgqnjg6vjg4DjgoLlkKvjgoHjgablj5blvpfjgZnjgosKUHJpdmF0ZSBTdWIgZ2V0X2ZpbGVzKEJ5VmFsIHBhdGggQXMgU3RyaW5nLCBGU08gQXMgT2JqZWN0LCBmaWxlX2NvdW50IEFzIExvbmcsIHN0ckFycmF5KCkgQXMgU3RyaW5nKQogICAgRGltIHRyZ2ZvbGRlciBBcyBPYmplY3QKICAgIERpbSBteWZpbGVzIEFzIE9iamVjdAogICAgRGltIG15ZmlsZSBBcyBPYmplY3QKICAgIERpbSBzdWJmb2xkZXJzIEFzIE9iamVjdAogICAgRGltIHN1YmZvbGRlciBBcyBPYmplY3QKICAgIFNldCB0cmdmb2xkZXIgPSBGU08uZ2V0Zm9sZGVyKHBhdGgpCiAgICBTZXQgbXlmaWxlcyA9IHRyZ2ZvbGRlci5maWxlcyAgICfjg5XjgqHjgqTjg6vkuIDopqflj5blvpcKICAgIEZvciBFYWNoIG15ZmlsZSBJbiBteWZpbGVzICAgICAgJ+WQhOODleOCoeOCpOODq+OCkuWHpueQhgogICAgICAgICfmi6HlvLXlrZDjgYwucHB044Gu44OV44Kh44Kk44Or44KS5Y+W5b6XCiAgICAgICAgSWYgTENhc2UoUmlnaHQobXlmaWxlLk5hbWUsIDQpKSA9ICIucHB0IiBUaGVuCiAgICAgICAgICAgIFJlRGltIFByZXNlcnZlIHN0ckFycmF5KGZpbGVfY291bnQpCiAgICAgICAgICAgIHN0ckFycmF5KGZpbGVfY291bnQpID0gcGF0aCAmICJcIiAmIG15ZmlsZS5OYW1lCiAgICAgICAgICAgIGZpbGVfY291bnQgPSBmaWxlX2NvdW50ICsgMQogICAgICAgIEVuZCBJZgogICAgTmV4dAogICAgU2V0IHN1YmZvbGRlcnMgPSB0cmdmb2xkZXIuc3ViZm9sZGVycyAgICfjg5Xjgqnjg6vjg4DkuIDopqflj5blvpcKICAgIEZvciBFYWNoIHN1YmZvbGRlciBJbiBzdWJmb2xkZXJzICAgICAgICAn5ZCE44K144OW44OV44Kp44Or44OA44KS5Yem55CGCiAgICAgICAgJ+OCteODluODleOCqeODq+ODgOS4i+OBruODleOCoeOCpOODq+WQjeOCkuWPluW+lwogICAgICAgIENhbGwgZ2V0X2ZpbGVzKHBhdGggJiAiXCIgJiBzdWJmb2xkZXIuTmFtZSwgRlNPLCBmaWxlX2NvdW50LCBzdHJBcnJheSkKICAgIE5leHQKRW5kIFN1Ygo=