How to get delay between letters in PowerPoint application?

Question

I want to export animation as mp4 in PowerPoint and get the timeline of all animation.

How do I get the delay between letters if the effect has EffectInformation.TextUnitEffect as msoAnimTextUnitEffectByCharacter?

Most documentation for PowerPoint I have read, but no message for "%delay between letters".

effectinformation documentation has no message as delay between letters in (https://learn.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://learn.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

The value for "seconds delay between letters" is not directly exposed in the object model.

While it's still possible to extract the value in VBA, the process is quite complicated. At a high level, you need to:

1. Use Presentation.SaveCopyAs to save a copy in "pptx" format, but with the "zip" extension, e.g. temp.zip
2. Use late binding to create a Shell.Application object
3. Use the shell object to copy temp.zip\ppt\slides\slideN.xml to a folder (N = the slide number)
4. Read the XML file and inspect the animation element. The exact value you are looking for ("seconds delay between letters") should be in an element like <p:tmAbs val="50"/>
5. The timing is in ms. So the 50 in the example would be 0.05s in the PowerPoint UI.

Because there could be many animations on the same slide, you may need to find the right animation sequence in the XML. It's definitely not an easy process, and particularly challenging to do in VBA. If possible, I would recommend that you use build a small utility exe file using C# or VB.NET to parse the XML and read the necessary information directly from the PPTX file and invoke the program from VBA. We did something similar for a different purpose, and it worked fairly well.

The first three steps can be used for extracting almost everything not available through the Object Model. For Word, you don't have to do that because it exposes a property WordOpenXML. Unfortunately, such property does not exist in Excel or PowerPoint.