What I'm trying to do here is give all the shapes in the worksheet a number.
The number must be counted up by one for each shape
So it should look something like this.
Keep in mind that these shapes are dynamic (it isn't always 2 columns, 3 rows)
This is the code i tried, but doesn't seem to work
Sub Nummer()
Dim lngShapes As Long
lngShapes = ActiveSheet.Shapes.Count
For teller = 1 To lngShapes
ActiveSheet.Shapes(teller).Value = teller
Next
End Sub
It seems like the question is actually "Loop through all of the shapes in a sheet". Something like the following should be used:
Sub nameTheShapes()
Dim shp As Shape
For Each shp In Sheet1.Shapes
shp.TextFrame2.TextRange.Characters.Text = shp.ID
Next
End Sub
Here we declare a shape as variable name shp. Then we loop through all of the shapes in the sheet1. Then we write the shape's id into the shape's textframe2.
If you have some charts hanging out on the same page, then you probably don't want to include them, so you can test the shp.type property to see that it's not a chart:
Sub nameTheShapes()
Dim shp As Shape
For Each shp In Sheet1.Shapes
If shp.type = 1 Then
shp.TextFrame2.TextRange.Characters.Text = shp.ID
End If
Next
End Sub
You get Error 438 when trying to set the value (text) within the shape because the shapes collection does not have a Value property to set. You need to use .TextFrame.Characters.Text
If you change the line
ActiveSheet.Shapes(teller).Value = teller
to
ActiveSheet.Shapes(teller).TextFrame.Characters.Text = teller
your code will work.
Related
Suppose I have the below, in which for every selected shape another one will be created:
For Each Shp In ActiveWindow.Selection.ShapeRange'.GroupItems
as you can see, at the end of the line objects within groups are commented out. Would it be possible to tell VBA to uncomment it, if for example a ListBox gives the option to apply the macro for grouped items? This would not be out of laziness, rather to save lines and possibly reduce the file size. And just to understand more how everything works. Or VBA is intrinsically blind to comments?
Here's a simple example of handling shapes whether within groups or not:
Sub Main()
Dim oSh As Shape
For Each oSh In ActivePresentation.Slides(1).Shapes
Call HandleShape(oSh)
Next
End Sub
Sub HandleShape(oSh As Shape)
Dim x As Long
If oSh.Type = msoGroup Then
For x = 1 To oSh.GroupItems.Count
Call HandleShape(oSh.GroupItems(x))
Next
Else
oSh.Fill.ForeColor.RGB = RGB(255, 0, 0)
End If
End Sub
I've written some code that formats text. The code doesn't work if user has put the cursor in a shape that is part of a group of shapes, the solution for which is to ungroup the shapes.
I want to regroup the shapes after executing the formatting code.
I am able to store the underlying shapes as objects, as well as their names. But, the normal approach to grouping (using shape names) doesn't work, because there can be multiple instances of those shape names on a given slide. E.g. this doesn't work as there could be multiple instances of "textbox" on the slide:
Set TempShapeGroup = TempSlide.Shapes.Range(Array("textbox", "header", "separator")).Group
https://learn.microsoft.com/en-us/office/vba/api/powerpoint.shaperange.group
But, I have the shape objects stored in an array, the crux of which is this (the object 'TempShape' is the group of shapes):
Dim ShapesArray() As Shape
ReDim ShapesArray(1 To TempShape.GroupItems.Count)
For i = 1 To TempShape.GroupItems.Count
Set ShapesArray(i) = TempShape.GroupItems.Item(i)
Next i
So, what I want to do is recreate the group of shapes, using the array of shape objects, so something to the effect of the below would be ideal:
Set MyShapesGroup= ShapesArray.Group
But any way to group shapes using Shape objects would be fine.
TIA
Here's some starter code that you can modify into a function that'll return a reference to the paragraph that contains the current selection cursor. It doesn't really need all the debug.print stuff, of course, but that might help to illustrate the object hierarchy:
Sub WhereIsTheCursor()
Dim oRng As TextRange
Dim oParentRange As TextRange
Dim x As Long
Dim lSelStart As Long
Dim lSelLen As Long
With ActiveWindow.Selection.TextRange
' find the selection start relative to first character in shape
lSelStart = .Start
' lSelLen = .Length
Debug.Print TypeName(.Parent)
Debug.Print TypeName(.Parent.Parent)
Debug.Print TypeName(.Parent.Parent.Parent)
Debug.Print .Paragraphs.Count
Set oRng = .Characters(.Start, .Length)
Debug.Print oRng.Text
' Reference the overall shape's textrange
Set oParentRange = .Parent.Parent.TextFrame.TextRange
' For each paragraph in the range ...
For x = 1 To oParentRange.Paragraphs.Count
' is the start of the selection > the start of the paragraph?
If lSelStart > oParentRange.Paragraphs(x).Start Then
' is the start < the start + length of the paragraph?
If lSelStart < oParentRange.Paragraphs(x).Start _
+ oParentRange.Paragraphs(x).Length Then
' bingo!
MsgBox "The cursor is in paragraph " & CStr(x)
End If
End If
Next
End With
End Sub
Not sure I'm completely understanding the problem, but this may help:
If the user has selected text within a shape, it doesn't really matter whether the shape is part of a group or not. You may need to test the .Selection.Type and handle things differently depending on whether the .Type is text or shaperange. Example:
Sub FormatCurrentText()
If ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange
.Font.Name = "Algerian"
End With
End If
End Sub
I want to highlight the shape corresponding to a particular group. The following code is only highlighting shapes that are grouped with active page or master but not with the group present in the active page.
Sub CA_Trace_Conflict1()
PCC_CA = InputBox("Enter PCC Band")
'SCC1_CA = InputBox("Enter SCC1 Band")
Dim shp As Visio.Shape
Dim subshp As Visio.Shape
Dim connectorshape As Visio.Shape
Dim BandLinewidth As String
Dim lngShapeIDs() As Long
Dim count As Integer
Dim PCC_Flag As Integer
Dim SCC1_Flag As Integer
PCC_Flag = 0
SCC1_Flag = 0
Dim DiagramServices As Integer
DiagramServices = ActiveDocument.DiagramServicesEnabled
ActiveDocument.DiagramServicesEnabled = visServiceVersion140 + visServiceVersion150
Dim UndoScopeID1 As Long
PCC_CA_space = PCC_CA & " "
For Each shp In Visio.ActivePage.shapes
If shp.Type = 2 Then 'Check if shp is a group
For Each subshp In shp.shapes
If InStr(shp.Text, PCC_CA_space) > 0 Then
'If PCC_CA Like shp.Text Then
Set connectorshape = shp
Debug.Print shp.Parent
Application.ActiveWindow.Page.shapes.ItemFromID(shp.ID).CellsSRC(visSectionObject,visRowLine, visLineWeight).FormulaU = "5.5 pt"
' Debug.Print shp.ID
End If
Next
End If
Next
End Sub
I think you want to select a subshape within a group programmatically. Doing this in Visio is not obvious, so let me help. I'll put links to two articles on my website, plus one on Microsoft's at the end of the post. These discuss selection-related topics in further detail.
So let's tackle your problem...
Setup
Open a blank drawing in Visio
Draw two rectangles, then group them
You now have three shapes on this page.
Sheet.1 is a subshape
Sheet.2 is a subshape
Sheet.3 is the group
You can programmatically select the group like this, as you've discovered:
Public Sub SelectGroup()
'// Get the active window:
Dim win As Visio.Window
Set win = Visio.ActiveWindow
'// Deselect everything:
Call win.DeselectAll
'// Get a shape object:
Dim shp As Visio.Shape
Set shp = Visio.ActivePage.Shapes.ItemFromID(3) '<<----- Sheet.3 is the group!
'// Cause that shape to be selected in the window:
Call win.Select(shp, Visio.VisSelectArgs.visSelect)
'// Cleanup:
Set shp = Nothing
Set win = Nothing
End Sub
By the way, the Sub above is much more nitpicky and long than it has to be. But it will help to have things simple and clean, when you start adding features and behaviors. You can actually one-line the whole procedure like this--you can even paste this into the Immediate window:
Call Visio.ActiveWindow.Select(Visio.ActivePage.Shapes.ItemFromID(3), Visio.VisSelectArgs.visDeselectAll + Visio.VisSelectArgs.visSelect)
Now to subselect Sheet.1 or Sheet.2. One would think we could simply change the shp object to be one of the subshapes, ala:
'// Sheet.1 is a subshape, you'll get an error
Set shp = Visio.ActivePage.Shapes.ItemFromID(1) '<<----- ID = 1
but this won't work. In fact you'll get an "Inappropriate target object for this action" error.
To fix this, we have to pass a different argument to the Select method:
Public Sub SelectSubshape()
'// We've drawn two rectangles on a blank page, then
'// grouped them. Sheet.1 and Sheet.2 are subshapes,
'// Sheet.3 is the group.
'// Get the active window:
Dim win As Visio.Window
Set win = Visio.ActiveWindow
'// Deselect everything:
Call win.DeselectAll
'// Get a subshape object:
Dim shp As Visio.Shape
Set shp = Visio.ActivePage.Shapes.ItemFromID(2)
'// Cause that shape to be SUBSELECTED in the window.
'// Note the different argument: visSubSelect
Call win.Select(shp, Visio.VisSelectArgs.visSubSelect) ' <<------ visSubSelect!
'// Cleanup:
Set shp = Nothing
Set win = Nothing
End Sub
Voila! Subshape selected in the active window!
If you want to detect which shapes are already selected, then you'll have to fiddle with the IterationMode property of a Selection object. This is pretty confusing, plus I don't think you're asking for that right now. But knowing the term will help you search for help in the future, should you need it.
Articles
Getting a Handle on Selecting and Subselecting Visio Shapes
Detect Sub-selected Shapes Programmatically
Selection.Select method (Visio)
I'm writing a script in VBA to change the Title's of the slide to the section title. I have multiple sections and I want to iterate though the ppt to change all the titles of the slides to have the same section title as its section.
I've tried finding how to grab the section title and set it to the slide's title.
Sub test()
ActivePresentation.Slides.Name = ActivePresentation.SectionProperties(sectionName)
End Sub
I need to add iteration, I need i believe syntax is messed.
Hopefully something like the following is what you're looking for. The code
Loops through each slide in the ActivePresentation, adding a title if there isn't already one.
Changes the title text by getting the sectionIndex property of the slide, and then using that index in the SectionProperties.Name method to retrieve the corresponding text.
Sub ChangeMyTitles()
Dim sld As Slide
Dim titleShape As Shape
If ActivePresentation.SectionProperties.Count = 0 Then Exit Sub
For Each sld In ActivePresentation.Slides
With sld
If Not .Shapes.HasTitle Then
Set titleShape = .Shapes.AddTitle
Else
Set titleShape = .Shapes.Title
End If
titleShape.TextFrame2.TextRange.Text = ActivePresentation.SectionProperties.Name(.sectionIndex)
End With
Next sld
End Sub
EDIT:
If you want to modify a different placeholder than the title, you could do something like this. Based on your screenshot, I assume that the placeholder you want to modify is the 3rd one (title is 1st, body is 2nd, and chapter is 3rd), but you might have to change the 3 below.
Sub ChangeMyChapters()
Dim sld As Slide
Dim chapterShape As Shape
If ActivePresentation.SectionProperties.Count = 0 Then Exit Sub
For Each sld In ActivePresentation.Slides
With sld
Set chapterShape = .Shapes.Placeholders(3)
chapterShape.TextFrame2.TextRange.Text = ActivePresentation.SectionProperties.Name(.sectionIndex)
End With
Next sld
End Sub
I have a library of eight images on my PowerPoint slide. Based on a userform input, some of the components get duplicated and renamed by adding a "1" or "2" after the original image's name so that they are differentiable. I then want to group the new images (I am building up an item from the component images). I am able to duplicate the images and line them up correctly, but I am having trouble grouping them. Note that I am not always grouping the same number of items, it is dependent on user inputs.
I receive the error "Shape (unknown member): Invalid request. To select a shape, its view must be active."
I searched and attempted to implement several strategies from the help forums but am coming up empty.
PLEASE HELP!!!
-Kevin
Part of code below because it is very long, but this is where my first problem arises:
Dim Cargo As Shape, Cargo_Dup as Shape, Chemical as Shape, Chemical_Dup as Shape
Set Cargo = ActivePresentation.Slides(2).Shapes("Cargo")
Set Chemical = ActivePresentation.Slides(2).Shapes("Chemical")
Cargo.Name = "Cargo"
Chemical.Name = "Chemical"
With ActivePresentation
Set Cargo_Dup = ActivePresentation.Slides(2).Shapes("Cargo")
With Cargo_Dup.Duplicate
.Name = "Cargo_1st"
.Left = 0
.Top = 540
End With
'CHEMICAL
If Input1 = "Chemical" Then
Set Chemical_Dup = ActivePresentation.Slides(2).Shapes("Chemical")
With Chemical_Dup.Duplicate
.Name = "Chemical" & 1
.Left = 36.74352
.Top = 540 + 0.36
End With
'''''WHERE PROBLEM ARISES'''''
ActivePresentation.Slides(2).Shapes("Cargo_1st").Select
ActivePresentation.Slides(2).Shapes("Chemical1").Select msoFalse
Set Vehicle = ActiveWindow.Selection.ShapeRange.Group
Vehicle.Name = "Vehicle"
'Elseif with a bunch for options where addition grouping occurs
I need some kind of keyboard macro to type this for me:
Never select anything unless you absolutely have to.
You nearly never absolutely have to.
You're asking how to make a view active so that you can select something.
I figure that's the wrong question.
It's more useful to know how to work with shapes WITHOUT having to select them.
Grouping shapes w/o selecting them is a bit tricky, but it can be done.
Here's an example of how you might go about this:
Sub GroupWithoutSelecting()
Dim oSl As Slide
Dim oSh As Shape
Dim aShapes() As String
Set oSl = ActivePresentation.Slides(2) ' or whichever slide you like
ReDim aShapes(1 To 1)
With oSl
For Each oSh In .Shapes
If oSh.Type <> msoPlaceholder Then ' can't group placeholders
' Substitute the real condition you want to use
' for selecting shapes to be grouped here
If oSh.Type = msoAutoShape Then
' add it to the array
aShapes(UBound(aShapes)) = oSh.Name
ReDim Preserve aShapes(1 To UBound(aShapes) + 1)
End If
End If
Next
' eliminate the last (empty) element in the array
ReDim Preserve aShapes(1 To UBound(aShapes) - 1)
' Create a shaperange from the array members and group the shaperange
.Shapes.Range(aShapes).Group
End With ' oSl
End Sub