ppt vba怎样实现excel vba中Application.SendKeys "{TAB}"的功能?

lss001

shenjianrong163 发表于 2020-1-15 22:20
谢谢！运行后有小点问题。

我更改了其中一点，可以运行了。只是运行完成后都要定位到工程模块，可以让 ...

Sub hh()
    Dim pw As Long
    Set ws = CreateObject("wscript.shell")
    pw = "123"
    ws.SendKeys "%LV%TE{tab 9}{end}{tab}V"
    ws.SendKeys "{tab}"
    ws.SendKeys pw
    ws.SendKeys "{tab}"
    ws.SendKeys pw
    ws.SendKeys "{ENTER}"
    ws.SendKeys "%Q"' 关闭工程模块并返回到ppt界面
End Sub

shenjianrong163

lss001 发表于 2020-1-16 02:28
Sub hh()
    Dim pw As Long
    Set ws = CreateObject("wscript.shell")

谢谢！这是给当前的ppt设置密码的，如果想用当前ppt给同时打开的另一个ppt设置密码，有什么办法吗?

lss001

shenjianrong163 发表于 2020-1-16 12:11
谢谢！这是给当前的ppt设置密码的，如果想用当前ppt给同时打开的另一个ppt设置密码，有什么办法吗?

Sub gg()
    With Application.Presentations("演示文稿2.ppt").Windows(1)
        If Not .Active Then '先激活演示文稿2
            Set oldWin = Application.ActiveWindow
            .Activate
        End If
    End With
    Dim pw As Long '再执行密码操作
    Set ws = CreateObject("wscript.shell")
    pw = "123"
    ws.SendKeys "%LV%TE{tab 9}{end}{tab}V"
    ws.SendKeys "{tab}"
    ws.SendKeys pw
    ws.SendKeys "{tab}"
    ws.SendKeys pw
    ws.SendKeys "{ENTER}"
    ws.SendKeys "%Q"
End Sub

shenjianrong163

lss001 发表于 2020-1-16 14:37
Sub gg()
    With Application.Presentations("演示文稿2.ppt").Windows(1)
        If Not .Active T ...

如果是手动打开的ppt可以，但如果是VBA代码打开的就不行，请看看问题出现在哪里?（所有幻灯片的后缀名都是.ppt  并且里面都有模块。）谢谢！
Sub gg(Str)
    With Application.Presentations("Str").Windows(1)
        If Not .Active Then '先激活演示文稿
            Set oldWin = Application.ActiveWindow
            .Activate
        End If
    End With
    Dim pw As Long '再执行密码操作
    Set ws = CreateObject("wscript.shell")
    pw = "123"
    ws.SendKeys "%LV%TE{tab 9}{end}{tab}V"
    ws.SendKeys "{tab}"
    ws.SendKeys pw
    ws.SendKeys "{tab}"
    ws.SendKeys pw
    ws.SendKeys "{ENTER}"
    ws.SendKeys "%Q"
End Sub

