What's up guys?
I need to find a way to create a new shape data row in a shape that is inside a container shape. I thought and tryied use a vba code to do it but I didnt find a solution yet. I want that running a macro, the shape data of a shape add a new row called "Sector" for example, and this new row be filled with container shape name, "Sector 1" for example. Is there possible? Is there another way to do it?
Thank you in advance.
I _think_ this is what you are asking for. I wrote this so you could, if you chose, make this a double-click action of the shape using '=CALLTHIS("GetContainerText")' method in the shape's shapesheet. You may choose to remove that message box.
Also note that a shape may be in more than one container.. you would need to decide what you want to do with the data in that case.. (loop over all containers and concatenate them, or something)
Public Sub GetContainerText(pCallingShape As Visio.Shape)
Dim lngShapeIDs() As Long 'This is the list of shape IDs to select
Dim vsoShape As Visio.Shape
Dim containerText As String
Dim pCellName As String: pCellName = "CONTAINER_TEXT"
'Get the list of containers the shape belongs to (an array of ShapeIds)
lngShapeIDs = pCallingShape.MemberOfContainers
'Here, we are just going to grab the first container out of the array, but you may want to cycle through them all..
Set vsoShape = ActivePage.Shapes.ItemFromID(lngShapeIDs(0))
containerText = vsoShape.Text
MsgBox ("My container's text is:" & containerText)
'Put it in a shape data field of the child
'If the Prop section isn't on the shape, then add it
If (Not (pCallingShape.SectionExists(visSectionProp, 1))) Then
pCallingShape.AddSection visSectionProp
End If
'If the shape data element doesnt exist, then add it:
If (Not (pCallingShape.CellExistsU("Prop." & pCellName, Visio.VisExistsFlags.visExistsAnywhere))) Then
pCallingShape.AddNamedRow visSectionProp, pCellName, visTagDefault
'Set the field's label
pCallingShape.CellsSRC(visSectionProp, visRowLast, visCustPropsLabel).Formula = Chr(34) & (pCellName) & Chr(34)
pCallingShape.CellsSRC(visSectionProp, visRowLast, visCustPropsType).FormulaU = visPropTypeString
End If
'Modify Shapedata field and set to the container's text. Dont forget to use CHR( 34 )'s to put it in quotes for a string
If (Len(containerText) > 0) Then
pCallingShape.CellsSRC(visSectionProp, visRowLast, visCustPropsValue).Formula = Chr(34) & (containerText) & Chr(34)
End If
End Sub