폴더 내의 모든 pptx파일의 모든 슬라이드를 png로 내보내기

 

 

관련 : https://konahn.tistory.com/entry/Export2PDF

지식인 링크:  https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102020103&docId=467310111

 

특정 폴더 내의 모든 pptx 파일에 대해

내부의 모든 슬라이드를 그림(png)으로 내보내기할 수 있습니다.

 

 

 

VBA코드:

Option Explicit
 
'Const TargetFolder = "C:\Temp"     '따로 결과파일을 저장할 폴더가 있을 경우
Const TargetFolder = ""             'ppt파일이 있는 폴더에 저장

Const Ext = ".png"                  '변환 확장자

Const Zoom = 3                      '저장 비율

Sub Export2PNG()

    Dim tPrs As Presentation, sPrs As Presentation, sld As Slide
    Dim sPpt As String, sPNG As String
    Dim sPath As String, tPath As String
    Dim PR As PrintRange
    Dim Cnt As Long, L As Long
    Dim SW As Single, SH As Single
    
    On Error GoTo Oops
    
    Set tPrs = ActivePresentation
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Filters.Clear
        .AllowMultiSelect = False
        .ButtonName = "현재폴더 선택"
        .InitialFileName = tPrs.Path & "\"
        .Title = "PNG로 내보낼 ppt파일이 들어있는 폴더 선택"
        If .Show = -1 Then sPath = .SelectedItems(1)
    End With
    'sPath = tPrs.Path
    If sPath = "" Then Exit Sub
    Debug.Print ">> Source Folder: " & sPath
    tPath = IIf(TargetFolder = "", sPath, TargetFolder)
    Debug.Print ">> Target Folder: " & tPath
    
    '첫번째 파일 검색
    sPpt = Dir(sPath & "\*.ppt?")
    'Debug.Print sPpt
    While Len(sPpt) > 0
        
        If FileExistsGA(sPath & "\" & sPpt) And _
            sPath & "\" & sPpt <> tPrs.FullName Then
            Set sPrs = Presentations.Open(FileName:=sPath & "\" & sPpt, ReadOnly:=msoTrue, _
                Untitled:=msoFalse, WithWindow:=msoTrue)
            
            If Not sPrs Is Nothing Then
                Cnt = Cnt + 1
                'ppt이름_xxx.png 으로 저장
                sPNG = Left(sPrs.Name, InStrRev(sPrs.Name, ".") - 1)
                 
                'sPNG = sPNG & Ext   '.PNG
                
                Debug.Print Format(Now, "YY-MM-DD HH:NN:SS") & " (" & Format(Cnt, "0000") & _
                    ") Converting " & sPrs.Name & " to " & sPNG & "_00x" & Ext
                
                With sPrs.PageSetup
                    SW = .SlideWidth: SH = .SlideHeight
                End With
                
                'sPrs.Export tPath, Mid(Ext, 2)
                For Each sld In sPrs.Slides
                    sld.Export tPath & "\" & sPNG & "_" & Format(sld.SlideIndex, "000") & Ext, Mid(Ext, 2), SW * Zoom, SH * Zoom
                Next sld
                Debug.Print Format(Now, "YY-MM-DD HH:NN:SS") & " " & sPrs.Slides.Count & " slide(s) exported."
                DoEvents
 
                sPrs.Close
            End If
        
        End If
        
        '다음 파일 검색
        sPpt = Dir()
        'Debug.Print sPpt
    Wend

    Debug.Print Format(Now, "YY/MM/DD HH:NN:SS") & " Total " & Cnt & " file(s) processed."

Oops:
    If Err.Number Then MsgBox Err.Description

End Sub

Function FileExistsGA(ByVal FileSpec As String) As Boolean
  ' Karl Peterson MS VB MVP
  Dim Attr As Long
  ' Guard against bad FileSpec by ignoring errors
  ' retrieving its attributes.
  On Error Resume Next
  Attr = GetAttr(FileSpec)
  If Err.Number = 0 Then
    ' No error, so something was found.
    ' If Directory attribute set, then not a file.
    FileExistsGA = Not ((Attr And vbDirectory) = vbDirectory)
  End If
  On Error GoTo 0
End Function

 

유의사항: 

첨부한 파일을 매크로 허용해서 열어놓고

Atl-F8로 매크로를 실행하세요.

그리고 pptx파일이 있는 폴더를 선택하면 됩니다.

​

실행결과:

>> Source Folder: C:\Users\사용자\Desktop\새 폴더 >> Target Folder: C:\Users\사용자\Desktop\새 폴더 24-04-02 13:36:53 (0001) Converting Sample5.pptm to Sample5_00x.png 24-04-02 13:36:53 5 slide(s) exported. 24-04-02 13:36:54 (0002) Converting Sample5Auto.pptm to x 24-04-02 13:36:55 7 slide(s) exported. 24-04-02 13:36:56 Total 2 file(s) processed.

​​

현재 파일은 제외합니다.

저장 위치는 pptx파일이 있는 폴더에 저장합니다.

현재는 3인데 Zoom 값을 크게할수록 png 이미지의 크기가 커집니다.

​Ext를 .jpg 로 바꾸면 jpg 파일로 저장합니다.

 

 

파일 첨부합니다:

Export2PNG1.pptm

0.04MB