CÁCH TẠO MACRO TỰ ĐỘNG RANDOM ĐỐI TƯỢNG POWER POINT

Macro dưới đây sẽ:

• Duyệt từng slide
• Lọc shape là Picture (ảnh)
• Xóa animation cũ (nếu có) của các ảnh (để tránh chồng hiệu ứng)
• Gán Entrance ngẫu nhiên cho mỗi ảnh (Fade / Fly In / Zoom / Wipe / Float In…)
• Thiết lập chạy After Previous để ảnh xuất hiện lần lượt tự động
• Có delay ngẫu nhiên nhẹ để nhìn “tự nhiên” hơn

Option Explicit

'========================

' Random Animations for Pictures

'========================

Public Sub RandomEntranceForAllPictures()

    Dim pres As Presentation

    Dim sld As Slide

    Dim pics() As Shape

    Dim n As Long

    Randomize 'seed once

    Set pres = ActivePresentation

    For Each sld In pres.Slides

        n = CollectPictures(sld, pics)

        If n > 0 Then

            ClearPictureAnimations sld, pics, n

            ShuffleShapes pics, n

            ApplyRandomEntrance sld, pics, n

        End If

    Next sld

    MsgBox "Đã random animation Entrance cho tất cả hình ảnh trong bài.", vbInformation

End Sub

'--- Collect picture shapes on a slide

Private Function CollectPictures(ByVal sld As Slide, ByRef pics() As Shape) As Long

    Dim shp As Shape

    Dim i As Long

    i = 0

    For Each shp In sld.Shapes

        If IsPictureShape(shp) Then

            i = i + 1

            ReDim Preserve pics(1 To i)

            Set pics(i) = shp

        End If

    Next shp

    CollectPictures = i

End Function

Private Function IsPictureShape(ByVal shp As Shape) As Boolean

    On Error GoTo SafeOut

    IsPictureShape = (shp.Type = msoPicture Or shp.Type = msoLinkedPicture)

    Exit Function

SafeOut:

    IsPictureShape = False

End Function

'--- Remove animations that target the picture shapes (MainSequence)

Private Sub ClearPictureAnimations(ByVal sld As Slide, ByRef pics() As Shape, ByVal n As Long)

    Dim seq As Sequence

    Dim i As Long, j As Long

    Dim eff As Effect

    Set seq = sld.TimeLine.MainSequence

    ' Walk backwards when deleting

    For i = seq.Count To 1 Step -1

        Set eff = seq(i)

        If Not eff.Shape Is Nothing Then

            For j = 1 To n

                If eff.Shape.Id = pics(j).Id Then

                    seq(i).Delete

                    Exit For

                End If

            Next j

        End If

    Next i

End Sub

'--- Shuffle array of shapes (Fisher–Yates)

Private Sub ShuffleShapes(ByRef arr() As Shape, ByVal n As Long)

    Dim i As Long, j As Long

    Dim tmp As Shape

    For i = n To 2 Step -1

        j = Int(Rnd() * i) + 1

        Set tmp = arr(i)

        Set arr(i) = arr(j)

        Set arr(j) = tmp

    Next i

End Sub

'--- Apply random entrance effect and timing

Private Sub ApplyRandomEntrance(ByVal sld As Slide, ByRef pics() As Shape, ByVal n As Long)

    Dim seq As Sequence

    Dim i As Long

    Dim eff As Effect

    Dim animType As MsoAnimEffect

    Set seq = sld.TimeLine.MainSequence

    For i = 1 To n

        animType = PickRandomEntrance()

        Set eff = seq.AddEffect(Shape:=pics(i), _

                                effectId:=animType, _

                                trigger:=msoAnimTriggerAfterPrevious)

        ' Timing tweaks (feel free to adjust)

        eff.Timing.Duration = 0.6 + Rnd() * 0.4   '0.6–1.0s

        eff.Timing.TriggerDelayTime = Rnd() * 0.4 '0–0.4s

    Next i

End Sub

'--- Choose from a safe set of Entrance animations

Private Function PickRandomEntrance() As MsoAnimEffect

    Dim pool As Variant

    pool = Array( _

        msoAnimEffectFade, _

        msoAnimEffectFly, _

        msoAnimEffectFloat, _

        msoAnimEffectZoom, _

        msoAnimEffectWipe, _

        msoAnimEffectPeek, _

        msoAnimEffectRiseUp _

    )

    PickRandomEntrance = pool(Int(Rnd() * (UBound(pool) - LBound(pool) + 1)) + LBound(pool))

End Function

//////////////////////

Option Explicit

'========================

' Random Animations for Pictures

'========================

Public Sub RandomEntranceForAllPictures()

    Dim pres As Presentation

    Dim sld As Slide

    Dim pics() As Shape

    Dim n As Long

    Randomize 'seed once

    Set pres = ActivePresentation

    For Each sld In pres.Slides

        n = CollectPictures(sld, pics)

        If n > 0 Then

            ClearPictureAnimations sld, pics, n

            ShuffleShapes pics, n

            ApplyRandomEntrance sld, pics, n

        End If

    Next sld

    MsgBox "Đã random animation Entrance cho tất cả hình ảnh trong bài.", vbInformation

End Sub

'--- Collect picture shapes on a slide

Private Function CollectPictures(ByVal sld As Slide, ByRef pics() As Shape) As Long

    Dim shp As Shape

    Dim i As Long

    i = 0

    For Each shp In sld.Shapes

        If IsPictureShape(shp) Then

            i = i + 1

            ReDim Preserve pics(1 To i)

            Set pics(i) = shp

        End If

    Next shp

    CollectPictures = i

End Function

