Question

我想用vb脚本在PowerPoint中将动画导出为mp4，并获取所有动画的时间轴，但是如果效果具有EffectInformation.TextUnitEffect作为msoAnimTextUnitEffectByCharacter，我不知道如何在字母之间延迟。我已经阅读了Powerpoint的大多数文档，但没有“字母之间的％dealy”消息，任何人都可以帮助！

效果信息文档没有（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

Answer 1

对象模型中没有直接显示“字母之间的秒数延迟”的值。

尽管仍然可以在VBA中提取值，但过程非常复杂。在较高级别，您需要：

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

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

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

如何以编程方式在Powerpoint.Application中的字母之间进行交易

1 个答案: