时间戳

首页 > 解决方案 > 如何在 PowerPoint 应用程序中获得字母之间的延迟？

vba - 如何在 PowerPoint 应用程序中获得字母之间的延迟？

问题描述

我想在 PowerPoint 中将动画导出为 mp4 并获取所有动画的时间线。

如果效果有，我如何获得字母之间的延迟EffectInformation.TextUnitEffect as msoAnimTextUnitEffectByCharacter？

我读过的大多数 PowerPoint 文档，但没有关于“%delay between letters”的消息。

effectinformation文档中没有消息作为字母之间的延迟（https://docs.microsoft.com/en-us/office/vba/api/powerpoint.effectinformation.textuniteffect）

CONST ppLayoutBlank = 12 ''ppt new black slide
CONST ppSaveAsMP4 = 39 ''ppSaveFormat for mp4
CONST ForAppending = 8 ''log file write for appending

const ppViewSlideMaster = 2 ''viewtype
const ppViewHandoutMaster = 4
const ppViewTitleMaster = 8
const ppViewMasterThumbnails = 12

const msoAnimTextUnitEffectByCharacter = 1

Dim filePath
dim logFilePath
dim logFile
dim fullPath

logFilePath = ".\convert.log"     '''''''logfile
 
filePath = SelectFile()

if len(filePath)<1 then
    wscript.quit
end if

MsgBox filePath + ";"

Set ObjFSO = CreateObject("Scripting.FileSystemObject")
Set objPPT = CreateObject("PowerPoint.Application")

objPPT.Visible = True

''create log file
if ObjFSO.fileExists(logFilePath) then
    set logFile = ObjFSO.OpenTextFile(logFilePath, ForAppending)
else
    set logFile = ObjFSO.CreateTextFile(logFilePath)
end if

''do job
pptAnimate(filePath)

''quit or not
''objPPT.Quit()


Function SelectFile()
    dim selectPath,selectPathLen
    Set wShell=CreateObject("WScript.Shell")
    Set oExec=wShell.Exec("mshta.exe ""about:<input type=file id=FILE><script>FILE.click();new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1).WriteLine(FILE.value);close();resizeTo(0,0);</script>""")
    selectPath = oExec.StdOut.ReadAll
    selectPathLen = len(selectPath)
    SelectFile = left(selectPath, selectPathLen-2)'''''remove \r\n, vbcr、vblf
End Function

Sub pptAnimate(pptPath)

    if not (regMatch(pptPath, "\.(ppt|pptx)$")) then
        exit sub
    end if
    
    Set pptInput = objPPT.Presentations.Open(pptPath)
    
    logFile.WriteLine("slide count:" + cstr(pptInput.Slides.Count))
    For i = 1 To pptInput.Slides.Count
        if pptInput.Slides(i).TimeLine.MainSequence.Count > 0 then
        
            Dim tmpPath
            tmpPath = "F:\\word\\" + cstr(i) + ".pptx"
            ObjFSO.CreateTextFile(tmpPath)
            Set pptOutput = objPPT.Presentations.Open(tmpPath)
            Set newSlide = pptOutput.Slides.Add(1, ppLayoutBlank)
            
            pptOutput.PageSetup.slideWidth = pptInput.PageSetup.slideWidth
            pptOutput.pageSetup.slideHeight = pptInput.pagesetup.slideheight
            
            pptInput.Slides(i).Copy
            pptOutput.Slides.Paste (pptOutput.Slides.Count)
                    
            logFile.WriteLine("page:" + cstr(i) + " sequence count:" + cstr(pptInput.Slides(i).TimeLine.MainSequence.Count))
            For Each effect in pptInput.Slides(i).TimeLine.MainSequence
            
                logFile.WriteLine("{delay time:" + cstr(effect.Timing.TriggerDelayTime) _
                + ", duration time:" + cstr(effect.Timing.Duration) _
                + ", Decelerate :" + cstr(effect.Timing.Decelerate) _
                + ", triggerType:" + getTriggerType(effect.Timing.TriggerType) _
                + ", Accelerate:" + cstr(effect.Timing.Accelerate) _
                + ", Decelerate:" + cstr(effect.Timing.Decelerate) _
                + ", Speed:" + cstr(effect.Timing.Speed) _
                + "}")
                
                if msoAnimTextUnitEffectByCharacter = effect.EffectInformation.TextUnitEffect then
                    ''I don't know how to get dealy between letters, have no way to set the effect to by graph
                    ''effect.EffectInformation.TextUnitEffect = 0 '''readonly
                end if
                
                For Each behaviour in effect.Behaviors
                    logFile.WriteLine("behaviour {delay time :" + cstr(behaviour.Timing.TriggerDelayTime) + ", duration time :" + cstr(behaviour.Timing.Duration) +  "}")
                Next
            Next
                        
            m = pptOutput.Slides.Count
            pptOutput.Slides(m).Delete
            
            ''fullPath = "F:\\word\\"+cstr(i)+".mp4"
            ''pptOutput.SaveAs fullPath,ppSaveAsMP4
            '''wait until the mp4 file exist,
            '''msgbox fullPath
            pptOutput.Save
            pptOutput.Close
        end if
    Next    
    
    pptInput.Close
