My Word document has many ActiveX labels. [Not textboxes: my original title was in error.]
I'd like a macro to loop through them to perform an action on each of them (changing the captions), but I don't know how to identify them.
If they were on a userform, I'd say:
For each aLabel in UserForm1.Controls
But that doesn't apply in my case.
Assuming it is textboxes you're working with, per the title but not the question, the document's Shapes collection may be what you're after:
Sub ShapeLoop()
Dim shp As Shape
For Each shp In ThisDocument.Shapes
' Test if shp is one you're interesed in, perhaps using shp.Name
Debug.Print shp.Name
' Do Stuff
Next shp
End Sub
Edit:
Same again for the fields collection
Sub FieldLoop()
Dim fld As Field
For Each fld In ThisDocument.Fields
If TypeName(fld.OLEFormat.Object) = "Label" Then
Debug.Print fld.OLEFormat.Object.Caption
fld.OLEFormat.Object.Caption = "New Caption"
End If
Next
End Sub
Related
I have a powerpoint slide with about 3000 slides. On each slide I have a one picture and a text box. In powerpoint the picture has a specific name attached to it in the selection pane while the text box is named "TextBox 3". Each text box contains the text "2013-09-27 16.27.54". My job is to go through each text box and replace that text with name of the picture in the selection pane. I have written the following code to do this however I am having trouble setting the name of the picture as a string. When I run this code I get "Compile error: Invalid qualifier" on line 10, and Name is highlighted in line 10
How do I get rid of this error? I am assuming it is because the name of the object is not being recognized as a string.
My code is as follows:
Sub Hello()
For Each sld In Application.ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
Set txtRng = shp.TextFrame.TextRange
Set foundText = txtRng.Find(FindWhat:="2013-09-27 16.27.54")
Do While Not (foundText Is Nothing)
With foundText
.Replace(FindWhat:=foundText, _
Replacewhat:=Application.ActivePresentation.Slides(i).Shapes(1).Name.TextRange.TextFrame, WholeWords:=True) = True
End With
Loop
End If
End If
Next
Next
End Sub
Find and Replace is unnecessarily complex. Find the picture, get its name, find the text box, replace the text:
Sub Hello()
Dim sld As Slide
Dim shp As Shape
Dim PicName As String
For Each sld In Application.ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoPicture Then
PicName = shp.Name
End If
Next
For Each shp In sld.Shapes
If shp.HasTextFrame Then
shp.TextFrame.TextRange.Text = PicName
End If
Next
Next
End Sub
I would like to select "Rectangle 132" in each slide, copy the content into the "outline menu" as a title for the slide using VBA.
Ultimately it would be nice to locate the "title" rubric above the actual slide, so it is not displayed on the slide.
Sub LoopThroughSlides()
'PURPOSE: Show how to loop through all slides in the active presentation
Dim sld As Slide
'Loop Through Each Slide in ActivePresentation
For Each sld In ActivePresentation.Slides
'Do something...(ie add a transition to slides)
Function getShapeByName(shapeName As String, Slide As Integer)
Set getShapeByName = ActivePresentation.Slides(Slide).Shapes(shapeName)
End Function
Dim myshape As Shape
myshape = getShapeByName("Rectangle 132", 1)
Next sld
End Function
End Sub
••••ˇˇˇˇ
I've found this but unsure how to apply it:
With ActivePresentation.Slides(1)
If .Layout <> ppLayoutBlank Then
With .Shapes
If Not .HasTitle Then
.AddTitle.TextFrame.TextRange.Text = "Restored title"
End If
End With
End If
End With
Sorry, but titles don't work that way. The Title placeholder has a special status in the program that can't be transferred to other shapes. If you copy the text from Rectangle 132 and paste it to the Title placeholder, it will work as expected.
As an illustration of the special nature of the placeholder, I created a slide using the Blank layout, which has no Title. I opened Outline View, then typed text beside the slide thumbnail. This text is automatically considered the slide title and PowerPoint creates a Title placeholder on the blank slide, even though it didn't previously have one.
When you change your question, please consider starting a new thread, rather than tacking it on to the previous one. Give this VBA a try:
Sub SetTitle()
Dim sld As Slide, oShape As Shape, TitleText As String, TitlePHName As String
For Each sld In ActivePresentation.Slides
For Each oShape In sld.Shapes
If oShape.Name = "Rectangle 132" Then
If oShape.HasTextFrame Then
If oShape.TextFrame2.HasText Then
TitleText = oShape.TextFrame2.TextRange.Text
End If
End If
End If
If Left(oShape.Name, 5) = "Title" Then
TitlePHName = oShape.Name
End If
Next oShape
If sld.Layout <> ppLayoutBlank Then
If sld.Shapes.HasTitle Then
sld.Shapes(TitlePHName).TextFrame2.TextRange.Text = TitleText
Else
sld.Shapes.AddTitle.TextFrame2.TextRange.Text = TitleText
End If
End If
TitlePHName = ""
TitleText = ""
Next sld
End Sub
I have big shapes on my worksheet (a group of shapes), and inside everyone of them others little shapes (the blue rectangles),
I made a for loop for inside each Big shape to fill automatically the little shapes, but how can I loop over the Big ones, because all the big shapes are similars, and they have the same names for the littles shapes inside ?
How can I acces the little shape from the big one ?
I tried this but didn't worked
ActiveSheet.Shapes.Range(gr).Select
ActiveSheet.Shapes.Range(Array(x)).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Format(Range(y_1).Value, "#,##0") & " k" & Chr(13) & Format(Range(y_2).Value, "#,##0.00") & " DT"
The "gr" variable takes every time the name of the big shapes (Graph_1 .. Graph_5)
and the x variable takes the name of the little shapes inside (rect_1 .. rect_21)
I think this code does not help because my approach it's like how to access a case in an array if I can say ?
For Each myshape In ActiveSheet.Shapes
You can access child shapes inside a group by using following example:
Sub test()
Dim shp As Shape
Dim shpChild As Shape
For Each shp In Sheet1.Shapes
If shp.Type = msoGroup Then
'/ Found a group. List all the child shapes here.
For Each shpChild In shp.GroupItems
Debug.Print "Child name :" & shpChild.Name & " Group name : " & shp.Name
Next
Else
'/ No group. Individual shape.
Debug.Print shp.Name
End If
Next
End Sub
Here... you should have figured it out yourself :)
Sub test()
Dim shp As Shape
Dim shpChild As Shape
For Each shp In Sheet1.Shapes
If shp.Type = msoGroup And shp.Name = "A" Then
'/ Found a group called "A". List all the child shapes here.
For Each shpChild In shp.GroupItems
If shpChild.Name = "X" Then
'/ Found X.
shpChild.TextFrame2.TextRange.Text = "Hello from VBA!!!"
End If
Next
Else
'/ No group. Individual shape.
Debug.Print shp.Name
End If
Next
End Sub
In VBA for Microsoft Word, I am trying writing a subroutine that will search through all shapes on a document, find the ones that are textboxes, and will move them to a newly created document by means of cut-and-paste.
My problem is that the sub will only move the first textbox it finds to a new doc. If I run it again it will move the next one, etc. Is there a way that I can select multiple textboxes, similar to the Shift-Left_Click ability that exists in the normal word document? I will post my code below:
Option Explicit
Public shp As Shape
Public Count As Integer
Public OldDoc As String
Public NewDoc As String
Sub BringTextBoxesToDoc()
Dim Count As Integer
Dim i As Integer
Count = 0
OldDoc = ActiveDocument.Name
Documents.Add
ActiveDocument.ActiveWindow.Caption = "Comment Textboxes"
NewDoc = ActiveDocument.Name
Documents(OldDoc).Activate
For Each shp In ActiveDocument.Shapes
If shp.Type = msoTextBox Then
Count = Count + 1
shp.Name = "Textbox" & Count
shp.Select
With Selection
.Cut
End With
Documents(NewDoc).Activate
Selection.Paste
End If
Next shp
End Sub
I have several PowerPoints with a great deal of text in the notes. I need to search the note text and delete any paragraphs that start with "A."
Here is what I tried - but am getting type mismatch error
Dim curSlide As Slide
Dim curNotes As Shape
Dim x As Long
For Each curSlide In ActivePresentation.Slides
Set curNotes = curSlide.NotesPage.Shapes(2).TextFrame.TextRange
With curNotes.TextFrame.TextRange
For x = 1 To Len(curNotes.TextFrame.TextRange)
If Mid(curNotes.TextFrame.TextRange, x, 2) = "A." Then
curNotes.TextFrame.TextRange.Paragraphs = ""
End If
Next x
End With
Next curSlide
End Sub
Thanks for your help!!
You get a mismatch error whenever you try to assign data of a different type specified by your variable. This is happening in your code because you defined curNotes as type Shape and then tried to set that object variable to a different data type, TextRange. You are then trying to process the object TextRange as a string. You need to work on the .Text child of .TextRange The use of Mid is not checking the start of the string and finally, when you set the text to "", you are deleting all the text in the Note but that's not what you said you're trying to do.
This is the corrected code to delete only paragraphs starting with "A."
' PowerPoint VBA macro to delete all slide note paragraphs starting with the string "A."
' Rewritten by Jamie Garroch of youpresent.co.uk
Option Explicit
Sub DeleteNoteParagraphsStartingA()
Dim curSlide As Slide
Dim curNotes As TextRange
Dim iPara As Long
For Each curSlide In ActivePresentation.Slides
Set curNotes = curSlide.NotesPage.Shapes(2).TextFrame.TextRange
With curNotes
' Count backwards in any collection when deleting items from it
For iPara = .Paragraphs.Count To 1 Step -1
If Left(.Paragraphs(iPara), 2) = "A." Then
.Paragraphs(iPara).Delete
Debug.Print "Paragraph " & iPara & " deleted from notes pane on slide " & curSlide.SlideIndex
End If
Next
End With
Next curSlide
End Sub