修改程序，自选图形设置跳转动作无果

dollar

我个人觉得，pptVBA相对于ExcelVBA不仅功能少，更重要的是很不成熟。

laoyingxin

已经成功移植到我的模板当中，谢谢你。

tigergroup

还有个问题要请教你。
目的：机动插入当前路径里面的音视频
问题：有时弹出下标越界，有时是对象的问题。我对dir函数理解和运用不熟。估计出问题的地方是红字的部分。
本应该上传附件，可是音视频的体积大，无法直接上传，暂时又没有闲暇编辑音视频，所以直接给了代码，如若一定要附件，我稍后再上传。烦请大侠帮我一看。谢谢你。
代码如下：
Sub 插入音视频()
h = ActivePresentation.PageSetup.SlideHeight / 2
w = ActivePresentation.PageSetup.SlideWidth / 2
l = w / 4 + 10
t = h / 2
s1 = ".wmv.mp4.flv.avi.f4v"
s2 = ".mp3.wav"
s3 = ".wmv.mp4.flv.avi.f4v.mp3.wav"
s = IIf(SlideMaster.CommandButton10.Caption = "视", s1, s2)
mypath = ActivePresentation.Path & ""
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
mn = Dir(mypath & "*.*")
  Do While mn <> &quot;&quot;
    If InStrRev(s3, Split(mns, &quot;.&quot;)(1), 1) > 0 Then
       If InStrRev(s1, Split(mns, &quot;.&quot;)(1), 1) > 0 Then
         d1(mypath & mn) = &quot;&quot;
       Else
         d2(mypath & mn) = &quot;&quot;
       End If
    mn = Dir   
End If
  Loop
    k1 = d1.keys
    k2 = d1.keys
  Randomize
   filnm1 = k1(Int(Rnd * d1.Count) + 1)
   filnm2 = k2(Int(Rnd * d2.Count) + 1)
If s = &quot;视&quot; Then
      For Each shp In ActivePresentation.SlideShowWindow.View.Slide.Shapes
          If shp.Type = 16 Then shp.Delete
      Next
      Set shp = Nothing
      
      Set sld = ActivePresentation.SlideShowWindow.View.Slide
      Set shps = sld.Shapes
      Set sp = shps.AddMediaObject2(FileName:=filnm1, Left:=l, Top:=t, Width:=w, Height:=h)
      With sp
               .AutoShapeType = Choose(Int(Rnd * 9) + 1, 6, 9, 10, 132, 13, 28, 94, 95, 96)
          With .ThreeD
             If sj Mod 2 = 1 Then
               .SetThreeDFormat msoThreeD & (Int(Rnd * 20) + 1)
             Else
               .BevelTopType = 3
               .BevelTopDepth = 10
               .BevelBottomType = 3
               .BevelBottomDepth = 6
             End If
          End With
          With ActivePresentation.SlideShowWindow.View.Slide
              .TimeLine.InteractiveSequences(1).Item(1).Delete
              .TimeLine.MainSequence.AddEffect sp, msoAnimEffectMediaPlay, , msoAnimTriggerWithPrevious
          End With
          Set seq = sld.TimeLine.MainSequence
          s = seq.Count
          seq(s).MoveBefore seq(1)
       End With
       Set sp = Nothing
   
    Else
       For Each shp In ActivePresentation.SlideShowWindow.View.Slide.Shapes '插入音频
          If shp.Type = 16 Then shp.Delete
       Next
       Set shp = Nothing
       Set sp = shps.AddMediaObject2(FileName:=filnm2, Left:=0, Top:=ActivePresentation.PageSetup.SlideHeight + 10)
       With sp
       With ActivePresentation.SlideShowWindow.View.Slide
              .TimeLine.InteractiveSequences(1).Item(1).Delete
              .TimeLine.MainSequence.AddEffect sp, msoAnimEffectMediaPlay, , msoAnimTriggerWithPrevious
          End With
          Set seq = sld.TimeLine.MainSequence
          s = seq.Count
          seq(s).MoveBefore seq(1)
       End With
       Set sp = Nothing
End If
End Sub

weiweix

在此请教，渴求教我。
批量设置按钮跳转未果：
两个要求
1、点击那个按钮跳转到与其数字相应的幻灯片。
2、跳转前按钮变色
问题
1、只跳转到第四张幻灯片，代码肯定有问题。
2、不能变色，代码不知怎样写。
附件如下：
按按钮数字对应跳转并变色.zip (69.73 KB, 下载次数: 39)

2017-2-13 12:02 上传

点击文件名下载附件

danny_hao

什么是机动？你的意思是搜索当前路径下的所有音频文件，然后随机插入一个音频文件么？

violetice

很高兴您的回复，希望我的附件您能查阅，仔细阅读，以前的回复暂且不管，看看这次的难题能否给予解决，谢谢您了，谢谢！！

aliub88

上次的问题已经完全解决，这次的问题，希望给予答复，谢谢你了！！

skybirdcao

谢谢你的多次回复和指教，
首先，对过去一年你的无私帮助表示感谢，
祝愿你新的一年万事如意，
预祝你新年快乐。
你问的那个问题，已经解决。
这次的内容是批量设置跳钮，
烦请你看看14楼的附件。
谢谢了。