파워포인트 VBA로 도트 하트 그리기

 

 
Sub test2()
    Dim shp As Shape
    Dim SW As Single, SH As Single
    Dim i As Integer, j As Integer
    Dim arr As Variant
    Dim sld As Slide
    
    arr = Array(Array(0, 0, 1, 1, 0, 1, 1, 0, 0), _
                Array(0, 1, 0, 0, 1, 0, 0, 1, 0), _
                Array(1, 0, 0, 0, 0, 0, 0, 0, 1), _
                Array(1, 0, 0, 0, 0, 0, 0, 0, 1), _
                Array(1, 0, 0, 0, 0, 0, 0, 0, 1), _
                Array(0, 1, 0, 0, 0, 0, 0, 1, 0), _
                Array(0, 0, 1, 0, 0, 0, 1, 0, 0), _
                Array(0, 0, 0, 1, 0, 1, 0, 0, 0), _
                Array(0, 0, 0, 0, 1, 0, 0, 0, 0))
    
    '하트 그리기
    With ActivePresentation
        SW = .PageSetup.SlideWidth: SH = .PageSetup.SlideHeight
        Set sld = ActiveWindow.Selection.SlideRange(1)
        For i = LBound(arr) To UBound(arr)
            For j = LBound(arr, 1) To UBound(arr, 1)
                If arr(i)(j) = 1 Then
                    Set shp = sld.Shapes.AddShape(msoShapeRoundedRectangle, _
                    SW / 2 - 50 * (UBound(arr, 1) + 1) / 2 + 50 * j, _
                    SH / 2 - 50 * (UBound(arr) + 1) / 2 + 50 * i, 50, 50)
                    
                    With shp
                        .Name = "Dot_" & i & "_" & j
                        .Adjustments(1) = 0.3
                        .TextFrame.TextRange = "♡"
                        .TextFrame.TextRange.Font.Color = rgbWhite
                        .Line.Visible = msoFalse
                        .Select msoFalse
                    End With
                    
                    With sld.TimeLine.MainSequence.AddEffect(shp, msoAnimEffectFade, , msoAnimTriggerAfterPrevious)
                        .Timing.Duration = 0.25
                    End With
                End If
            Next j
        Next i
    End With

End Sub

 

실행 영상:

 

 

샘플파일:

프레젠테이션2.pptm

0.80MB