PowerPoint (VBA?) Исчезающий текст - PullRequest
Новая
       11

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

3 голосов
/ 14 февраля 2011

Попытка моего первого перехода на 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

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

Skyhawk

Ответы [ 2 ]

3 голосов
/ 14 февраля 2011

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

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

0 голосов
/ 16 августа 2017

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

Поэтому я рекомендую вам использовать обычное текстовое поле и анимацию и разрешить макросу копировать текстовое поле и анимацию.1004 * Я сделал для вас пример файла 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 ()'

...