모핑 슬라이드 사진앨범 생성

삽입 > 사진앨범을 이용하면 각 슬라이드에 사진을 한 장씩 넣을 수 있습니다.

 

이렇게 삽입된 여러장의 사진이 아래처럼 오른쪽에서 왼쪽으로 자동으로 슬라이드되는 

슬라이드 앨범을 만드는 방법입니다.

 

 

사진을 이동애니메이션을 적용해서 오른쪽에서 왼쪽으로 움직이게 할 수도 있지만

모핑 전환을 이용할 수도 있습니다.

 

현재 사진을 이전 슬라이드 오른쪽에 넣어주고 또한

다음 슬라이드의 왼쪽에도 넣어준 다음

모핑 전환을 시키면 사진들이 오른쪽에서 왼쪽으로 계속 슬라이딩으로 넘어가게 됩니다.

 

아래와 같은 코드가 사용되었습니다.

 

Option Explicit

Sub AddMorphingTransition()
    
    Dim pres As Presentation
    Dim sld As Slide
    Dim shp As Shape
    Dim cur As Long
    Dim SW!, SH!
    
    Set pres = ActivePresentation
    If Right(pres.Name, 5) Like ".pptm" Then
        If MsgBox("모핑전환 사진 슬라이드를 생성하려면" & vbNewLine & _
            "사진앨범 파일을 활성화한 상태에서 실행하세요." & vbNewLine & _
            "현재 파일은 pptm 형식파일입니다." & vbNewLine & vbNewLine & _
            "계속하려면 '확인'을 누르세요.", vbOKCancel + vbInformation) = vbCancel Then Exit Sub
    End If
    
    '슬라이드 크기
    With pres.PageSetup
        SW = .SlideWidth: SH = .SlideHeight
    End With
    
    '슬라이드 순환
    For Each sld In pres.Slides
        
        cur = sld.SlideIndex
        '현재 사진을 이전슬라이드의 오른쪽으로
        If cur > 1 Then
            Set shp = findPicture(sld)
            shp.Copy
            DoEvents
            Set shp = pres.Slides(cur - 1).Shapes.Paste(1)
            DoEvents
            shp.Name = "Temp_" & cur
            shp.Left = SW
            shp.Top = 0
        End If
        
        '현재 사진을 다음 슬라이드의 왼쪽으로
        If cur > 1 And cur < pres.Slides.Count Then
            Set shp = findPicture(sld)
            shp.Copy
            DoEvents
            Set shp = pres.Slides(cur + 1).Shapes.Paste(1)
            DoEvents
            shp.Name = "Temp_" & cur
            shp.Left = -shp.Width
            shp.Top = 0
        End If
        
        '모핑 전환
        With sld.SlideShowTransition
            .AdvanceOnTime = msoTrue
            .AdvanceTime = 1
            .Duration = 2
            .EntryEffect = ppEffectMorphByObject    '3954
            '.Speed = 1
            '.SoundEffect.Name = "bg.mp3"
            pres.SlideShowSettings.LoopUntilStopped = msoTrue
        End With
        
    Next sld
    
    pres.SlideShowSettings.Run
End Sub

Function findPicture(oSld As Slide) As Shape

    Dim oShp As Shape
 
    For Each oShp In oSld.Shapes
        If oShp.Type = msoPicture Then
            Set findPicture = oShp
            Exit For
        End If
    Next oShp
    
End Function

 

사진앨범을 만들 때 그림 레이아웃은 '슬라이드에 맞춤'으로 설정하고 

테마는 비워두면 검은 배경의 사진 앨범이 만들어집니다. (나중에 디자인메뉴에서 흰색배경을 설정할 수 있음)

찾아보기를 누르고 Office 테마를 선택하면 흰색 배경으로 만들어집니다.

 

 

전체적으로 아래와 같은 과정으로 작업을 합니다.

매크로를 실행하면 

전환시간은 2초, 모핑 전환이 적용되고

