Выполнить макрос для всех открытых презентаций

Question

У меня есть следующий код, который я использую для размещения фигуры на первом слайде одной из моих PowerPoints.

Sub WriteToTextBox() 
Dim tb As Shape 
Dim sld As Slide 
Dim pres As Presentation 
Dim var1 As String 


var1 = InputBox("Var1") 
Set pres = ActivePresentation 
Set sld = pres.Slides(1) 'Modify as needed 

Set tb = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 400, 400, 100, 50) 
tb.Name = "InsertShape" 
tb.TextFrame.TextRange.Text = var1 

End Sub 

Я знаю, что хочу выполнить это для всех моих открытых презентаций. Я пытался сделать это вот так:

Sub WriteToTextBoxALL() 

Dim i as integer 
Dim pptcount as integer 

Dim tb As Shape 
Dim sld As Slide 
Dim pres As Presentation 
Dim var1 As String 

For i = 1 to pptcount 

var1 = InputBox("Var1") 
Set pres = ActivePresentation 
Set sld = pres.Slides(1) 'Modify as needed 

Set tb = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 400, 400, 100, 50) 
tb.Name = "InsertShape" 
tb.TextFrame.TextRange.Text = var1 

Next 
End Sub 

Но я получаю сообщение об ошибке. Кто-нибудь вводит то, что я делаю неправильно?

Уважаемые С уважением,

Marc

Answer 1

Вам нужно установить pptcount. Я изменил свой код на этот:

Sub WriteToTextBoxALL() 

    Dim i As Integer 
    Dim pptcount As Integer 

    Dim tb As Shape 
    Dim sld As Slide 
    Dim pres As Presentation 
    Dim var1 As String 

    pptcount = Application.Presentations.Count 

    For i = 1 To pptcount 
     Set pres = Application.Presentations(i) 

     var1 = InputBox("Var1") 
     Set sld = pres.Slides(1) 

     Set tb = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 400, 400, 100, 50) 
     tb.Name = "InsertShape" 
     tb.TextFrame.TextRange.Text = var1 

    Next 
End Sub 

Edit:

Для просто рисунка нормальной границы к вашей форме, добавьте

tb.Line.Visible = True 

---

Explanation to with-statements