파워포인트 페이지 분할 매크로

회사에서 파워포인트 문서 nn개를 한장 한장 분리하라고... 시켜서... 어떻게든 편한 방법을 찾아냄

 

Sub 페이지분할()

    Dim oPresentation As Presentation
    Dim oNewPresentation As Presentation
    Dim slideIndex As Integer
    Dim folderPath As String
    Dim slideName As String
    Dim presentationName As String
    Dim basePath As String
    Dim totalSlides As Integer
    Dim i As Integer
    
    ' 현재 프레젠테이션을 변수에 할당
    Set oPresentation = ActivePresentation
    
    ' 현재 프레젠테이션의 파일명 가져오기 (확장자 제거)
    presentationName = Left(oPresentation.Name, InStrRev(oPresentation.Name, ".") - 1)
    
    ' basePath 경로 수정 (E:\temps)
    basePath = "E:\temps"
    
    ' 파일 이름을 포함한 저장 폴더 경로 (E:\temps\PresentationName)
    folderPath = basePath & "\" & presentationName
    
    ' 폴더가 존재하지 않을 경우 폴더 생성
    If Dir(folderPath, vbDirectory) = "" Then
        MkDir folderPath
    End If
    
    ' 슬라이드 개수 가져오기
    totalSlides = oPresentation.Slides.Count
    
    ' 슬라이드 개수만큼 반복
    For slideIndex = 1 To totalSlides
        ' 현재 프레젠테이션을 복제하여 새 프레젠테이션 생성
        oPresentation.SaveCopyAs folderPath & "\" & "TempPresentation.pptx"
        Set oNewPresentation = Presentations.Open(folderPath & "\" & "TempPresentation.pptx")
        
        ' 슬라이드 방향 복사 (가로/세로)
        oNewPresentation.PageSetup.SlideOrientation = oPresentation.PageSetup.SlideOrientation
        
        ' 모든 슬라이드를 삭제하고 slideIndex 슬라이드만 남기기
        For i = oNewPresentation.Slides.Count To 1 Step -1
            If i <> slideIndex Then
                oNewPresentation.Slides(i).Delete
            End If
        Next i
        
        ' 슬라이드 이름 지정 (예: "Slide_1.pptx")
        slideName = "Slide_" & slideIndex & ".pptx"
        
        ' 새 프레젠테이션을 지정된 폴더에 저장
        oNewPresentation.SaveAs folderPath & "\" & slideName
        
        ' 새 프레젠테이션 닫기
        oNewPresentation.Close
    Next slideIndex
    
    ' 임시 프레젠테이션 파일 삭제
    Kill folderPath & "\" & "TempPresentation.pptx"
    
    ' 완료 메시지
    MsgBox "All slides have been saved as separate PPT files in " & folderPath
    
End Sub