PPT 일부 슬라이드만 블러처리된 그림 프레젠이션 만들기

관련 : 지식인

 

 

예를 들어서 3~7슬라이드는 제대로 보여주고 나머지 슬라이드는 블러처리해서 

클라이언트에게 미리 보여주는 상황입니다.

 

파워포인트에 이런 기능은 없습니다.

​​

직접 처리하자면 파일을 다른 이름으로 저장에서 모든 슬라이드를 그림으로 저장하고

그래픽 소프트웨어로 일부 슬라이드그림만 블러 처리해서 저장한 다음

다시 파워포인트에서 삽입 > 사진 앨범으로 사진들을 일괄 삽입해서 PPTX로 저장하거나 PDF로 저장해야 합니다.

​

​

이 과정을 VBA로 자동으로 처리할 수 있습니다.

Const BindingMargin As Single = 0        '제본시 왼쪽 여백

'저장 이미지 형식
Const ImgType = "PNG"

'블러(모자이크) 제외 슬라이드
Const PageFrom = 3
Const pageTo = 7

'Blur정도
Const BlurAmount = 30

Sub A1_SaveAsImagePPT()
    Dim prs As Presentation
    Dim usr As VbMsgBoxResult
    
    'Set prs = ActivePresentation
    usr = MsgBox("페이지 " & PageFrom & "부터 " & pageTo & "를 제외한 페이지를 블러처리하고 " & vbNewLine & vbNewLine & _
        "모든 슬라이드를 그림 프레젠테이션으로 저장할까요?", _
        vbInformation + vbOKCancel, "모자이크 그림 PPT 생성")
    If usr <> vbOK Then Exit Sub
    
 
    Set prs = ActivePresentation
    Set prs = A2_SaveAsImagePresentation(prs)
 
    If Not prs Is Nothing Then
         Call A2_PeplaceWithBlur(prs)
         
    End If

End Sub

Function A2_SaveAsImagePresentation(Optional oldPPT As Presentation) As Presentation
   
    Dim newPPT As Presentation
    Dim oldLayouts As CustomLayouts
    Dim i As Long
    Dim SW As Single, SH As Single, nWidth As Single, nHeight As Single
    Dim dPath As String, Fname As String, Pname As String, Bname As String
    Dim sld As Slide, newSld As Slide, shp As Shape
    Dim x As Single, y As Single, w As Single, h As Single
      
    '//현재 프리젠테이션
    If oldPPT Is Nothing Then Set oldPPT = ActivePresentation
    Fname = oldPPT.Name
    Bname = Left(Fname, InStrRev(Fname, ".") - 1)   '확장자 없이 이름만 추출
    
    '//새 프리젠테이션 열기
    dPath = oldPPT.Path & "\"
    Set newPPT = Presentations.Add(WithWindow:=msoTrue)
    If newPPT Is Nothing Then GoTo ErrMsg
    
    '//페이지설정 복사
    With newPPT.PageSetup
        .SlideOrientation = oldPPT.PageSetup.SlideOrientation
        .SlideSize = oldPPT.PageSetup.SlideSize
        .SlideWidth = oldPPT.PageSetup.SlideWidth
        .SlideHeight = oldPPT.PageSetup.SlideHeight
        SW = .SlideWidth: SH = .SlideHeight
    End With
    
    '비트맵 그림 저장시 확대비율
    nWidth = 3072                       '2010에서 최대 3072px, 2019이상은 8192px 이상 가능
    nHeight = SH * nWidth / SW
      
    On Error GoTo ErrMsg

    '//모든 슬라이드에 대해 순환
    i = 1
    For Each sld In oldPPT.Slides
        
        '기존 슬라이드 이미지로 저장
        Pname = Bname & i & "." & ImgType
        
        If ImgType Like "EMF" Then
            sld.Export dPath & Pname, ImgType
        Else
            sld.Export dPath & Pname, ImgType, nWidth, nHeight
        End If
        
        '새 슬라이드 추가
        Set newSld = newPPT.Slides.Add(i, ppLayoutBlank)
        
        '기존 디자인 복사하려면 주석 제거
        'newSld.Design = sld.Design
        
        'image 붙이기
        h = SH:         y = 0:        w = SW:        x = 0
        
        '제본용으로 인쇄시 홀수페이지는 왼쪽에, 짝수페이지는 오른쪽에 BindingMrgin 추가
        If i Mod 2 = 1 Then
            x = x + BindingMargin
            w = w - BindingMargin
        Else
            w = w - BindingMargin
        End If
        Set shp = newSld.Shapes.AddPicture(dPath & Pname, msoFalse, msoTrue, x, y, w, h)
        shp.Name = Pname
        
        Kill dPath & Pname  '각 슬라이드 이미지 삭제
                 
        i = i + 1

    Next sld

    newPPT.SaveAS FileName:=dPath & Bname & "_New.pptx", FileFormat:=ppSaveAsDefault

    If i > 1 Then
        If MsgBox(i - 1 & "개의 이미지 슬라이드 복사본를 생성하였습니다:" & vbNewLine & _
            dPath & Bname & "_New.pptx" & vbNewLine & vbNewLine & _
            "블러처리를 계속할까요?", vbOKCancel) <> vbOK Then
                Set newPPT = Nothing
        End If
        Set A2_SaveAsImagePresentation = newPPT
    End If
    
ErrMsg:
    If Err.Number Then MsgBox Err.Description
    Set newPPT = Nothing
    
End Function

Function A2_PeplaceWithBlur(Optional pres As Presentation)

    Dim sld As Slide   'Slide
    Dim shp As Shape, nshp As Shape
    Dim pEft As PictureEffect
    Dim SW!, SH!, nWidth!, nHeight!
    Dim Pname As String
    
    If pres Is Nothing Then Set pres = ActivePresentation
    
    With pres.PageSetup
        SW = .SlideWidth: SH = .SlideHeight
    End With
    
    Pname = pres.Path & "\" & "temp." & ImgType
    nWidth = 3072
    nHeight = SH * nWidth / SW

    For Each sld In pres.Slides
        If sld.SlideIndex < PageFrom Or sld.SlideIndex > pageTo Then
            For Each shp In sld.Shapes
                If shp.Type = msoPicture And shp.Name Like "*." & ImgType Then
                    Set pEft = shp.Fill.PictureEffects.Insert(msoEffectBlur)
                    pEft.EffectParameters(1).Value = BlurAmount
                    'shp.Export pres.Path & "\" & "temp." & ImgType, ppShapeFormatPNG
                    sld.Export Pname, ImgType, nWidth, nHeight
                    With shp
                        Set nshp = sld.Shapes.AddPicture(Pname, msoFalse, msoTrue, .Left, .Top, .Width, .Height)
                        nshp.Name = .Name
                    End With
                    Kill Pname
                    shp.Delete
                End If
            Next shp
        End If
    Next sld
    
    If MsgBox("처리 완료했습니다. 저장할까요?", vbOKCancel) = vbOK Then pres.Save
    
End Function

 

Alt-F11 누르고 창이 뜨면 삽입 > 모듈 추가한 후에 위 코드를 붙여넣고 F5로 매크로를 실행하면 됩니다.

​

위의 경우 3~7페이지는 놔두고 나머지 슬라이드는 30정도 블러 처리를 해서 각 슬라이드를 이미지로 저장해서 새로운 ppt를 만들어줍니다.

이전(왼쪽)과 이후(오른쪽) 1,2 슬라이드가 블러처리됨

각 슬라이드가 그림으로 변환된 새 파일이 생성됩니다.

그림이라서 수정할 수도 없고 블러 처리된 슬라이드는 궁금증을 자아내게 됩니다.​

 

_New.pptx 파일을 그대로 사용해도 되고 pdf로 저장해도 됩니다.

​

첨부한 Before와 After파일 참고하세요.

 

매크로 실행전 파일

Sample15Before.pptm

0.18MB

매크로 실행해서 새로 만들어진 파일

Sample15After.pptx

1.80MB