I took this code directly from the VBA documentation from Microsoft, I am trying to select a shape then iterate through outgoing connected shapes.
Public Sub ConnectedShapes_Outgoing_Example()
' Get the shapes that are connected to the selected shape
' by outgoing connectors.
Dim vsoShape As Visio.Shape
Dim lngShapeIDs() As Long
Dim intCount As Integer
If ActiveWindow.Selection.Count = 0 Then
MsgBox ("Please select a shape that has connections")
Exit Sub
Else
Set vsoShape = ActiveWindow.Selection(1)
End If
lngShapeIDs = vsoShape.ConnectedShapes _
(visConnectedShapesOutgoingNodes, "")
Debug.Print "Shapes at the end of outgoing connectors:"
For intCount = 0 To UBound(lngShapeIDs)
Debug.Print ActivePage.Shapes(lngShapeIDs(intCount)).Name
Next
End Sub
lngShapeIDs array gives me one item with an ID of 1077.
Then this:
Debug.Print ActivePage.Shapes(lngShapeIDs(intCount)).Name
...gives me an "Invalid Sheet Identifier" error, as if the ID doesn't exist.
The Shapes collection takes an index rather than an ID.
You need Shapes.ItemFromId
Related
I'm trying to duplicate selected slides multiple times in the same presentation. Could someone please advise where I am going wrong? Thank you
Public Sub DuplicateSlideMultipleTimes()
Dim n As Integer
On Error Resume Next
n = InputBox("How many copies of the selected slides do you want to make?")
Dim mySlides As Slides
Set mySlides = ActiveWindow.Selection.SlideRange
If n >= 1 Then
For numtimes = 1 To n
mySlides.Copy After:=ActivePresentation.Slides(ActivePresentation.Slides.Count)
Next
End If
End Sub
Here's another approach. Instead of looping through each of the selected slides to make a duplicate, it simply copies and pastes. It also places them at the end of the presentation.
Note that mySlides has been appropriately declared as a SlideRange, as Ricardo has already pointed out.
Also note that On Error Resume Next has been removed, since it can hide errors when not used properly, as Ricardo has also pointed out.
Option Explicit
Public Sub DuplicateSlideMultipleTimes()
Dim ans As String
Dim num_copies As Long
num_copies = 0
Do
ans = InputBox("How many copies of the selected slides do you want to make?")
If Len(ans) = 0 Then Exit Sub
If IsNumeric(ans) Then
num_copies = CLng(ans)
If num_copies > 1 Then Exit Do
End If
MsgBox "Invalid entry, try again!", vbExclamation
Loop
Dim mySlides As SlideRange
Set mySlides = ActiveWindow.Selection.SlideRange
Dim i As Long
For i = 1 To num_copies
mySlides.Copy
ActivePresentation.Slides.Paste
Next i
MsgBox "Completed!", vbExclamation
End Sub
You were close.
Some highlights:
Avoid On Error Resume Next whenever possible (this will just hide where you have errors)
Declare all your variables (use Option Explicit at the top of your modules)
You have some variables types wrong
Review code's comments and adjust it to fit your needs
Code:
Option Explicit
Public Sub DuplicateSlideMultipleTimes()
Dim sourceSlide As Slide
Dim selectedSlides As SlideRange
Dim numTimes As Variant
Dim counter As Long
Dim totalCounter As Long
' Ask user for num slides
numTimes = InputBox("How many copies of the selected slides do you want to make?")
' Check if numTimes is a number otherwise, exit procedure
If Not IsNumeric(numTimes) Then Exit Sub
' Set a reference to the selected slides
Set selectedSlides = ActiveWindow.Selection.SlideRange
' Loop through each slide in the selected slides
For Each sourceSlide In selectedSlides
For counter = 1 To numTimes
' Duplicate the slide
sourceSlide.Duplicate
' Track total number of duplicated slides
totalCounter = totalCounter + 1
Next counter
Next sourceSlide
' Display message to user
MsgBox totalCounter & " duplicates generated"
End Sub
Let me know if it works
I have a shape in an Excel sheet, and I have to add/remove hyperlink to it as a part of my code. How can we check if the shape contains a hyperlink? Something like the below code:
if shape.hyperlink.exists is True then
shape.hyperlink.delete
end if
Public Sub TestMe()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
On Error Resume Next
sh.Hyperlink.Delete
On Error GoTo 0
Next sh
End Sub
The idea is to delete the hyperlink of every shape. If the shape does not have one, it is quite ok, the code continues. In this solution, the hyperlink is declared as a variable - How do I refer to a shape's hyperlinks using Excel VBA - as a workaround something similar can be used.
It is possible to loop over all the hyperlinks on a sheet and determine whether those hyperlinks are in cells or in Shapes (this avoids using OnError):
Sub HyperActive()
Dim h As Hyperlink, n As Long
If ActiveSheet.Hyperlinks.Count = 0 Then
MsgBox "no hyperlinks"
Exit Sub
End If
For Each h In ActiveSheet.Hyperlinks
n = h.Type
If n = 0 Then
MsgBox "in cell: " & h.Parent.Address
ElseIf n = 1 Then
MsgBox "in shape: " & h.Shape.Name
End If
Next h
End Sub
To check if a Shape has a Hyperlink, call this function (instead of the 'shape.hyperlink.exists') in your post:
Public Function HasHyperlink(shpTarget As Shape) As Boolean
Dim hLink As Hyperlink: Set hLink = Nothing
On Error Resume Next: Set hLink = shpTarget.Hyperlink: On Error GoTo 0
HasHyperlink = Not (hLink Is Nothing)
End Function
I want to create a VBA macro in PPT to Group shapes in same height across multiple rows in Powerpoint using VBA. My initial step would be ideally like this image:
Group Textboxes row wise
There is a matrix of textboxes in many rows and columns evenly distributed vertically & horizontally. I want to select all the shapes altogether and run a macro to group the textboxes row wise, into multiple rows. Code below is copied and not final yet, Appreciate any help, snippets for this, thanks a lot.
Sub GroupSameHeightObjects()
' Dimension the variables.
Dim shapeObject As shape
Dim lSlideNumber As Long
Dim strPrompt, strTitle As String
Dim ShapeList() As String
Dim count As Long
' Initialize the counter.
count = 0
' Make sure PowerPoint is in slide view.
If ActiveWindow.ViewType <> ppViewSlide Then
' Set up the error message.
strPrompt = "You must be in slide view to run this macro." _
& " Change to slide view and run the macro again."
strTitle = "Not In Slide View"
' Display the error message.
MsgBox strPrompt, vbExclamation, strTitle
' Stop the macro.
End
End If
' Get the current slide number.
lSlideNumber = ActiveWindow.Selection.SlideRange.SlideNumber
' Loop through the shapes on the slide.
For Each shapeObject In _
ActivePresentation.Slides(lSlideNumber).Shapes
' See whether shape is a placeholder.
If shapeObject.Type <> msoPlaceholder Then
' Increment count if the shape is not a placeholder.
count = count + 1
' Get the name of the shape and store it in the ShapeList
' array.
ReDim Preserve ShapeList(1 To count)
ShapeList(count) = shapeObject.Name
End If
Next shapeObject
' If more than 1 object (excluding a placeholder object) is found,
' group the objects.
If count > 1 Then
With ActivePresentation.Slides(lSlideNumber).Shapes
' Group the shapes together.
.Range(ShapeList()).Group.Select
End With
Else
Select Case count
' One shape found.
Case 1
' Set up the message.
strPrompt = "Only one shape found." _
& " You need at least two shapes to group."
strTitle = "One Shape Available"
' Zero shapes found.
Case 0
' Set up the message.
strPrompt = "No shapes found. You need to have at " _
& "least two shapes, excluding placeholders."
strTitle = "No Shapes Available"
' An error occurred.
Case Else
' Set up the message.
strPrompt = "The macro found an error it could not correct."
strTitle = "Error"
End Select
' Display the message.
MsgBox strPrompt, vbExclamation, strTitle
End If
End Sub
I don't have time right now to write/test any code, but if I had to do this, I'd start with something like this snippet I had from another project:
Sub GroupCertainShapes()
Dim x As Long
Dim sTemp As String
Dim aShapeList() As String
Dim lShapeCount As Long
With ActivePresentation.Slides(1)
' iterate through all shapes on the slide
' to get a count of shapes that meet our condition
For x = 1 To .Shapes.Count
' Does the shape meet our condition? count it.
If .Shapes(x).Type = msoAutoShape Then
lShapeCount = lShapeCount + 1
End If
Next
' now we know how many elements to include in our array,
' so redim it:
ReDim aShapeList(1 To lShapeCount)
' Reset the shape counter
lShapeCount = 0
' Now add the shapes that meet our condition
' to the array:
For x = 1 To .Shapes.Count
' apply some criterion for including the shape or not
If .Shapes(x).Type = msoAutoShape Then
lShapeCount = lShapeCount + 1
aShapeList(lShapeCount) = .Shapes(x).Name
End If
Next
' and finally form a group from the shapes in the array:
If UBound(aShapeList) > 0 Then
.Shapes.Range(aShapeList).Group
End If
End With
End Sub
A couple of things that may not give you fully what you're after but that'll save you some trouble down the line:
Sub GroupSameHeightObjects()
' Dimension the variables.
Dim shapeObject As shape
Dim lSlideNumber As Long
' This will dim strPrompt as a variant
' Dim strPrompt, strTitle As String
Dim strPrompt as string, strTitle as string
Dim ShapeList() As String
Dim count As Long
' Initialize the counter.
count = 0
' Make sure PowerPoint is in slide view.
If ActiveWindow.ViewType <> ppViewSlide Then
' Set up the error message.
strPrompt = "You must be in slide view to run this macro." _
& " Change to slide view and run the macro again."
strTitle = "Not In Slide View"
' Display the error message.
MsgBox strPrompt, vbExclamation, strTitle
' Stop the macro.
' See previous comment
'End
Exit Sub
End If
' Get the current slide number.
' Nope, you want the SlideIndex; SlideNumber gives you the number that'll
' appear when you use PPT's slide numbering features; if the user sets the
' starting number to something other than 1, your code will break
'lSlideNumber = ActiveWindow.Selection.SlideRange.SlideNumber
lSlideNumber = ActiveWindow.Selection.SlideRange.SlideIndex
' Loop through the shapes on the slide.
For Each shapeObject In _
ActivePresentation.Slides(lSlideNumber).Shapes
' See whether shape is a placeholder.
If shapeObject.Type <> msoPlaceholder Then
' Increment count if the shape is not a placeholder.
count = count + 1
' Get the name of the shape and store it in the ShapeList
' array.
' I've learned not to trust shape names in PPT
' I'd dim ShapeList as an array of shapes and then
' Set ShapeList(count) = shapeObject
ReDim Preserve ShapeList(1 To count)
ShapeList(count) = shapeObject.Name
End If
Next shapeObject
' You could include this next bit in the following Case selector,
' Case > 1 ... etc.
' If more than 1 object (excluding a placeholder object) is found,
' group the objects.
If count > 1 Then
With ActivePresentation.Slides(lSlideNumber).Shapes
' Group the shapes together.
.Range(ShapeList()).Group.Select
End With
Else
Select Case count
' One shape found.
Case 1
' Set up the message.
strPrompt = "Only one shape found." _
& " You need at least two shapes to group."
strTitle = "One Shape Available"
' Zero shapes found.
Case 0
' Set up the message.
strPrompt = "No shapes found. You need to have at " _
& "least two shapes, excluding placeholders."
strTitle = "No Shapes Available"
' An error occurred.
Case Else
' Set up the message.
strPrompt = "The macro found an error it could not correct."
strTitle = "Error"
End Select
' Display the message.
MsgBox strPrompt, vbExclamation, strTitle
End If
End Sub
I am attempting to write a vba loop that will detect the value of all ActiveX textboxes on the slide. However I am have trouble writing the code for the "variable" in the textbox reference. For example TextBox(i) needs to be referenced in the loop. Where i is an integer I set the value to.
Dim i as Integer
For i = 1 to 4
If IsNull(Slide1.Shapes.("TextBox" & i).Value) = True
Then (Slide1.Shapes.("TextBox" & i).Value) = 0
Else: ...
Next i
However this script doesn't work and I have been unable to locate a source for how to properly code this variable portion of script. There has been some talk of using Me.Controls however I am not creating a form. Would anyone be willing to share what the error is here in my script?
This will put the value of i into TextBox i. Should get you started, I think.
Sub Example()
Dim oSh As Shape
Dim i As Integer
On Error Resume Next
For i = 1 To 4
Set oSh = ActivePresentation.Slides(1).Shapes("TextBox" & CStr(i))
If Err.Number = 0 Then ' shape exists
oSh.OLEFormat.Object.Text = CStr(i)
End If
Next i
End Sub
#Steve Rindsberg you had the correct code. Thank you. Here was the final script to obtain the value, and set the value if blank.
For i = 1 To 4
'set oSh to TextBox1, TextBox2, TextBox3... etc.
Set oSh = ActivePresentation.Slides(1).Shapes("TextBox" & CStr(i))
'set myVar to value of this TextBox1, TextBox2...
myVar = oSh.OLEFormat.Object.Value
If myVar = "" Then _
ActivePresentation.Slides(1).Shapes("Text" & CStr(i)).OLEFormat.Object.Value = 0 _
Else: 'do nothing
'clear value of myVar
myVar = ""
'start on next integer of i
Next i
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