VBA Pulse Animation di PowerPoint 2013 menggunakan Excel 2013

Saya harap saya di SE yang tepat. Posting yang saya temukan mengarahkan saya untuk memposting di sini.

BLUF: Saya mencoba menggunakan pernyataan if / else untuk menerapkan / menghapus animasi pulsa pada objek tertentu di PowerPoint.

Latar Belakang: Kode ini hidup pada dokumen excel karena saya menggunakannya sebagai firewall figuratif dasar sederhana untuk menjaga karyawan dari mengacaukan slide. Saya ingin dokumen pemutakhiran langsung yang mendorong info ke slide PowerPoint yang sedang berjalan dan memperbarui teks ke status status situs tertentu (atas atau bawah). Saya membuat tombol naik / turun sederhana yang hanya mengubah antara UP / DN dalam sel dan memasukkannya ke sel lain untuk menentukan apa yang harus dilakukan dengan data. Kemudian tombol makro menjalankan kode dan memperbarui teks pada PowerPoint.

Berita baik: Semuanya berfungsi dengan baik (selain dari animasi). Teks berubah (kata-kata dan warna) saat PowerPoint berjalan dan mengunci dokumen Excel mencegah karyawan mengacaukan pengaturan apa pun.

Bagian utama dari kode yang dimaksud:

For Each c In Sheet1.Range("a2:a" & Sheet1.Range("a" & Rows.Count).End(xlUp).Row)

shapeslide = Sheet1.Range("a" & c.Row)
shapename = Sheet1.Range("b" & c.Row)
shapetext = (Sheet1.Range("c" & c.Row).Text)
friendlyname = Sheet1.Range("d" & c.Row)
pPreso.Slides(shapeslide).Shapes(shapename).TextEffect.Text = shapetext

If (friendlyname = "DN") Then
pPreso.Slides(shapeslide).Shapes(shapename).TextFrame.TextRange.Font.Color.RGB = RGB(255, 0, 0)

'The porttion below worked, but it is not animation (not as cool)
'pPreso.Slides(shapeslide).Shapes(shapename).TextEffect.PresetTextEffect = 4
'pPreso.Slides(shapeslide).Shapes(shapename).TextEffectFormat = msoAnimEffectBoldFlash

Else
pPreso.Slides(shapeslide).Shapes(shapename).TextFrame.TextRange.Font.Color.RGB = RGB(0, 255, 0)

End If

Next c

Pernyataan for dijalankan melalui sel tempat saya memanggil teks slide, bentuk, dan bentuk tertentu. Nama friendly adalah pengulangan untuk menjalankan IF / Else.

Jika saya mengubah status menjadi DN, berubah menjadi merah, maka jika saya mengubahnya ke UP, itu berubah menjadi hijau.

Saya bisa menerapkan animasi menggunakan kode ini di If / Else:

Dim oeff As Effect
Dim osld As Shape
Set osld = ppapp.ActivePresentation.Slides(shapeslide).Shapes(shapename)
With pPreso.Slides(shapeslide)
Set oeff = .TimeLine.MainSequence.AddEffect(Shape:=.Shapes(shapename),_ effectID:=msoAnimEffectBoldFlash, trigger:=msoAnimTriggerAfterPrevious)
With oeff
.Timing.RepeatDuration = 25
End With
End With

Masalah utama adalah bahwa (dapat dimengerti) itu terus menerapkan animasi, karena jelas tidak ada pemeriksaan untuk melihat apakah diterapkan dalam kode ini. Kedua, ketika saya mencoba memperkenalkan oeff.delete, itu hanya meninggalkan animasi dan kemudian menerapkan non animasi untuk semua orang lain yang ditandai sebagai "UP" di panel animasi PowerPoint.

Jadi, 2 hal:

1. Apakah ada opsi untuk menerapkan animasi pulsa? Saya tidak dapat menemukannya di area perpustakaan msoAnimEffect.

2. Adakah yang memiliki cara yang elegan untuk menghidupkan atau mematikan animasi menggunakan metode yang saya buat ini atau akankah saya perlu mencari cara untuk mengatur bendera, membaca bendera itu, lalu memasukkannya ke dalam pernyataan If / Else?

Berikut ini adalah foto dari Dokumen Excel:

Setelah berunding dengan seorang teman, saya dapat menjalankan beberapa hal, dan menambahkan sedikit bumbu tambahan sendiri.

Berikut adalah kode yang membuat animasi berfungsi:

'Variabel Baru
Redupkan stempel waktu teks
Dim oeff Sebagai PowerPoint.Effect
Dim oshp Sebagai PowerPoint.Shape
Dim osld Sebagai PowerPoint. Geser
'Tambah Efek
Set oshp = pApp.ActivePresentation.Slides (styleslide) .Shapes (shapename)
Dengan pPreso.Slides (styleslide)
Set oeff = .TimeLine.MainSequence.AddEffect (Bentuk: = Bentuk (shapename), effectID: _
= msoAnimEffectFlashBulb, trigger: = msoAnimTriggerWithPrevious)
Dengan oeff
'Berlangsung selama 60 detik slide
.Timing.RepeatDuration = 60
Berakhir dengan
Berakhir dengan

Lalu bagian yang menghilangkan animasi tersebut (terima kasih kepada CM!)

'Hapus Efek
Set osld = pPreso.Slides (styleslide)
“Ke-28 itu hanya karena aku punya 28 animasi lain yang harus tetap
Jika osld.TimeLine.MainSequence.Count> 28 Lalu
Untuk i = osld.TimeLine.MainSequence.Count To 29 Langkah -1
Set oeff = osld.TimeLine.MainSequence (i)
If oeff.Shape.Name Like shapename Then
oeff. Hapus
Berakhir jika
Selanjutnya saya
Berakhir jika

Semoga ini bisa membantu beberapa orang di luar sana.

Sebagai bonus, saya menambahkan stempel waktu ke slide sehingga saya bisa melihat kapan terakhir kali status diperbarui menggunakan kode ini (objeknya adalah kotak teks 28 pada semua slide dan stempel waktu adalah fungsi "SEKARANG ()" di Excel dalam sel H25):

Catatan: ini ada di dalam loop Main For, tetapi di luar main If / Else = "DN"

timestamptext = (Sheet1.Range ("H" & 25) .Text)
pPreso.Slides (styleslide) .Shapes ("Text Box 28"). TextEffect.Text = timestamptext