슬라이드 이미지 분할 인쇄 및 저장

PPT+VBA 2019. 6. 8. 06:32

 

위 화면은 ProPoster 로 이미지를 분할하는 화면입니다.

A4만 지원하는 프린터에서 이미지를 크게 확대하고 싶을 때 기존 이미지를

분할해서 각 이미지를 A4에 꽉차게 인쇄한 후 조각 이미지를 합쳐주는 방법입니다.

 

위와 같은 작업을 PPT에서 해보도록 하겠습니다.

 

먼저 이미지는 최대한 큰 해상도로 준비합니다.

가능하면 .emf 같은 벡터 이미지가 좋습니다.

.emf나 .wmf 는 파워포인트에 삽입하면( 혹은 일러스트레이터에서 복사해서 슬라이드에 붙이면)

겉으로는 비트맵 그림으로 삽입되지만 우클릭해서 오피스개체로 변환하면 선이나 도형으로 변환되어 편집이 가능할 정도로 실제로는 벡터 이미지입니다.

 

첨부파일을 열어서 테스해봅시다.

분할저장1EMF우체국.pptm
0.04MB

매크로컨텐츠허용해서 열어주세요.

우체국 로고를 벡터 이미지로 삽입했습니다.

Alt-F8을 누르고 Slice라는 매크로를 실행합니다.

그리고 가로칸수, 세로칸수를 입력합니다.

가로로 3칸, 세로로 2칸이라면 "3,2" 로 입력합니다.

 

 

내부적으로는 현재 슬라이드전체를 EMF이미지로 저장하고 

각 조각별로 슬라이드를 추가하고 emf이미지를 넣은 다음 해당되는 부분만 Crop해주게 됩니다.

 

아래는 2,2로 나눈 결과입니다.

 

 

아래는 3,2로 나눈 결과입니다.

 

 

아래는 4,3로 나눈 결과입니다.

 

 

이렇게 원하는 칸수대로 슬라이드를 분할할 수 있습니다.

코드상에 여백(Margin)을 조정하면 조각 이미지를 붙일 때 여유 공간이 더 생기겠습니다.

Crop 작업전 현재 ppt가 저장된 상태여야만 합니다.

 

아래는 매크로 코드입니다.

 

Option Explicit

Dim TargetSlide As Integer
Dim TargetFile As String

Sub Slice()
    Dim user As String
    Dim RowCol() As String
    Dim Cols As Integer, Rows As Integer

    If Not ActivePresentation.Saved Then MsgBox "반드시 파일이 먼저 저장된 상태여야 합니다.": Exit Sub
    
    user = InputBox("선택 슬라이드를 가로, 세로로 작게 분할하여 EMF파일로 저장합니다." & vbNewLine & vbNewLine & _
        "가로와 세로 칸수를 콤마(,)로 구분해서 입력하세요:" & vbNewLine & "(예: 3, 2 =>가로3칸*세로2칸)", "화면 분할 저장")
    If Len(user) = 0 Then Exit Sub
    
    RowCol = Split(user, ",")
    
    If UBound(RowCol) <> 1 Then MsgBox "콤마로 구분된 숫자2개가 아닙니다.": Exit Sub
    If Not IsNumeric(RowCol(0)) Or Not IsNumeric(RowCol(1)) Then _
        MsgBox "숫자로 입력하세요.": Exit Sub
        
    Cols = CInt(RowCol(0)): Rows = CInt(RowCol(1))
    
    TargetSlide = ActiveWindow.Selection.SlideRange(1).SlideIndex  ' 선택된 첫번째 슬라이드
    
    'CenterImage ' 중앙정렬
    
    TargetFile = ActivePresentation.Path & "\" & TargetSlide & ".emf"
    
    SaveSlide
    
    SliceImage Cols, Rows     '가로 세로 숫자를 변경 가능: 3,3 이나 2,4 등
    
    Save2PPTx Cols, Rows
    
End Sub

