파워포인트에서 사진앨범을 세로형태로 한번에 만드는 방법은 없을까요?

Question

파워포인트에서 세로로된 사진으로 사진앨범을 만들고 있습니다.

사진앨범을 만들고 가로로된 형태를 디자인탭에 들어가

일일이 사용자지정에서 세로로 변경을 하고 있는데요

최근에 무슨 이유인지 최대화가 되지 않고 이미지가 작게 들어가는 현상이 벌어지네요

애초에 세로로 사진앨범을 만들순 없는걸까요?

Answer 1

VBA를 이용해보세요.

Alt-F11 누르고 삽입 > 모듈 추가 후에 아래 코드를 붙여넣고

창 닫고 Alt-F8로 실행하세요.

Option Explicit

Option Base 1   '배열 시작 1번부터

Const LOCKASPECT As Boolean = True  '가로세로 비율 유지

Const LabelOn As Boolean = False    '사진 라벨 추가

Sub M1_MakePhotoAlbum()

    '파일 선택(여러 개 가능)

    Dim Filename  As Variant    '삽입할 그림파일명 리스트(배열)

    Filename = FileSelect

    If VarType(Filename) <> vbArray + vbString Then Exit Sub

    '그림 삽입

    Dim c As Integer    '갯수

    Dim slideNo As Integer

    Dim i As Integer, str$

    Dim Sld As Slide, Shp As Shape, Tshp As Shape

    Dim x!, y!, w!, h!, hm!, vm! '가로,세로, 넓이, 높이, 가로 여백, 세로 여백

    Dim SW As Single, SH As Single  '슬라이드 넓이, 높이

    hm = 0: vm = 0     '여백없이 가득차게

    'hm = 100: vm = 50   '그림 가로, 세로 여백

    c = UBound(Filename)    '그림파일 개수

    With Presentations.Add(msoTrue)

        '슬라이드 크기 구하기

        With .PageSetup

            '16:9

            '.SlideSize = ppSlideSizeOnScreen16x9

            'A4

            .SlideSize = ppSlideSizeA4Paper

            '가로

            '.SlideOrientation = msoOrientationHorizontal

            '세로

            .SlideOrientation = msoOrientationVertical

            SW = .SlideWidth: SH = .SlideHeight

        End With

        For i = 1 To c

            '빈슬라이드 추가

            slideNo = .Slides.Count + 1

            Set Sld = .Slides.Add(slideNo, ppLayoutBlank)

            'Sld.BackgroundStyle = msoBackgroundStylePreset4     '검은 배경

            Sld.FollowMasterBackground = msoFalse

            Sld.Background.Fill.ForeColor.RGB = rgbBlack        '배경 색상  RGB(127,127,127)

            '그림 추가1

            '그림 위치나 크기 사전에 지정

            w = SW - 2 * hm: h = SH - 2 * vm

            x = hm   'sw / 2 + (sw / 2 - w) / 2   '가로 가운데

            y = vm   '(sh / 2 - h) / 2            '세로 가운데

            Set Shp = Sld.Shapes.AddPicture(Filename(i), msoFalse, msoTrue, x, y, w, h)

            With Shp

                .Name = "Pic_" & i

                '.Line.ForeColor.RGB = rgbBlack

                '.Line.Visible = msoFalse

                If LOCKASPECT Then

                    .LockAspectRatio = msoTrue

                    .ScaleWidth 1, msoTrue

                    .ScaleHeight 1, msoTrue

                    .Height = SH

                    If .Width > SW Then .Width = SW

                    .Top = SH / 2 - .Height / 2

                    .Left = SW / 2 - .Width / 2

                End If

            End With

            '라벨 추가

            If LabelOn Then

                Set Tshp = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, x, y + Shp.Height + 5, w, h)

                Tshp.Left = SW / 2 - Tshp.Width / 2

                Tshp.TextFrame.HorizontalAnchor = msoAnchorCenter

                str = Left(Filename(i), InStrRev(Filename(i), ".") - 1)

                str = Mid(str, InStrRev(str, "\") + 1)

                Tshp.TextFrame.TextRange.Text = str     '라벨

                Tshp.TextFrame.TextRange.Font.Size = 15

                Tshp.TextFrame.TextRange.Font.Color.RGB = rgbWhite

                Tshp.Name = "Label_" & i

                '사진과 라벨 그룹

                Sld.Shapes.Range(Array(1, 2)).Group.Name = "Pic_Group_" & i

            End If

            '애니메이션 추가

            'With Sld.TimeLine.MainSequence.AddEffect(Shp, msoAnimEffectFade, , msoAnimTriggerAfterPrevious)

            '    .Timing.Duration = 0.5

            'End With

        Next i

        .SaveAs Environ("USERPROFILE") & "\DeskTop\PhotoAlbum_" & Format(Date, "YYYYMMDD") & Format(Time, "hhnnss") & ".pptx"

    End With

    If i Then MsgBox i - 1 & "개의 그림이 삽입되었습니다.", vbInformation

End Sub

Function FileSelect() As Variant

    Dim FD As FileDialog

    Dim Fname() As String

    Set FD = Application.FileDialog(msoFileDialogFilePicker)    '파일 선택 상자 시작

    With FD

        .AllowMultiSelect = True '중복선택 여부

        .Filters.Clear '기존에 지정된 확장자 초기화

        .Filters.Add "이미지파일", "*.bmp; *.gif; *.jpg; *.png; *.wmf; *.emf; *.svg", 1   '확장자 지정

        .Title = "그림파일을 선택하세요"                    ' 창 제목

        .InitialFileName = ActivePresentation.Path & "\"    '최초 시작 폴더

        If .Show = True Then

            Dim i As Integer, c As Integer

            c = .SelectedItems.Count

            ReDim Fname(1 To c)

            For i = 1 To c

                Fname(i) = .SelectedItems(i)

            Next i

        End If

    End With

    If c = 0 Then FileSelect = msoFalse _

    Else FileSelect = Fname

End Function

'이미지를 슬라이드에 가득차게

Sub M2_FillAllImages()

    Dim Sld As Slide

    Dim Shp As Shape

    For Each Sld In ActivePresentation.Slides

         For Each Shp In Sld.Shapes

             If Shp.Type = msoPicture Then

                Shp.LockAspectRatio = msoFalse

                With ActivePresentation.PageSetup

                    Shp.Width = .SlideWidth

                    Shp.Height = .SlideHeight

                    Shp.Left = 0

                    Shp.Top = 0

                End With

             End If

        Next Shp

    Next Sld

End Sub

M2를 실행하면 기존 이미지를 슬라이드에 가득 차게 채워줍니다.