폴더 내의 모든 PPT파일을 동영상으로 내보내기

 

VBA에서 현재 프레젠테이션을 동영상으로 저장하는 코드는

​

프레젠테이션.CreateVideo "파일명", 타이밍여부, 기본재생시간, 세로픽셀수, 프레임속도, 압축률 을 이용합니다.

​

예를 들어, 아래 명령은 현재 프레젠테이션을 1080p로 30 프레임, 압축률 90%로 저장합니다.

 

Sub Export2Video()
    ActivePresentation.CreateVideo "c:\temp\myVideo.mp4", True, 5, 1080, 30, 90
End Sub

 

 

이제 여기서 나아가서 폴더를 선택하면

폴더 내의 모든 ppt, pps나 pptx, pptm, ppsx 등의 파일을 열어서 동영상으로 저장하고 닫는 코드입니다.

 

Option Explicit
 
'Const TargetFolder = "C:\Temp"     '동영상을 저장할 폴더가 있을 경우
Const TargetFolder = ""      'ppt파일이 있는 폴더에 저장

Const Overwrite = False     '동영상 파일이 존재할 때 덮어쓸지 여부

Const Ext = ".mp4"          '동영상 확장자

Sub Export2Videos()

    Dim tPrs As Presentation, sPrs As Presentation
    Dim sPpt As String, sMp4 As String
    Dim sPath As String, tPath As String
    Dim Cnt As Long
    On Error GoTo Oops
    
    Set tPrs = ActivePresentation
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Filters.Clear
        .AllowMultiSelect = False
        .ButtonName = "현재폴더 선택"
        .InitialFileName = tPrs.Path & "\"
        .Title = "동영상으로 내보낼 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이름.mp4 으로 저장
                sMp4 = Left(sPrs.Name, InStrRev(sPrs.Name, ".") - 1)
                If Overwrite = False And FileExistsGA(tPath & "\" & sMp4 & Ext) Then _
                    sMp4 = sMp4 & "_" & CDbl(Now)
                'sMp4 = sMp4 & Ext   '.mp4
                
                Debug.Print Format(Now, "YY-MM-DD HH:NN:SS") & " (" & Format(Cnt, "0000") & _
                    ") Converting " & sPrs.Name & " to " & sMp4 & Ext
                sPrs.CreateVideo FileName:=tPath & "\" & sMp4 & Ext, _
                    UseTimingsAndNarrations:=True, _
                    DefaultSlideDuration:=5, _
                    VertResolution:=1080, _
                    FramesPerSecond:=30, _
                    Quality:=90
                    
                'Wait until done or failed
                While sPrs.CreateVideoStatus < 3
                    DoEvents
                Wend
                sPrs.Close
            End If
        
        End If
        
        '다음 파일 검색
        sPpt = Dir()
        'Debug.Print sPpt
    Wend

    Debug.Print Format(Now, "YY/MM/DD HH:NN:SS") & " " & 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

 

 

Alt-F11 창에서 모듈 추가하고 위 코드를 붙여넣은 다음 F5키나 일반 화면에서 Alt+F8로 실행하면

아래와 같은 화면입니다. ppt나 pptx파일이 들어있는 폴더로 들어가서 '현재 폴더 선택'버튼을 눌러주면 됩니다.

 

​

TargetFolder를 적어주면 동영상을 해당 폴더에 저장하고

빈 값이면 기본적으로 ppt파일이 있는 폴더에 동영상을 저장합니다.

​

Debug창의 결과:

 

>> Source Folder: C:\Users\사용자\Desktop\Export2Videos >> Target Folder: C:\Users\사용자\Desktop\Export2Videos 23-12-03 08:53:45 (0001) Converting Export2Videos1.pptx to Export2Videos1_45263.3706597222.mp4 23-12-03 08:53:50 (0002) Converting Export2Videos2.pptx to Export2Videos2_45263.3707175926.mp4 23-12-03 08:53:54 (0003) Converting 프레젠테이션1.ppt to 프레젠테이션1_45263.3707638889.mp4 23-12-03 08:53:55 (0004) Converting 프레젠테이션1.pptx to 프레젠테이션1_45263.370775463.mp4 23-12-03 08:54:09 4 file(s) processed.

 

mp4파일 생성 결과:

동영상 중복파일이 있는 경우 뒤에 숫자(현재시간)를 붙입니다.

그냥 덮어쓰려면 Overwrite = True 로 바꾸면 되겠습니다.

 

 

​

Export2Videos1.pptm

0.04MB

 

관련: 지식인