Function CenterImage()
    
    Dim SW As Single, SH As Single
    Dim shp As Shape
    Dim Margin As Single
    
    Margin = 5 '바깥여백
    With ActivePresentation.PageSetup
        SW = .SlideWidth
        SH = .SlideHeight
    End With
    '도형 개수가 1개이고 그림형식이면 가운데로 맞춤
    With ActivePresentation.Slides(TargetSlide)
        If .Shapes.Count = 1 And .Shapes(1).Type = msoPicture Then
            Set shp = .Shapes(1)
            shp.LockAspectRatio = msoFalse
            shp.Width = SW - Margin * 2
            shp.Height = SH - Margin * 2
            shp.Left = Margin
            shp.Top = Margin
        End If
    End With
        
End Function


Function SaveSlide()

    With ActivePresentation
        .Slides(TargetSlide).Export TargetFile, "EMF", 1, 1
    End With
    
End Function

Function SliceImage(Col As Integer, Row As Integer)

    On Error Resume Next
    Dim n As Integer
    Dim r As Integer, c As Integer
    Dim w As Single, h As Single
    Dim oWidth As Single, oHeight As Single
    
    With ActivePresentation.PageSetup
        oWidth = .SlideWidth: oHeight = .SlideHeight
    End With
    
    w = oWidth / Col: h = oHeight / Row
    
    For r = 0 To Row - 1
        For c = 0 To Col - 1
    
            With ActivePresentation.Slides(TargetSlide).Shapes.AddPicture(TargetFile, _
                0, 1, 0, 0, oWidth, oHeight)
                .Name = "Slice" & TargetSlide & "_" & (r + 1) & "_" & (c + 1)
                .ScaleWidth 1, msoTrue
                .ScaleHeight 1, msoTrue
                
                .PictureFormat.CropLeft = oWidth * c / Col
                .PictureFormat.CropRight = oWidth * (Col - c - 1) / Col
                .PictureFormat.CropTop = oHeight * r / Row
                .PictureFormat.CropBottom = oHeight * (Row - r - 1) / Row
    
                .Width = w
                .Height = h
                .Left = 0 + c * w
                .Top = 0 + r * h
                .Line.Weight = 0.1
                
                .Export ActivePresentation.Path & "\" & .Name & ".emf", ppShapeFormatEMF, 1, 1
                .Delete
            End With
            
        Next c
    Next r
    
End Function

