insertVideos.pptm

Sub InsertAudioAndSetSlideTime()

' 遍历文件夹中的文件，为了获取权限
Dim fileName0 As String
fileName0 = Dir(ActivePresentation.Path & "*.mp3")

' 这替换为你的音频文件夹路径
Dim baseFilePath As String
baseFilePath = "/Users/june/Work/ppt2video"

' 使用VBA读取文本文件
Dim textLines() As String, myFile As Integer
Dim timeFilePath As String
myFile = FreeFile()
timeFilePath = baseFilePath & "/times.txt"
Open timeFilePath For Input As myFile
textLines = Split(Input$(LOF(myFile), myFile), vbLf)
Close myFile


' 插入音频
Dim sld As Slide
Dim audioFile As String
For Each sld In ActivePresentation.Slides

  audioFile = baseFilePath & "/video_" & sld.SlideNumber & ".wav"
  sld.Shapes.AddMediaObject2 audioFile, msoFalse, msoTrue

  Dim shp As Shape
  Set shp = sld.Shapes(sld.Shapes.Count)
  shp.AnimationSettings.PlaySettings.HideWhileNotPlaying = msoTrue
  shp.AnimationSettings.PlaySettings.PlayOnEntry = True
  ' 设置音频对象的位置
  shp.Top = 0  ' 设置垂直位置为 0 磅
  shp.Left = -70 ' 设置为负数便于导出ppt时不显示音频对象


  ' 设置时长
  If IsNumeric(textLines(sld.SlideIndex - 1)) Then
    sld.SlideShowTransition.AdvanceTime = CLng(textLines(sld.SlideIndex - 1))
  Else
    MsgBox "行号" & sld.SlideIndex & "包含非数字"
  End If

   ' 设置切换类型为自动换片
   sld.SlideShowTransition.EntryEffect = ppEffectCut
   sld.SlideShowTransition.AdvanceOnTime = msoTrue


Next sld

End Sub