PowerPoint (VBA?) Исчезающий текст

Question

Попытка моего первого перехода на VBA в рамках PPT, немного проделанная в Excel раньше... но мне нужна помощь по поводу того, куда идти с этим...

У меня есть список из ста или около того строк, которые я хочу постепенно увеличивать и уменьшать на одном и том же слайде после примерно 3 или нескольких секунд отображения 1 за раз. И продолжать делать это до тех пор, пока пользователь не остановится, т.е. CTRL + break. У меня пока немного кодирования, но я не уверен, куда идти...

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Test()
'Start the presentation
ActivePresentation.SlideShowSettings.Run

'Change the value of the text box to String1 and fade in the text
ActivePresentation.Slides(1).Shapes(1).TextFrame.TextRange.Text = "String1"

DoEvents

'Wait 2 secounds, fade out the Hello! Sting

Sleep 2000

'Fade in the new string.. String2!
 ActivePresentation.Slides(1).Shapes(1).TextFrame.TextRange.Text = "String2"

DoEvents

'A Loop to keep going back and forth between the 2 (there will be many more later....
'Until stoped by the user [CTRL + BREAK]

End Sub

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub Test()
'Start the presentation
ActivePresentation.SlideShowSettings.Run

'Change the value of the text box to String1 and fade in the text
ActivePresentation.Slides(1).Shapes(1).TextFrame.TextRange.Text = "String1"

DoEvents
'Wait 2 secounds, fade out the Hello! Sting

Sleep 2000

'Fade in the new string.. String2!
ActivePresentation.Slides(1).Shapes(1).TextFrame.TextRange.Text = "String2"

DoEvents

'A Loop to keep going back and forth between the 2 (there will be many more later....
'Until stoped by the user [CTRL + BREAK]

End Sub

Я действительно ценю любую помощь, которую форум / люди могут предоставить.. спасибо!!

штурмовик типа "Скайхки"

Answer 1

Вы должны использовать обычную анимацию вместо VBA.

Создайте два одинаковых текстовых поля с разными текстами, затем добавьте и затемните другой.

Answer 2

К сожалению, команда Sleep API не заставит макрос действительно уснуть. Даже в "Спящем" макрос будет работать и появится следующая анимация. VBA не процедура в режиме реального времени. (Чтобы избежать этого ограничения, вы можете использовать Timer API, но это другая история.)

Поэтому я рекомендую вам использовать обычное текстовое поле и анимацию и позволить макросу скопировать текстовое поле и анимацию.

Я сделал образец файла PPT(M) для вас

https://drive.google.com/file/d/0ByoPCwQXKo0HVGhZOVJvYkJwak0/view

Откройте его и включите функцию макроса. Это не повредит тебе. Клавиша Alt-F11 покажет вам источник.

На этом слайде я добавил текстовое поле "модель" на слайде 2. Это текстовое поле будет скопировано на слайд 3, включая эффект анимации. Хорошо, что вы можете изменить шрифт, размер, цвет, эффект анимации или что угодно. VBA также может добавить эффект на фигуру, но это требует слишком много усилий.

На первом слайде нажмите кнопку "Добавить", и он начнет показ. Кнопка "Удалить" удаляет все добавленные предложения, которые были добавлены ранее.

Option Base 1
Const MAX = 10

Sub Add()
    Dim shp As Shape
    Dim str() As String
    Dim i As Integer

    'First, remove sentences that were added before
    Remove

    ' Initialize str() array
    ReDim str(MAX)
    For i = 1 To MAX
        str(i) = "This is the sentence #" & i
    Next i

    'Let's copy the textbox on Slide #2 onto Slide #3
    Set shp = ActivePresentation.Slides(2).Shapes("TextBox 1")
    shp.Copy
    For i = 1 To UBound(str)
        With ActivePresentation.Slides(3).Shapes.Paste
            .Left = shp.Left
            .Top = shp.Top
            .TextFrame.TextRange.Text = str(i)
            .Name = "TextBox " & i
        End With
    Next i

    'Message
    MsgBox "Total " & i - 1 & " sentence(s) has(have) been added."

    'go to the Slide #3
    SlideShowWindows(1).View.GotoSlide 3
End Sub


Sub Remove()
    Dim i As Integer, cnt As Integer

    With ActivePresentation.Slides(3)
        'When deleting, be sure to delete shapes from the top. Otherwise, some shapes might survive
        For i = .Shapes.Count To 1 Step -1
            If Left(.Shapes(i).Name, 8) = "TextBox " Then
                .Shapes(i).Delete
                cnt = cnt + 1
            End If
        Next i
    End With

    If cnt > 0 Then MsgBox "Total " & cnt & " sentence(s) has(have) been removed."
End Sub

Все, что вам нужно сделать, это создать собственный массив 'str()'