Function Save2PPTx(Col As Integer, Row As Integer)

    Dim usr As VbMsgBoxResult
    Dim ppt As Presentation
    Dim sld As Slide
    Dim shp As Shape
    Dim SW As Single, SH As Single
    Dim pptFile As String, slicedFile As String
    Dim r As Integer, c As Integer
    Dim Margin As Single
    
    Set ppt = ActivePresentation

    If ppt.Slides.Count > 1 Then
        usr = MsgBox("_Sliced.pptx파일의 슬라이드 개수가 이미 2개 이상입니다. 계속할까요?" & vbNewLine & vbNewLine & _
        "=> 계속 추가(Yes), 새로 시작(No), 취소(Cancel)", vbYesNoCancel)
        If usr = vbNo Then
            For c = ppt.Slides.Count To 2 Step -1
                ppt.Slides(c).Delete
            Next c
        ElseIf usr = vbCancel Then
            Set ppt = Nothing: Exit Function
        End If
    End If
    
    
    With ppt.PageSetup
        SW = .SlideWidth: SH = .SlideHeight
    End With
    
    Margin = 0          '슬라이드 여백
    
    For r = 1 To Row
        For c = 1 To Col
            Debug.Print r, c;
            ppt.Slides.Add((r - 1) * c + c, ppLayoutBlank).MoveTo ppt.Slides.Count + 1
            Set sld = ppt.Slides(ppt.Slides.Count)
            slicedFile = "Slice" & TargetSlide & "_" & r & "_" & c & ".emf"
            Set shp = sld.Shapes.AddPicture( _
                ActivePresentation.Path & "\" & slicedFile, 0, 1, Margin, Margin)
            shp.Name = slicedFile
            shp.LockAspectRatio = msoFalse
            shp.Width = SW
            shp.Height = SH
            Debug.Print slicedFile
            Kill ActivePresentation.Path & "\" & slicedFile
        Next c
    Next r
    
    'ppt.Close
    Set ppt = Nothing
    
    MsgBox "Sliced images are saved in pptx."
End Function

 

참고 - 지식인답변 링크:

https://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020103&docId=328646369

 

유사 기능은 Jobs추가기능에도 포함되었었습니다.

https://cafe.naver.com/gameppt/139722

 

[설쓸신잡] 설치해두면 쓸데없는 신비...

[설쓸신잡] 설치해두면 쓸데없는 신비한 잡다도구 Jobs v2018.01 를 소개합니다. ...

cafe.naver.com

 

 

[2021.12.5 추가]

기존 버전에서는 처음 슬라이드의 크기를 그대로 유지하면서 분할하고 있는데

슬라이드를 나누었을 때의 사이즈를 기준으로 만드는 버전입니다.

만일 A4 슬라이드를 3, 2로 나눈 다면 아래처럼 가로 29.7/3, 세로 21/2 로 슬라이드 사이즈가 바뀌도록 했습니다.

프린트 한다면 여백이 많이 생길 것입니다.

 

수정 코드 보기:

더보기 
Option Explicit

Dim TargetSlide As Integer
Dim TargetFile As String

Sub Slice()
    Dim user As String
    Dim RowCol() As String
    Dim Cols As Integer, Rows As Integer

    If Not ActivePresentation.Saved Then MsgBox "반드시 파일이 먼저 저장된 상태여야 합니다.": Exit Sub
    
    user = InputBox("선택 슬라이드를 가로, 세로로 작게 분할하여 EMF파일로 저장합니다." & vbNewLine & vbNewLine & _
        "가로와 세로 칸수를 콤마(,)로 구분해서 입력하세요:" & vbNewLine & "(예: 3, 2 =>가로3칸*세로2칸)", "화면 분할 저장", "3,2")
    If Len(user) = 0 Then Exit Sub
    
    RowCol = Split(user, ",")
    
    If UBound(RowCol) <> 1 Then MsgBox "콤마로 구분된 숫자2개가 아닙니다.": Exit Sub
    If Not IsNumeric(RowCol(0)) Or Not IsNumeric(RowCol(1)) Then _
        MsgBox "숫자로 입력하세요.": Exit Sub
        
    Cols = CInt(RowCol(0)): Rows = CInt(RowCol(1))
    
    TargetSlide = ActiveWindow.Selection.SlideRange(1).SlideIndex  ' 선택된 첫번째 슬라이드
    
    'CenterImage ' 중앙정렬
    
    TargetFile = ActivePresentation.Path & "\" & TargetSlide & ".emf"
    
    SaveSlide
    
    SliceImage Cols, Rows     '가로 세로 숫자를 변경 가능: 3,3 이나 2,4 등
    
    Save2PPTx Cols, Rows
    
End Sub

Function CenterImage()
    
    Dim SW As Single, SH As Single
    Dim shp As Shape
    Dim Margin As Single
    
    Margin = 5 '바깥여백
    With ActivePresentation.PageSetup
        SW = .SlideWidth
        SH = .SlideHeight
    End With
    '도형 개수가 1개이고 그림형식이면 가운데로 맞춤
    With ActivePresentation.Slides(TargetSlide)
        If .Shapes.Count = 1 And .Shapes(1).Type = msoPicture Then
            Set shp = .Shapes(1)
            shp.LockAspectRatio = msoFalse
            shp.Width = SW - Margin * 2
            shp.Height = SH - Margin * 2
            shp.Left = Margin
            shp.Top = Margin
        End If
    End With
        
End Function


Function SaveSlide()

    With ActivePresentation
        .Slides(TargetSlide).Export TargetFile, "EMF", 1, 1
    End With
    
End Function

Function SliceImage(Col As Integer, Row As Integer)

    On Error Resume Next
    Dim n As Integer
    Dim r As Integer, c As Integer
    Dim w As Single, h As Single
    Dim oWidth As Single, oHeight As Single
    
    With ActivePresentation.PageSetup
        oWidth = .SlideWidth: oHeight = .SlideHeight
    End With
    
    w = oWidth / Col: h = oHeight / Row
    
    For r = 0 To Row - 1
        For c = 0 To Col - 1
    
            With ActivePresentation.Slides(TargetSlide).Shapes.AddPicture(TargetFile, _
                0, 1, 0, 0, oWidth, oHeight)
                .Name = "Slice" & TargetSlide & "_" & (r + 1) & "_" & (c + 1)
                .ScaleWidth 1, msoTrue
                .ScaleHeight 1, msoTrue
                
                .PictureFormat.CropLeft = oWidth * c / Col
                .PictureFormat.CropRight = oWidth * (Col - c - 1) / Col
                .PictureFormat.CropTop = oHeight * r / Row
                .PictureFormat.CropBottom = oHeight * (Row - r - 1) / Row
    
                .Width = w
                .Height = h
                .Left = 0 + c * w
                .Top = 0 + r * h
                .Line.Weight = 0.1
                
                .Export ActivePresentation.Path & "\" & .Name & ".emf", ppShapeFormatEMF, 1, 1
                .Delete
            End With
            
        Next c
    Next r
    
End Function

Function Save2PPTx(Col As Integer, Row As Integer)

    Dim usr As VbMsgBoxResult
    Dim ppt As Presentation, ppt1 As Presentation
    Dim sld As Slide
    Dim shp As Shape
    Dim SW As Single, SH As Single
    Dim pptFile As String, slicedFile As String
    Dim r As Integer, c As Integer
    Dim Margin As Single
    
    Set ppt = ActivePresentation
 
    With ppt.PageSetup
        SW = .SlideWidth: SH = .SlideHeight
    End With
    
    
    Set ppt1 = Application.Presentations.Add(msoTrue)
    With ppt1.PageSetup
        .SlideSize = ppSlideSizeCustom
        .SlideWidth = SW / Col
        .SlideHeight = SH / Row
    End With
    
    Margin = 0          '슬라이드 여백
    
    For r = 1 To Row
        For c = 1 To Col
            Debug.Print r, c;
            ppt1.Slides.Add((r - 1) * c + c, ppLayoutBlank).MoveTo ppt1.Slides.Count + 1
            Set sld = ppt1.Slides(ppt1.Slides.Count)
            slicedFile = "Slice" & TargetSlide & "_" & r & "_" & c & ".emf"
            Set shp = sld.Shapes.AddPicture( _
                ppt.Path & "\" & slicedFile, 0, 1, Margin, Margin)
            shp.Name = slicedFile
            shp.LockAspectRatio = msoFalse
            shp.Width = SW / Col
            shp.Height = SH / Row
            Debug.Print slicedFile
            Kill ppt.Path & "\" & slicedFile
        Next c
    Next r
    
    pptFile = Left(ppt.FullName, InStrRev(ppt.FullName, ".") - 1) & "_Sliced.pptx"
    ppt1.SaveAs pptFile, ppSaveAsDefault
    MsgBox "Sliced images are saved in " & pptFile
    
    'ppt.Close
    Set ppt1 = Nothing
    Set ppt = Nothing
End Function

 

파일 다운로드:

분할저장21EMF우체국.pptm
0.04MB

 

 

[2022.09.15 추가]

 

위 버전에서 슬라이드 개수가 여러 개인 경우를 반영한 수정 버전입니다. 

더보기 
Option Explicit

Function CenterImage(TargetSlide As Long)
    
    Dim SW As Single, SH As Single
    Dim shp As Shape
    Dim Margin As Single
    
    Margin = 5 '바깥여백
    With ActivePresentation.PageSetup
        SW = .SlideWidth
        SH = .SlideHeight
    End With
    '도형 개수가 1개이고 그림형식이면 가운데로 맞춤
    With ActivePresentation.Slides(TargetSlide)
        If .Shapes.Count = 1 And .Shapes(1).Type = msoPicture Then
            Set shp = .Shapes(1)
            shp.LockAspectRatio = msoFalse
            shp.Width = SW - Margin * 2
            shp.Height = SH - Margin * 2
            shp.Left = Margin
            shp.Top = Margin
        End If
    End With
        
End Function

Function SliceImage(oSld As Slide, sTargetFile As String, Col As Integer, Row As Integer)

    On Error Resume Next
    Dim n As Integer
    Dim r As Integer, c As Integer
    Dim w As Single, h As Single
    Dim oWidth As Single, oHeight As Single
    
    With oSld.Parent.PageSetup
        oWidth = .SlideWidth: oHeight = .SlideHeight
    End With
    
    w = oWidth / Col: h = oHeight / Row
    
    For r = 0 To Row - 1
        For c = 0 To Col - 1
            With oSld.Parent.Slides(oSld.SlideIndex).Shapes.AddPicture(sTargetFile, _
                0, 1, 0, 0, oWidth, oHeight)
                .Name = "Slice" & oSld.SlideIndex & "_" & (r + 1) & "_" & (c + 1)
                .ScaleWidth 1, msoTrue
                .ScaleHeight 1, msoTrue
                
                .PictureFormat.CropLeft = oWidth * c / Col
                .PictureFormat.CropRight = oWidth * (Col - c - 1) / Col
                .PictureFormat.CropTop = oHeight * r / Row
                .PictureFormat.CropBottom = oHeight * (Row - r - 1) / Row
    
                .Width = w
                .Height = h
                .Left = 0 + c * w
                .Top = 0 + r * h
                .Line.Weight = 0.1
                
                .Export oSld.Parent.Path & "\" & .Name & ".emf", ppShapeFormatEMF, 1, 1
                .Delete
            End With
            
        Next c
    Next r
    
End Function

Sub SliceSlides()

    Dim user As String
    Dim usr As VbMsgBoxResult
    Dim ppt As Presentation, ppt1 As Presentation
    Dim sld As Slide
    Dim shp As Shape
    Dim SW As Single, SH As Single
    Dim pptFile As String, slicedFile As String
    Dim r As Integer, c As Integer
    Dim Margin As Single
    Dim RowCol() As String
    Dim Cols As Integer, Rows As Integer
    Dim TargetSlide As Integer
    Dim targetFile As String


    Set ppt = ActivePresentation
    If Not ppt.Saved Then MsgBox "반드시 파일이 먼저 저장된 상태여야 합니다.": Exit Sub
    
    user = InputBox("선택 슬라이드를 가로, 세로로 작게 분할하여 EMF파일로 저장합니다." & vbNewLine & vbNewLine & _
        "가로와 세로 칸수를 콤마(,)로 구분해서 입력하세요:" & vbNewLine & "(예: 3, 2 =>가로3칸*세로2칸)", "화면 분할 저장", "3,2")
    If Len(user) = 0 Then Exit Sub
    
    RowCol = Split(user, ",")
    
    If UBound(RowCol) <> 1 Then MsgBox "콤마로 구분된 숫자2개가 아닙니다.": Exit Sub
    If Not IsNumeric(RowCol(0)) Or Not IsNumeric(RowCol(1)) Then _
        MsgBox "숫자로 입력하세요.": Exit Sub
        
    Cols = CInt(RowCol(0)): Rows = CInt(RowCol(1))
 
    With ppt.PageSetup
        SW = .SlideWidth: SH = .SlideHeight
    End With
    
    Set ppt1 = Application.Presentations.Add(msoTrue)
    With ppt1.PageSetup
        .SlideSize = ppSlideSizeCustom
        .SlideWidth = SW / Cols
        .SlideHeight = SH / Rows
    End With
    
    Margin = 0          '슬라이드 여백
    
    For Each sld In ppt.Slides
        
        '슬라이드 저장
        TargetSlide = sld.SlideIndex    '  슬라이드
        'CenterImage ' 중앙정렬
        targetFile = ppt.Path & "\" & Format(TargetSlide, "000") & ".emf"
        ppt.Slides(TargetSlide).Export targetFile, "EMF", 1, 1
        
        '슬라이드 이미지 조각내기
        Call SliceImage(sld, targetFile, Cols, Rows)
        
        '슬라이드 이미지 조각 새 슬라이드에 삽입
        For r = 1 To Rows
            For c = 1 To Cols
                Debug.Print r, c;
                ppt1.Slides.Add((r - 1) * c + c, ppLayoutBlank).MoveTo ppt1.Slides.Count + 1
                Set sld = ppt1.Slides(ppt1.Slides.Count)
                
                slicedFile = "Slice" & TargetSlide & "_" & r & "_" & c & ".emf"
                Set shp = sld.Shapes.AddPicture( _
                    ppt.Path & "\" & slicedFile, 0, 1, Margin, Margin)
                shp.Name = slicedFile
                shp.LockAspectRatio = msoFalse
                shp.Width = SW / Cols
                shp.Height = SH / Rows
                Debug.Print slicedFile
                Kill ppt.Path & "\" & slicedFile
            Next c
        Next r
    
    Next sld
    
    pptFile = Left(ppt.FullName, InStrRev(ppt.FullName, ".") - 1) & "_Sliced.pptx"
    ppt1.SaveAs pptFile, ppSaveAsDefault
    MsgBox "Sliced images are saved in " & pptFile
    
    'ppt.Close
    'Set ppt1 = Nothing
    Set ppt = Nothing
End Sub

 

실행 화면: 

첨부파일을 열어 놓고 자신의 ppt 파일을 연 다음

매크로 위치를 첨부파일 pptm으로 선택한 뒤에 SliceSlides 를 실행합니다.

그리고 가로 세로 개수를 입력하세요. 가로 1열, 세로 2행으로 나눈다면 1, 2를 입력합니다.

 

중간에 각 슬라이드를  EMF로 저장해서 다시 삽입하고 자르기 때문에 시간이 조금 걸리고 텍스트 상자의 경우 기존에 사용된 폰트가 설치되어 있어야 원래대로 폰트를 유지합니다. 설치되어 있지 않은 폰트의 경우 기본 폰트로 대체됩니다.

 

나머지는 첨부파일 참고하세요.(2022.11.04 수정)

분할저장_A4세로_1_2.pptm
1.17MB

 

 

같은 버전(가로 B4 를 2*1로 분할)

 

분할저장_B4가로_2_1.pptm
1.32MB

 

 

분할저장_A4가로2장을세로1장으로_2_1.pptm
1.17MB

 

 

👉 대형 배너 분할인쇄 적용 사례:

https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102020103&docId=431464041#answer1 

 

파워포인트 대형인쇄

배너를 제작해야해서 파워포인트로 68*130(cm) 크기로 작업을 했습니다. b4 10장이 딱 그 사이즈에 들어가서 분할 인쇄하여 붙이려고 하는데 어떻게 하나요?

kin.naver.com

 

저작자표시 비영리 동일조건

'PPT+VBA' 카테고리의 다른 글

PPT 한글, 영문 폰트 및 기타 속성 일괄 변경하기  (17) 2019.10.29
파워포인트에서 메뉴-서브메뉴 시스템 구현  (1) 2019.09.05
여러 PPT안의 특정 단어 검색(도형 및 VBA 코드 포함 검색)  (7) 2019.07.07
각 슬라이드에 한글자씩 가득차게 분할 출력  (0) 2019.07.02
VBA로 슬라이드 자동 생성 - '자주 쓰는 영어속담 50개'  (4) 2019.04.16
ppt 슬라이드를 워드 Doc, PDF, txt 로 저장  (4) 2019.04.05
PPT, Excel 등 MS 오피스 Office 2010 버전 등 구하기  (4) 2019.03.16
실시간 RSS 뉴스와 날씨 슬라이드쇼  (0) 2019.03.15

티스토리툴바