请教老师们一段代码选中PPT中所有文本框

yjwdjfqb

请教老师们一段代码选中PPT中所有文本框
用VBA选中PPT中每页中的所有文本框
请老师们帮我写段这样的代码，谢谢老师们了!

kevinchengcw

只能同时选中活动页面的文本框，非活动页面的无法选中，就像excel工作表里的对象未激活工作表时也不能选中一样，不过你倒是可以用集合把这些对象装起来，需要的时候直接从集合里调用处理
下面这段会选中活动工作表里有全部文本框

1. Sub test()
   
2. Dim Sld As Slide, Obj As Object, N&, I&
   
3. I = Application.ActiveWindow.View.Slide.SlideNumber
   
4. For Each Sld In ActivePresentation.Slides
   
5.     If Sld.SlideNumber = I Then
   
6.         For Each Obj In Sld.Shapes
   
7.             If Obj.Type = msoTextBox Then
   
8.                 N = N + 1
   
9.                 If N = 1 Then Obj.Select Else Obj.Select False
   
10.             End If
    
11.         Next Obj
    
12.     End If
    
13. Next Sld
    
14. End Sub

复制代码

yjwdjfqb

kevinchengcw 发表于 2019-11-6 19:24
只能同时选中活动页面的文本框，非活动页面的无法选中，就像excel工作表里的对象未激活工作表时也不能选中 ...

老师你好，我在PPT中用这段代码没有成功
老师可否帮我写下，能够一次选中PPT中所有文本框，并将字体颜色调整为黑色、字号15
谢谢了老师!

kevinchengcw

那你不用选择，循环到哪个就设定哪个就行了，这样应该可以操作全部，因为不需要选择

T100

Sub test()
    Dim ptApp, ptPre, n%
    Dim Sld As Slide, Obj As Object
    Application.ScreenUpdating = False
    Set ptApp = CreateObject("PowerPoint.Application")
    Set ptPre = ptApp.Presentations.Open("C:\Users\Administrator\Desktop\演示文稿1.pptx", ReadOnly:=msoFalse)
    ptApp.WindowState = ppWindowMinimized
    For Each Sld In ptPre.Slides
        For Each Obj In Sld.Shapes
            Sld.Select
            If Obj.Type = msoTextBox Then
                Obj.Select
                Obj.TextFrame.TextRange.Font.Size = 15
                Obj.TextFrame.TextRange.Font.Name = "Microsoft YaHei Light"
                Obj.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
            End If
        Next Obj
    Next Sld
    'ptPre.Save      '保存PPT文件
    'ptPre.Close     '关闭PPT文件
    'ptApp.Quit      '退出PPT程序
    Set ptPre = Nothing
    Set ptApp = Nothing
    Application.ScreenUpdating = True '关闭刷新
End Sub

yjwdjfqb

T100 发表于 2019-11-7 12:08
Sub test()
    Dim ptApp, ptPre, n%
    Dim Sld As Slide, Obj As Object

老师你好，才看到老师的代码，谢谢老师了，我是把代码用到当前PPT中，我修改了下，没有成功，请老师帮修改下，谢谢老师了！

T100

yjwdjfqb 发表于 2019-11-21 18:14
老师你好，才看到老师的代码，谢谢老师了，我是把代码用到当前PPT中，我修改了下，没有成功，请老师帮修 ...

Application.ScreenUpdating = False，Application.ScreenUpdating = True删除，再改下面2句定义试试
    Set ptApp = ActiveWindow
    Set ptPre = ActivePresentation

yjwdjfqb

T100 发表于 2019-11-22 17:24
Application.ScreenUpdating = False，Application.ScreenUpdating = True删除，再改下面2句定义试试
   ...

1. Sub test()
   
2.     Dim ptApp, ptPre, n%
   
3.     Dim Sld As Slide, Obj As Object
   
4.    
   
5.     Application.ScreenUpdating = False
   
6.    
   
7. 
   
8. ptApp.WindowState = ppWindowMinimized
   
9.     For Each Sld In ptPre.Slides
   
10.         For Each Obj In Sld.Shapes
    
11.             Sld.Select
    
12.             If Obj.Type = msoTextBox Then
    
13.                 Obj.Select
    
14.                 Obj.TextFrame.TextRange.Font.Size = 15
    
15.                 Obj.TextFrame.TextRange.Font.Name = "Microsoft YaHei Light"
    
16.                 Obj.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
    
17.             End If
    
18.         Next Obj
    
19.     Next Sld
    
20.     'ptPre.Save      '保存PPT文件
    
21.     'ptPre.Close     '关闭PPT文件
    
22.     'ptApp.Quit      '退出PPT程序
    
23.    Set ptApp = ActiveWindow
    
24.     Set ptPre = ActivePresentation
    
25.     Application.ScreenUpdating = True '关闭刷新
    
26. End Sub
    

复制代码

老师你好，提示这样的，什么问题呢！