Private Function IsPictureShape(ByVal shp As Shape) As Boolean

    On Error GoTo SafeOut

    IsPictureShape = (shp.Type = msoPicture Or shp.Type = msoLinkedPicture)

    Exit Function

SafeOut:

    IsPictureShape = False

End Function

'--- Remove animations that target the picture shapes (MainSequence)

Private Sub ClearPictureAnimations(ByVal sld As Slide, ByRef pics() As Shape, ByVal n As Long)

    Dim seq As Sequence

    Dim i As Long, j As Long

    Dim eff As Effect

    Set seq = sld.TimeLine.MainSequence

    ' Walk backwards when deleting

    For i = seq.Count To 1 Step -1

        Set eff = seq(i)

        If Not eff.Shape Is Nothing Then

            For j = 1 To n

                If eff.Shape.Id = pics(j).Id Then

                    seq(i).Delete

                    Exit For

                End If

            Next j

        End If

    Next i

End Sub

'--- Shuffle array of shapes (Fisher–Yates)

Private Sub ShuffleShapes(ByRef arr() As Shape, ByVal n As Long)

    Dim i As Long, j As Long

    Dim tmp As Shape

    For i = n To 2 Step -1

        j = Int(Rnd() * i) + 1

        Set tmp = arr(i)

        Set arr(i) = arr(j)

        Set arr(j) = tmp

    Next i

End Sub

'--- Apply random entrance effect and timing

Private Sub ApplyRandomEntrance(ByVal sld As Slide, ByRef pics() As Shape, ByVal n As Long)

    Dim seq As Sequence

    Dim i As Long

    Dim eff As Effect

    Dim animType As MsoAnimEffect

    Set seq = sld.TimeLine.MainSequence

    For i = 1 To n

        animType = PickRandomEntrance()

        Set eff = seq.AddEffect(Shape:=pics(i), _

                                effectId:=animType, _

                                trigger:=msoAnimTriggerAfterPrevious)

        ' Timing tweaks (feel free to adjust)

        eff.Timing.Duration = 0.6 + Rnd() * 0.4   '0.6–1.0s

        eff.Timing.TriggerDelayTime = Rnd() * 0.4 '0–0.4s

    Next i

End Sub

'--- Choose from a safe set of Entrance animations

Private Function PickRandomEntrance() As MsoAnimEffect

    Dim pool As Variant

    pool = Array( _

        msoAnimEffectFade, _

        msoAnimEffectFly, _

        msoAnimEffectFloat, _

        msoAnimEffectZoom, _

        msoAnimEffectWipe, _

        msoAnimEffectPeek, _

        msoAnimEffectRiseUp _

    )

    PickRandomEntrance = pool(Int(Rnd() * (UBound(pool) - LBound(pool) + 1)) + LBound(pool))

End Function

////////////////

Cách chạy macro (2 phút là xong)

1. Mở PowerPoint → File → Options → Customize Ribbon → bật Developer
2. Vào tab Developer → Visual Basic
3. Insert → Module → dán code ở trên
4. Chạy: Developer → Macros → RandomEntranceForAllPictures → Run
5. Lưu file: nếu muốn giữ macro → .pptm (PowerPoint Macro-Enabled)

Nếu máy bạn đang chặn macro, bạn cần bật “Enable Content” khi mở file .pptm (tùy chính sách máy).

Bạn muốn “tự chạy” hay “bấm từng ảnh mới hiện”?

Macro trên đang để After Previous (tự chạy lần lượt).
Nếu bạn muốn On Click (mỗi click hiện 1 ảnh) thì đổi dòng:

VisualBasic

trigger:=msoAnimTriggerAfterPrevious

Hiện thị thêm dòng

thành:

VisualBasic

trigger:=msoAnimTriggerOnPageClick

Hiện thị thêm dòng

Gợi ý tối ưu cho bài của bạn (nhiều ảnh)

• Giữ pool hiệu ứng “an toàn” như trên (Fade/Fly/Zoom/Wipe…) để không bị “lố”
• Duration 0.6–1.0s là vừa mắt
• Delay ngẫu nhiên nhỏ giúp cảm giác tự nhiên

Nếu bạn thích, mình có thể viết thêm 1 macro nút bấm “Shuffle lại animation của slide hiện tại” (mỗi lần bấm ra hiệu ứng & thứ tự khác) — đúng kiểu “random thật mỗi lần trình chiếu”, vẫn dựa trên VBA (PowerPoint không có sẵn).

Để bạn thử cho “mượt” ngay, mình gửi vài mẹo nhỏ (đỡ gặp lỗi vặt):

1) Nhớ lưu đúng định dạng

• Nếu muốn giữ macro: lưu thành .pptm (PowerPoint Macro‑Enabled).
• Nếu chỉ cần áp hiệu ứng xong rồi thôi: chạy macro xong có thể lưu lại .pptx (nhưng macro sẽ không còn trong file).

2) Nếu chạy mà không thấy hiệu ứng khi trình chiếu

Vào Slide Show → Set Up Slide Show xem có lỡ bật “Show without animation” không (nếu bật thì mọi animation bị tắt).

3) Nếu PowerPoint chặn macro

Thường PowerPoint sẽ hiện thanh vàng “Enable Content”. Bạn bấm Enable để chạy macro.

4) Muốn nhìn “đẹp” hơn (ít “lố”)

Trong macro mình đã chọn nhóm hiệu ứng khá “an toàn” (Fade/Fly/Zoom/Wipe…), tránh mấy hiệu ứng gây rối mắt. Nếu bạn muốn mình chỉnh theo phong cách:

• Nhẹ nhàng: chỉ Fade + Zoom
• Sôi động: thêm Fly/Float
  mình có thể đưa phiên bản macro “tối giản” hoặc “sôi động” luôn.

Võ Nhật Trường Chat My AI