End Sub

Function regMatch(strng,Pattern)  
    Dim regEx  
    Set regEx = New RegExp  
    regEx.Pattern = Pattern  
    regEx.IgnoreCase = True  
    regEx.Global = True  
    regMatch = regEx.test(strng)  
    Set regEx = Nothing  
End Function 

'https://docs.microsoft.com/zh-cn/office/vba/api/powerpoint.msoanimtriggertype
Function getTriggerType(triggerType)
    getTriggerType = ""
    Select Case triggerType
        Case 3
            getTriggerType = "msoAnimTriggerAfterPrevious"
        Case -1
            getTriggerType = "msoAnimTriggerMixed"
        Case 0
            getTriggerType = "msoAnimTriggerNone"
        Case 1
            getTriggerType = "msoAnimTriggerOnPageClick"
        Case 4
            getTriggerType = "msoAnimTriggerOnShapeClick"
        Case 2
            getTriggerType = "msoAnimTriggerWithPrevious"
    End Select
    
End Function

Function Format_Time(s_Time, n_Flag)
    Dim y, m, d, h, mi, s
    Format_Time = ""
    If IsDate(s_Time) = False Then Exit Function
    y = cstr(year(s_Time))
    m = cstr(month(s_Time))
    If len(m) = 1 Then m = "0" & m
    d = cstr(day(s_Time))
    If len(d) = 1 Then d = "0" & d
    h = cstr(hour(s_Time))
    If len(h) = 1 Then h = "0" & h
    mi = cstr(minute(s_Time))
    If len(mi) = 1 Then mi = "0" & mi
    s = cstr(second(s_Time))
    If len(s) = 1 Then s = "0" & s
    Select Case n_Flag
        Case 1
            ' yyyy-mm-dd hh:mm:ss
            Format_Time = y & "-" & m & "-" & d  & " "& h  &":" &  mi  &":" & s
        Case 2
            ' yyyy-mm-dd
            Format_Time = y & "-" & m & "-" & d
        Case 3
            ' hh:mm:ss
            Format_Time = h & ":" & mi & ":" & s
        Case 4
            ' yyyymmdd
            Format_Time = y & m & d
    End Select
End Function

标签： vbapowerpoint

解决方案

“字母之间的秒延迟”的值不直接暴露在对象模型中。

虽然仍然可以在 VBA 中提取值，但过程相当复杂。在高层次上，您需要：

  1. 使用 Presentation.SaveCopyAs 以“pptx”格式保存副本，但带有“zip”扩展名，例如 temp.zip
  2. 使用后期绑定创建Shell.Application对象
  3. 使用外壳对象复制temp.zip\ppt\slides\slideN.xml到文件夹（N=幻灯片编号）
  4. 读取 XML 文件并检查动画元素。您正在寻找的确切值（“字母之间的秒数延迟”）应该在像这样的元素中<p:tmAbs val="50"/>
  5. 时间以毫秒为单位。因此50，示例中的 PowerPoint UI 中的时间为 0.05 秒。

因为同一张幻灯片上可能有很多动画，您可能需要在 XML 中找到正确的动画序列。这绝对不是一个简单的过程，在 VBA 中尤其具有挑战性。如果可能的话，我建议您使用 C# 或 VB.NET 构建一个小型实用程序 exe 文件来解析 XML 并直接从 PPTX 文件中读取必要的信息并从 VBA 调用程序。我们出于不同的目的做了类似的事情，而且效果很好。

前三个步骤可用于提取几乎所有无法通过对象模型获得的内容。对于 Word，您不必这样做，因为它公开了属性 WordOpenXML。不幸的是，Excel 或 PowerPoint 中不存在此类属性。

推荐阅读