텍스트를 여러 장의 자막 슬라이드로 일괄 생성

 

예를 들어 자막 파일이 있을 때 이 자막을 나눠서 여러 슬라이드에 삽입하고 싶은 경우입니다.

 

여기서는 텍스트를 엑셀파일에 정리하고 프레젠테이션의 마지막 슬라이드가 기준이 되어 해당 기준 슬라이드의 텍스트상자를 기준으로 자막 슬라이드를 일괄로 생성하는 조건입니다.

​

1. 작업 편의상 엑셀파일에 장문의 텍스트를 정리합니다. 텍스트 파일의 경우 단순히 줄바꿈을 기준으로 슬라이드를 나눌 수 있는데 여러 줄을 한 슬라이드에 넣을 때는 그 기준이 모호합니다. 그래서 여기서는 엑셀 행으로 슬라이드를 구분하도록 합니다.

 

한개의 행의 내용이 한 슬라이드에 들어갑니다. Shift+Enter를 쳐서 여러 줄을 넣을 수 있습니다.

 

만약 여러 행의 글인 경우 일단 A열의 특정셀에 붙여넣어 두고 우클릭해서 SplitByLines 를 실행하면 현재 셀을 줄바꿈단위로 여러 행으로 자동으로 나눠서 해당 셀 바로 아래에 넣어줍니다.

 

 

우클릭하고 SplitByLinesBlank 를 실행하면 현재 셀을 빈줄 단위로 여러 행으로 자동으로 나눠줍니다. 다른 말로 바꾸면 단순 엔터가 아니라 엔터가 2번 연속되는 부분을 기준으로 슬라이드를 나누게 됩니다. 이 경우 여러 줄의 텍스트가 한 슬라이드에 들어가게 할 수 있습니다.

 

Alt+F8누르고 AutoHeight를 누르면 행의 높이를 보기 좋게 조절해 줍니다.​

 

2. 첨부한 파워포인트 pptm파일을 파일속성에서 차단해제 > 확인한 다음 열면서 매크로를 허용해줍니다.

그리고 맨 마지막 슬라이드에 기준 슬라이드를 만듭니다.

 

텍스트가 들어갈 도형은 TEXT라는 이름의 도형이고 폰트나 색상, 텍스트 효과, 도형 모양 등을 설정합니다.

줄바꿈, 폰트 크기, 폰트 색상, 텍스트상자의 여백 등도 복사되기 때문에 잘 설정해줍니다.

​

3. 파워포인트에서 Alt+F8 을 누르고 매크로를 실행하고

자막 등의 텍스트가 들어 있는 엑셀 파일을 선택합니다.

​

4. 자막 슬라이드가 일괄 생성됩니다.

특히 자막 내용이 많아서 텍스트상자를 벗어나는 경우 텍스트 크기를 자동으로 줄여줍니다.

​

첨부한 샘플 파일 이용해서 테스트해보세요.

주의) pptm 이나 xlsm 은 다운로드한 후에 파일속성에서 '차단해제'한 후 파일을 열 때 매크로를 허용해주세요

 

엑셀 파일에서 줄바꿈을 기준으로 행을 나눠주는 코드:

Sub SplitByLines()

    Dim rng As Range, arr$(), str$, i%
    Set rng = ActiveCell
    
    arr = Split(rng, vbLf)
    If UBound(arr) < 1 Then MsgBox "최소 2줄 이상이어야 합니다.": Exit Sub
    
    For i = LBound(arr) To UBound(arr)
        str = Trim(arr(i))
        If Right(str, 1) = vbCr Then str = Left(str, Len(str) - 1)
        If Len(str) > 0 Then
            rng.Offset(i + 1).Insert Shift:=xlShiftDown
            rng.Offset(i + 1) = str
        End If
    Next i
            
End Sub

Sub SplitByLinesBlank()

    Dim rng As Range, arr$(), str$, i%
    Set rng = ActiveCell
    
    arr = Split(rng, vbLf & vbLf)
    If UBound(arr) < 1 Then MsgBox "최소 2줄 이상이어야 합니다.": Exit Sub
    
    For i = LBound(arr) To UBound(arr)
        str = Trim(arr(i))
        If Right(str, 1) = vbCr Then str = Left(str, Len(str) - 1)
        If Len(str) > 0 Then
            rng.Offset(i + 1).Insert Shift:=xlShiftDown
            rng.Offset(i + 1) = str
        End If
    Next i
            
End Sub

Sub AutoHeight()
    Dim sht As Worksheet, r As Range
    
    Set sht = ActiveSheet
    sht.Rows.AutoFit
    
    For Each r In sht.UsedRange.Columns(1).Cells
        If r.RowHeight < 406 Then r.RowHeight = r.RowHeight + 5
        r.VerticalAlignment = xlVAlignCenter
    Next r
End Sub

 

엑셀 파일을 불러와서 파워포인트 마지막 슬라이드를 기준으로 텍스트를 복사해오는 코드:

Option Explicit