슬라이드쇼 설정은 'ESC를 누를 때까지 반복'으로 설정됩니다.

원하면 다른 시간으로 수정해도 됩니다.

사진은 슬라이드에 맞춰지는데 모두 같은 크기로 맞춰주는 것이 좋습니다.

 

실행화면:

 

샘플 결과물 파일 첨부합니다. 파워포인트 스톡이미지로 만들었습니다.

사진 앨범1.pptx

8.21MB

 

 

매크로 파일은 첨부파일 참고하세요.

MorphSlide1.pptm

0.21MB

 

버전2. 그림의 여백 없이 이어붙이는 기능도 추가한 버전입니다.

 

아래처럼 각 그림의 좌우 여백이 없이 이어붙여서 스크롤하는 방식을 추가했습니다.

 

사진 앨범을 선택한 상태에서 매크로를 실행하면 아래와 같은 옵션이 있습니다.

 

Yes를 누르면 좌우 여백 없이 사진을 계속 이어붙여서 슬라이딩하고

 

No를 누르면 이전 버전처럼 좌우 여백과 함께 한 슬라이드씩 스크롤 합니다.

 

사진을 이어 붙이는 것은 약간 고려할 점이 있습니다.

슬라이드 넓이 보다 좁은 경우 그 다음 사진까지 불러와야 합니다.

따라서 슬라이드 넓이보다 좁은 한 계속 그 다음 혹은 그 이전 사진까지 불러와서 좌우에 복사해줘야 합니다.

 

1슬라이드 왼쪽은 사진이 필요 없지만 무한 반복하는 경우를 대비하여 맨 마지막 사진을 왼쪽에 복사합니다.

 

사진앨범을 만들 때 화면에 가득차는 사진 뿐만 아니라 사진 설명이 있는 그룹도형인 경우도 작동할 수 있게 반영하였습니다. (예시 파일 참고)

 

ImgDarken 이 True인 경우

현재 사진이 아닌 모핑전 사진들은 밝기를 어둡게처리하여 현재 사진을 돋보이게 사진 효과를 적용하였습니다.

 

RemoveCopiedPicsAndTransition 매크로로 모핑 슬라이드 적용 후 다시 취소할 수 있습니다.

 

이어붙인 사진 스크롤하기 실행 영상:

 

 

수정된 코드>>

Module1:

'// Photo Album PPT to Right-To-Left Sliding Show
'// by konahn(at)naver.com

Option Explicit
Option Compare Text     '대소문자 구별 안함

Const ImgDarken As Boolean = True   '다른이미지 어둡게
Dim Pres As Presentation
Dim SW!, SH!

