위 화면은 ProPoster 로 이미지를 분할하는 화면입니다.
A4만 지원하는 프린터에서 이미지를 크게 확대하고 싶을 때 기존 이미지를
분할해서 각 이미지를 A4에 꽉차게 인쇄한 후 조각 이미지를 합쳐주는 방법입니다.
위와 같은 작업을 PPT에서 해보도록 하겠습니다.
먼저 이미지는 최대한 큰 해상도로 준비합니다.
가능하면 .emf 같은 벡터 이미지가 좋습니다.
.emf나 .wmf 는 파워포인트에 삽입하면( 혹은 일러스트레이터에서 복사해서 슬라이드에 붙이면)
겉으로는 비트맵 그림으로 삽입되지만 우클릭해서 오피스개체로 변환하면 선이나 도형으로 변환되어 편집이 가능할 정도로 실제로는 벡터 이미지입니다.
첨부파일을 열어서 테스해봅시다.
매크로컨텐츠허용해서 열어주세요.
우체국 로고를 벡터 이미지로 삽입했습니다.
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
[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
파일 다운로드:
[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 수정)
같은 버전(가로 B4 를 2*1로 분할)
👉 대형 배너 분할인쇄 적용 사례:
https://kin.naver.com/qna/detail.naver?d1id=1&dirId=102020103&docId=431464041#answer1
🍕 105cm*65cm 비율의 슬라이드를 A4사이즈 29.7* 21로 분할하는 예시
특히 '몇개의 가로*세로 개수로 나누는가'가 관건입니다.
예를 들어 위처럼 위 아래에 여백이 조금 생기지만 5 * 2개의 A4비율 사각형(A4종이)로 나눌 수 있습니다.
A4 두장이 위, 아래로 배열되어 60cm 정도가 되어 위아래에 5cm정도 여백이 생깁니다.
여백 때문에 균등하게 분할한 부분을 A4로 인쇄하면 위아래로 5cm만큼 약간 눌릴 수 있습니다.
다른 예시:
실행결과 아래와 같이 분할되었습니다.
여기에 사용된 pptm 파일:
세로 원본을 정확히 2*2페이지 A4사이즈로 분할하는 예시:
'PPT+VBA' 카테고리의 다른 글
PPT 한글, 영문 폰트 및 기타 속성 일괄 변경하기 (19) | 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 |
최근댓글