Sub Excel2PPT()
        
    Dim xlApp As Object 'Excel.Application
    Dim xlWb As Object  'Excel.Workbook
    Dim xlSht As Object 'Excel.Worksheet
    Dim r As Object     'Excel.Range
    Dim Target  As String
    Dim LastRow As Long, l As Long
    Dim SW!, SH!, Margin!
    
    Dim sld As Slide
    Dim shp As Shape
    
    Set xlApp = CreateObject("Excel.Application")
    'Set xlApp = New Excel.Application
    If xlApp Is Nothing Then Exit Sub
    
    'Set xlWb = xlApp.Workbooks.Open(ActivePresentation.Path & "\문장목록.xlsx", , True)
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Choose Excel files", "*.xls?"
        .InitialFileName = ActivePresentation.Path & "\"
        If .Show = -1 Then Target = .SelectedItems(1)
    End With
    If Target = "" Then GoTo Oops
    
    Set xlWb = xlApp.Workbooks.Open(Target, , True)
    If xlWb Is Nothing Then GoTo Oops
            
    Set xlSht = xlWb.Sheets(1)
    LastRow = xlSht.Cells(xlSht.Rows.Count, "A").End(-4162).Row   '-4162:xlUp
        
    If LastRow <= 1 Then MsgBox "문장이 1개 이하입니다.": GoTo Oops
        
    With ActivePresentation.PageSetup
        SW = .SlideWidth: SH = .SlideHeight
    End With
        
    l = 1
    Margin = 15
    For Each r In xlSht.Range("A1:A" & LastRow)
        
            With ActivePresentation
                .Slides(.Slides.Count).Duplicate.MoveTo (.Slides.Count)
                Set sld = .Slides(.Slides.Count - 1)
                sld.SlideShowTransition.Hidden = msoFalse
            End With
 
            
            '폰트 크기 조절
            Set shp = sld.Shapes("TEXT")
            With shp.TextFrame.TextRange
                .Text = r
                '텍스트가 2줄을 넘어가는 경우 글씨 크기 줄이기
                'While .Lines.Count > 2
                '    .Font.Size = .Font.Size - 1
                '텍스트가 슬라이드 아래로 넘치는 경우 글씨 크기 줄이기
                While .BoundTop + .BoundHeight > shp.Top + shp.Height ' SH - Margin
                    .Font.Size = .Font.Size - 2
                Wend
            End With
            
            l = l + 1
 
    Next r
        
        
Oops:
    If Not xlApp Is Nothing Then xlApp.Quit: Set xlApp = Nothing
    
    If l Then MsgBox ActivePresentation.Slides.Count - 1 & "개의 슬라이드 추가 완료"
    
End Sub

 

현재 선택된 도형의 여러가지 속성을 다른 슬라이드에 적용시키는 코드:

'현재 선택된 슬라이드의 도형과 텍스트의 속성을  나머지 슬라이드에 이름이 같은 도형에 똑같이 일괄 적용
'도형모양, 크기, 텍스트상자 여백, 위치 등 포함
Private Sub BatchApply()

    Dim sld0 As Slide, sld As Slide, shp0 As Shape, shp As Shape, prs As Presentation
    Dim SW!, SH!, bottomMargin!, i%
    
    Set prs = ActivePresentation
    With prs.PageSetup: SW = .SlideWidth: SH = .SlideHeight: End With
    Set sld0 = ActiveWindow.Selection.SlideRange(1)
    Set shp0 = ActiveWindow.Selection.ShapeRange(1)
    shp0.PickUp
    bottomMargin = SH - (shp0.Top + shp0.Height)
    
    For Each sld In prs.Slides
    
        If Not sld Is sld0 Then
            For Each shp In sld.Shapes
        
                If shp.Name Like shp0.Name Then
                    i = i + 1
                    shp.Apply
                    
                    shp.Width = shp0.Width
                    shp.Height = shp0.Height
                    shp.AutoShapeType = shp0.AutoShapeType
                    shp.TextFrame.AutoSize = ppAutoSizeNone
                    shp.TextFrame.MarginBottom = shp0.TextFrame.MarginBottom
                    shp.TextFrame.MarginTop = shp0.TextFrame.MarginTop
                    shp.TextFrame.MarginLeft = shp0.TextFrame.MarginLeft
                    shp.TextFrame.MarginRight = shp0.TextFrame.MarginRight
                    
                    shp.Top = SH - shp.Height - bottomMargin
                    shp.Left = SW / 2 - shp.Width / 2
                End If
            
            Next shp
        End If
    Next sld
            
    MsgBox i & "개의 도형에 적용 완료"
End Sub

'현재 선택된 슬라이드의 도형과 텍스트의 속성을 나머지 슬라이드에 이름이 같은 도형에 똑같이 일괄 적용
'도형모양, 텍스트 크기나 색상은 제외한 단순 속성만
Private Sub ApplyCurrentShapeFormat()

    Dim sld0 As Slide, sld As Slide, shp0 As Shape, shp As Shape, prs As Presentation
    
    Set prs = ActivePresentation
    Set sld0 = ActiveWindow.Selection.SlideRange(1)
    Set shp0 = ActiveWindow.Selection.ShapeRange(1)
    shp0.PickUp
    
    For Each sld In prs.Slides
    
        If Not sld Is sld0 Then
            For Each shp In sld.Shapes
        
                If shp.Name Like shp0.Name Then
                    i = i + 1
                    shp.Apply
                    
                End If
            
            Next shp
        End If
    Next sld
            
    MsgBox i & "개의 도형에 적용 완료"
End Sub
 
'모든 도형의 폰트 그림자 제거
Private Sub RemoveShadow()

    Dim sld As Slide, shp As Shape, prs As Presentation
    
    Set prs = ActivePresentation
     
    For Each sld In prs.Slides
         
        For Each shp In sld.Shapes
                    
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                 
                    With shp.TextFrame2.TextRange
                        .Font.Shadow.Visible = msoFalse
                    End With
                    i = i + 1
                    
                End If
            End If
        Next shp
    Next sld
            
    MsgBox i & "개의 도형에 적용 완료"
End Sub

 

마지막 코드에 보듯이 BatchApply 등은 현재 선택된 텍스트 상자의  여러가지 속성을 다른 모든 슬라이드의 같은 이름의 도형에 대해 일괄로 서식을 설정하는 것이 가능합니다.

 

SplitByLines1.xlsm

0.02MB

 

자막슬라이드일괄생성1.pptm

0.09MB

 

참고: 지식인