Sub A1_AddMorphingTransition()
    
    Dim Sld As Slide
    Dim Shp As Shape
    Dim cur As Long, s As Long, x As Single
    Dim usr As VbMsgBoxResult
    Dim Stitch  As Boolean      'True:이미지를 이어 붙이기, False: 이미지 여백 유지
    Dim StartingSlide As Long
   
    Set Pres = ActivePresentation
    If Right(Pres.Name, 5) Like ".pptm" Then
        If MsgBox("모핑전환 사진 슬라이드를 생성하려면" & vbNewLine & _
            "사진앨범 파일(창)을 활성화한 상태에서 실행하세요." & vbNewLine & _
            "현재 파일은 pptm 형식파일입니다." & vbNewLine & vbNewLine & _
            "계속하려면 '확인'을 누르세요.", vbOKCancel + vbExclamation) = vbCancel Then Exit Sub
    End If
    
    usr = MsgBox("1. 이미지를 좌우여백 없이 계속 이어 붙이려면 Yes를," & vbNewLine & _
        "2. 좌우여백을 그대로 유지하려면 No를," & vbNewLine & "3. 취소하려면 Cancel을 누르세요", _
        vbYesNoCancel + vbInformation)
    If usr = vbYes Then Stitch = True Else If usr = vbCancel Then Exit Sub
    
    '슬라이드 크기
    With Pres.PageSetup
        SW = .SlideWidth: SH = .SlideHeight
    End With
    
    If Not Pic(1) Is Nothing Then StartingSlide = 1 Else StartingSlide = 2
    
    '슬라이드 순환
    For Each Sld In Pres.Slides
        
        cur = Sld.SlideIndex
        
        '오른쪽
        If cur < StartingSlide Or Not Stitch Then x = SW _
        Else x = Pic(cur).Left + Pic(cur).Width
        
        If cur < Pres.Slides.Count Then
             For s = cur + 1 To Pres.Slides.Count
                If Not Stitch Then x = x + (SW / 2 - Pic(s).Width / 2)
                copyPicture s, cur, x
                If Stitch Then
                    x = x + Pic(s).Width
                Else
                    x = x + SW
                End If
                If x >= SW * 2 Or Not Stitch Then Exit For
            Next s
        End If
        
        '왼쪽
        If cur = 1 Then '무한 반복일 경우를 대비해서 1슬라이드 왼쪽부분도 처리
            If Stitch And cur = StartingSlide Then x = Pic(cur).Left Else x = 0
            For s = Pres.Slides.Count To 2 Step -1
                If Stitch Then x = x - Pic(s).Width _
                Else x = x - SW + (SW / 2 - Pic(s).Width / 2)
                copyPicture s, cur, x
                If x <= -SW Or Not Stitch Then Exit For
            Next s
        '첫슬라이드는 제외
        ElseIf cur > StartingSlide Then
            If Stitch Then x = Pic(cur).Left Else x = 0
            For s = cur - 1 To 2 Step -1
                If Stitch Then x = x - Pic(s).Width _
                Else x = x - SW + (SW / 2 - Pic(s).Width / 2)
                copyPicture s, cur, x
                If x <= -SW Or Not Stitch Then Exit For
            Next s
        End If
        
        '모핑 전환
        With Sld.SlideShowTransition
            .AdvanceOnTime = msoTrue
            .AdvanceTime = 1    '다음 시간 후
            .Duration = 2       '전환 시간
            .EntryEffect = ppEffectMorphByObject    '3954
            '.Speed = 1
            '.SoundEffect.Name = "bg.mp3"
            Pres.SlideShowSettings.LoopUntilStopped = msoTrue
        End With
        
    Next Sld
    
    If MsgBox("모핑 슬라이드 적용을 완료했습니다. 쇼를 시작할까요?", _
        vbOKCancel + vbInformation) = vbOK Then _
            Pres.SlideShowSettings.Run
End Sub

'사진을 복사
Function copyPicture(sFrom As Long, sTo As Long, xx As Single)

    Dim sldFrom As Slide, sldTo As Slide
    Dim oShp As Shape
    
    If Pres Is Nothing Then Set Pres = ActivePresentation

    Set sldFrom = Pres.Slides(sFrom)
    Set sldTo = Pres.Slides(sTo)
    
    Set oShp = Pic(sFrom)
    oShp.Copy
    DoEvents
    Set oShp = sldTo.Shapes.Paste(1)
    DoEvents
    'oShp.Name = "Temp_" & cur
    oShp.Left = xx
    If oShp.Type = msoGroup Then
        oShp.Top = SH / 2 - oShp.GroupItems(1).Height / 2
    Else
        oShp.Top = SH / 2 - oShp.Height / 2    '세로 가운데
    End If
    
    '사진을 흐리게
    If ImgDarken Then
        If oShp.Type = msoPicture Then
            'oShp.PictureFormat.ColorType = msoPictureGrayscale
            oShp.PictureFormat.Brightness = 0.2
            'With oShp.Fill.PictureEffects
                '.Insert msoEffectBlur  '// Too Slow!
            '    .Item(.Count).EffectParameters(1).Value = 1
            'End With
        ElseIf oShp.Type = msoGroup Then
            If oShp.GroupItems(1).Type = msoPicture Then
                oShp.GroupItems(1).PictureFormat.Brightness = 0.2
                oShp.GroupItems(2).TextFrame.TextRange.Font.Color.RGB = RGB(40, 40, 40)
            End If
        End If
    End If
    
    oShp.Tags.Add "Copied", "True"
 