Sub pptName()
    Dim f$, p$, d, ppt_name
    Set d = CreateObject("Scripting.Dictionary")
    p = ActivePresentation.Path & "\"
    f = Dir(p & "*.ppt*")
    Do While Len(f)
        If f <> ActivePresentation.Name Then
            d(f) = ""
        End If
        f = Dir
    Loop
    ppt_name = d.keys   '获取所有的ppt文件名
    If (UBound(ppt_name) < 0) Then
        MsgBox "当前目录下没有其它的PPT", 48, "警告"
        Exit Sub
    Else
        For i = 0 To UBound(ppt_name)
                Set pptInput = Presentations.Open(p & "\" & ppt_name(i), ReadOnly:=msoFalse)
                 Call hh(ppt_name(i))   'ppt_name(i)是当前目录下的别的ppt
                  Presentations(p & "\" & ppt_name(i)).Save
                  Presentations(p & "\" & ppt_name(i)).Close
        Next i
    End If
End Sub

lss001

shenjianrong163 发表于 2020-1-16 18:18
如果是手动打开的ppt可以，但如果是VBA代码打开的就不行，请看看问题出现在哪里?（所有幻灯片的后缀名都 ...

Private Declare PtrSafe Sub Sleep Lib"kernel32" (ByVal dwMilliseconds As Long)

Sub pptName()

  Dim f$, p$, d, ppt_name

  Set d = CreateObject("Scripting.Dictionary")

    p= ActivePresentation.Path & "\"

    f= Dir(p & "*.ppt*")

   DoWhile Len(f)

      If f <>ActivePresentation.Name Then d(f) = ""

      f = Dir

  Loop

  ppt_name = d.keys

   If(UBound(ppt_name) < 0) Then

      MsgBox "当前目录下没有其它的PPT", 48, "警告"

      Exit Sub

  Else

      For i = 0 To UBound(ppt_name)

          Set pptInput = Presentations.Open(p & "\" &ppt_name(i), ReadOnly:=msoFalse)

          DoEvents: Sleep 100 '转出控制权！！！

          Call gg(ppt_name(i))

          DoEvents: Sleep 100 '控制权转回！！！

          Presentations(p & "\" & ppt_name(i)).Save

          Presentations(p & "\" & ppt_name(i)).Close

      Next

  End If

End Sub

Sub gg(str)

  Dim pw&

  With Application.Presentations(str).Windows(1)

      If Not .Active Then

          Set oldWin = Application.ActiveWindow

          .Activate

      End If

  End With

  Set ws = CreateObject("wscript.shell")

   pw= "123"

  ws.SendKeys "%LV%TE{tab 9}{end}{tab}V"

  ws.SendKeys "%P" '改为%P

  ws.SendKeys pw

  ws.SendKeys "%C" '改为%C

  ws.SendKeys pw

  ws.SendKeys "~%{F11}" '改为~%{F11}

End Sub

shenjianrong163

lss001 发表于 2020-1-16 20:59
Dir(p & "*.ppt*")‘此处多了星号*
改为 >>>
Dir(p & "*.ppt")

Dir(p & "*.ppt*")     ‘此处的星号*是为了防止出现.pptm的文件，我也输出文件名测试过了，没有影响。
去掉Presentations(p & "\" & ppt_name(i)).Close 不关闭打开的PPT倒是可以，只是相同目录下，除当前PPT外只能再有一个PPT，再多就会出现一个有，另外的没有。而且vba打开的ppt个数是偶数的话，第一个的”查看工程密码“也没有打勾了。

lss001

shenjianrong163 发表于 2020-1-16 23:03
Dir(p & "*.ppt*")     ‘此处的星号*是为了防止出现.pptm的文件，我也输出文件名测试过了，没有影响。
...

见楼上分析，转让控制权！

lss001

shenjianrong163 发表于 2020-1-16 23:03
Dir(p & "*.ppt*")     ‘此处的星号*是为了防止出现.pptm的文件，我也输出文件名测试过了，没有影响。
...

见楼上具体分析,加上延时函数

shenjianrong163

lss001 发表于 2020-1-16 20:59
Private Declare PtrSafe Sub Sleep Lib"kernel32" (ByVal dwMilliseconds As Long) '增加延时函数Sub p ...

谢谢您的耐心回复，仍然不能关闭打开的PPT，否则添加密码就变为给当前的PPT添加了。如果去掉Presentations(p & "\" & ppt_name(i)).Close，那么程序能给打开的PPT添加工程密码，增加延时函数能够解决多个PPT文件了！

shenjianrong163

lss001 发表于 2020-1-16 20:59
Private Declare PtrSafe Sub Sleep Lib"kernel32" (ByVal dwMilliseconds As Long) '增加延时函数Sub p ...

我在主程序结束时才依次关闭打开的PPT，发现每次都要弹出一个工程属性窗口，于是我稍加修改，问题终于解决了。只是感觉关闭PPT的代码与前面的部分重复了，不简洁。
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub pptName()
   Dim f$, p$, d, ppt_name
   Set d = CreateObject("Scripting.Dictionary")
    p = ActivePresentation.Path & "\"
    f = Dir(p & "*.ppt*") '可不做修改
   Do While Len(f)
       If f <> ActivePresentation.Name Then d(f) = ""
       f = Dir
   Loop
   ppt_name = d.keys
   If (UBound(ppt_name) < 0) Then
       MsgBox "当前目录下没有其它的PPT", 48, "警告"
       Exit Sub
   Else
       For i = 0 To UBound(ppt_name)
           Set pptInput = Presentations.Open(p & "\" & ppt_name(i), ReadOnly:=msoFalse)
           DoEvents: Sleep 100 '转出控制权！！！
           Call gg(ppt_name(i)) '是gg不是hh
           Presentations(p & "\" & ppt_name(i)).Save
           DoEvents: Sleep 100 '控制权转回！！！
       Next
   End If
   If (UBound(ppt_name) > 0) Then ‘判断是否有打开的文件
       For i = 0 To UBound(ppt_name)
           Presentations(p & "\" & ppt_name(i)).Close
       Next
   End If
End Sub
Sub gg(str)
   Dim pw&
   With Application.Presentations(str).Windows(1) '注意str不可加冒号
       If Not .Active Then
           Set oldWin = Application.ActiveWindow
           .Activate
       End If
   End With
   Set ws = CreateObject("wscript.shell")
   pw = "123"
    Application.VBE.CommandBars(1).Controls("工具(T)").Controls("VBAProject 属性(&E)...").Execute
    ws.SendKeys "^{tab}"  '切换到密码页  Ctrl+tab
    ws.SendKeys "^v"      '勾选查看工程密码 Ctrl+V
    ws.SendKeys "{tab}"   '换到输入密码
    ws.SendKeys pw        '输入密码
    ws.SendKeys "{tab}"   '跳到下一个
    ws.SendKeys pw        '输入密码
    ws.SendKeys "{ENTER}" '确定
    ws.SendKeys "{Esc}"   'Esc取消工程属性窗口
    ws.SendKeys "^s"      '保存 Ctrl+S
End Sub