End Function

'사진 앨범에서
'해당 슬라이드의 첫번째 사진이나 사진이 들어 있는 그룹 개체를 리턴
Function Pic(no As Long) As Shape
    Dim oSld As Slide
    Dim oShp As Shape
    
    If Pres Is Nothing Then Set Pres = ActivePresentation
    Set oSld = Pres.Slides(no)
    
    '첫번째 발견된 사진
    For Each oShp In oSld.Shapes
        If oShp.Type = msoPicture Then
            Set Pic = oShp
            Exit For
        End If
    Next oShp
    
    '그룹으로 묶인 사진인 경우
    If Pic Is Nothing Then
        For Each oShp In oSld.Shapes
            If oShp.Type = msoGroup Then
                If oShp.GroupItems(1).Type = msoPicture Then
                    Set Pic = oShp
                    Exit For
                End If
            End If
        Next oShp
    End If
    
End Function
 
'좌우에 복사된 사진 삭제, 모핑 전환 취소
Sub A2_RemoveCopiedPicsAndTransition()
    
    Dim Sld As Slide
    Dim l As Long
    
    Set Pres = ActivePresentation
    
    If Right(Pres.Name, 5) Like ".pptm" Then
        If MsgBox("복사된 사진을 삭제하고 모핑전환을 취소하려면" & vbNewLine & _
            "사진앨범 파일(창)을 활성화한 상태에서 실행하세요." & vbNewLine & _
            "현재 파일은 pptm 형식파일입니다." & vbNewLine & vbNewLine & _
            "계속하려면 '확인'을 누르세요.", vbOKCancel + vbInformation) = vbCancel Then Exit Sub
    End If
   
    For Each Sld In Pres.Slides
        '복사된 그림 삭제
        For l = Sld.Shapes.Count To 1 Step -1
            If Sld.Shapes(l).Tags("Copied") = "True" Then
                Sld.Shapes(l).Delete
            End If
        Next l
        '모핑 해제
        With Sld.SlideShowTransition
            .AdvanceOnTime = msoFalse
            .EntryEffect = ppEffectNone
            Pres.SlideShowSettings.LoopUntilStopped = msoFalse
        End With
    Next Sld
End Sub

Module2:

Option Explicit
Option Base 1   '배열 시작 1번부터
 
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
            .SlideSize = ppSlideSizeOnScreen16x9
            .SlideOrientation = msoOrientationHorizontal
            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
            
            '그림 추가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
            End With
            
            '라벨 추가
            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
            '애니메이션 추가
            '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
        Set Shp = Module1.Pic(Sld.SlideIndex)
        '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

버전3에서 몇가지 매크로가 추가되었습니다.

1. A1 은 메인 매크로로 모핑슬라이드를 생성합니다.
2. A2는 추가된 좌우 사진들과 모핑전환을 제거해서 초기화합니다.
3. M1은 삽입 > 사진앨범 대신 자체적으로 사진앨범을 만들어줍니다. 
4. M2는 삽입된 사진을 화면에 가득 채웁니다.

(M1을 실행하기 전에 사진을 가득채우려면 미리 hm과 vm 을 0으로 조절해도 됩니다.)

 

 

이어붙여서 슬라이딩하는 예제파일:

사진 앨범3DarkStitch.pptx

13.31MB

이어붙여서 라벨+이미지를 슬라이딩하는 예제:

사진 앨범4LabelDarkStitch.pptx

1.72MB

PhotoAlbum_20231010103519.pptx

1.02MB

매크로 파일(버전3):

MorphSlide3.pptm

0.22MB