I want to highlight connectors of a Shape object, but it doesn't give me any LineStyle properties for the connector itself. Here's what I got so far:
For i = 0 To UBound(lngShapeIDs)
Dim shp As Shape
Dim connect As connect
Set shp = ActivePage.Shapes.ItemFromID(lngShapeIDs(i))
shp.LineStyle = "Guide"
shp.BringToFront
Set connect = shp.FromConnects.Item(i + 1)
Next
Based in your comments this is what I think you are looking for
Dim shape As shape
For Each shape In ActivePage.Shapes
If (shape.OneD <> 0) Then
shape.CellsU("LineColor").Formula = "rgb(255,0,0)"
shape.BringToFront
End If
Next
This sample enumerates through all the shapes in the page. It assumes and "1-D" shapes are connectors that need to be modified. For those connectors, their line color is set to red and they are each brought to the front.
So if this was the initial state of the drawing:
Then after running the VBA code, the drawing will look like this:
Related
After selecting a shape (f.e. square or more squares) all the connectors glued to this shape would highlight red, yellow whatever.
The found code below is not working for me, any advice? (I am not coder, so please have patience with me)
Set shpAtEnd = cnx(1).ToSheet
' use HitTest to determine whether Begin end of connector
' is outside shpAtEnd
x = shpAtEnd.HitTest(shpTaskLink.Cells("BeginX"), _
shpTaskLink.Cells("BeginY"), 0.01)
If x = visHitOutside Then
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 2
Else
' do other stuff
End If
This is my first answer on stackoverflow and I hope the following VBA code can solve your problem on how to highlight connectors or connected shapes in Visio!
Public Sub HighlightConnectedShapes()
Dim vsoShape As Visio.Shape
Dim connectedShapeIDs() As Long
Dim connectorIDs() As Long
Dim intCount As Integer
' Highlight the selected shape
Set vsoShape = ActiveWindow.Selection(1)
vsoShape.CellsU("Fillforegnd").FormulaU = "RGB(146, 212, 0)"
vsoShape.Cells("LineColor").FormulaU = "RGB(168,0,0)"
vsoShape.Cells("LineWeight").Formula = "2.5 pt"
' Highlight connectors from/to the selected shape
connectorIDs = vsoShape.GluedShapes _
(visGluedShapesAll1D, "")
For intCount = 0 To UBound(connectorIDs)
ActivePage.Shapes.ItemFromID(connectorIDs(intCount)).Cells("LineColor").FormulaU = "RGB(168,0,0)"
ActivePage.Shapes.ItemFromID(connectorIDs(intCount)).Cells("LineWeight").Formula = "2.5 pt"
Next
' Highlight shapes that are connected to the selected shape
connectedShapeIDs = vsoShape.connectedShapes(visConnectedShapesAllNodes, "")
For intCount = 0 To UBound(connectedShapeIDs)
ActivePage.Shapes.ItemFromID(connectedShapeIDs(intCount)).Cells("LineColor").FormulaU = "RGB(168,0,0)"
ActivePage.Shapes.ItemFromID(connectedShapeIDs(intCount)).Cells("LineWeight").Formula = "2.5 pt"
Next
End Sub
To run the macro, you can consider associating with double-click behavior of shapes.
If you only need to highlight incoming/outgoing connectors and incoming/outgoing shapes, replace visGluedShapesAll1D with visGluedShapesIncoming1D/visGluedShapesOutgoing1D and visConnectedShapesAllNodes with visConnectedShapesIncomingNodes/visConnectedShapesOutgoingNodes.
Learn more at visgluedshapesflags and visconnectedshapesflags. Good luck!
The following code will loop though all 1d-Shapes glued to the first shape in your Selection and write their name to the Immediate window. This should be a good starting point.
Visio has no Event that fires if a Shape is selected (at least not without some workarounds), so maybe bind the macro to a keybind.
The visGluedShapesAll1D flag can be replace with another filter as described here: Microsoft Office Reference
Sub colorConnectors()
If ActiveWindow.Selection(1) Is Nothing Then Exit Sub
Dim selectedShape As Shape
Set selectedShape = ActiveWindow.Selection(1)
Dim pg As Page
Set pg = ActivePage
Dim gluedConnectorID As Variant 'variant is needed because of "For Each" Loop
For Each gluedConnectorID In selectedShape.GluedShapes(visGluedShapesAll1D, "")
Debug.Print pg.Shapes.ItemFromID(gluedConnectorID).NameU
Next gluedConnectorID
End Sub
I'm writing a simple code to position my shapes (which are actually pictures) in the document. I want them to be positioned:
horizontally to exactly 0 mm. from the left side of the printable area
vertically to 7 mm. below the paragraph (to which the shape is anchored)
I wrote a simple code:
Selection.ShapeRange.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
Selection.ShapeRange.Left = MillimetersToPoints(0)
Selection.ShapeRange.RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
Selection.ShapeRange.Top = MillimetersToPoints(7)
Selection.ShapeRange.WrapFormat.Type = wdWrapTopBottom
For 1 shape on the page it works fine. But if there are more then 1 shape, it somehow "throws" the 2nd shape to the top of the page. It looks like Word anchors it to the 1st paragraph on the page. but it shouldn't. At the same time horizontal positioning is ok.
I would appreciate any help to fix this issue.
My possible solution for this issue will look as follows:
Sub PositShape_3()
Dim I As Integer
If Selection.InlineShapes.Count <> 0 Then
For I = Selection.InlineShapes.Count To 1 Step -1
Selection.InlineShapes(I).ConvertToShape
Next I
End If
Selection.ShapeRange.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
Selection.ShapeRange.Left = MillimetersToPoints(0)
Selection.ShapeRange.RelativeVerticalPosition = wdRelativeVerticalPositionLine
Selection.ShapeRange.Top = MillimetersToPoints(7)
Selection.ShapeRange.WrapFormat.Type = wdWrapTopBottom
End Sub
In spite of the fact that the use of wdRelativeVerticalPositionLine solved the problem, it is still interesting why the use of wdRelativeVerticalPositionParagraph has such unexpected unwanted consequences.
Note the use of SELECTION in the code you show us. If you don't change the paragraph selection, then the shapes will always be anchored to the same paragraph. Working with a Selection in Word is tricky; it's much better to work with a more tangible object, such as a specific paragraph.
The following code sample illustrates using paragraph objects to anchor and position successively added Shapes.
Sub insertShapesProgressively()
Dim shp As word.Shape
Dim shpRng As word.ShapeRange
Dim rng As word.Range
Dim iParaCounter As Long
'We want to insert the Shape anchored to three different paragraphs
' on the same page
For i = 7 To 9
Set rng = ActiveDocument.Paragraphs(i).Range
Set shp = ActiveDocument.shapes.AddShape(msoShapeWave, 0, 0, 10, 10, rng)
Set shpRng = rng.ShapeRange
shpRng.RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
shpRng.Left = MillimetersToPoints(0)
shpRng.RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
shpRng.Top = MillimetersToPoints(7)
shpRng.WrapFormat.Type = wdWrapTopBottom
Next
End Sub
I'm trying to create a macro to change the thickness of connectors that are connected to a specific block. This is what I have so far:
Private Sub HighlightPaths_Click()
Dim selection As Shape
Dim connections() As Long
Dim i As Integer
'Msgbox glued shapes
If ActiveWindow.selection.Count = 0 Then
MsgBox ("Select a shape then click this button.")
Else
'Set shape to current selection
Set selection = ActiveWindow.selection(1)
'Get array of connectors on selected object
connections() = selection.GluedShapes(visGluedShapesAll1D, "")
'Resize connectors to that shape [ERROR HERE]
For i = 0 To UBound(connections())
connections(i).Cells("LineWeight").Formula = "0.5 pt"
Next
End If
End Sub
I know this comes from the fact that I'm trying to access the Cells property in a type that is not applicable. Do I have to search for the returns of the Glue method in the list of master shapes to find the dynamic connector master shapes?
Array connections(), contains connected shapes IDs.
You need get shape object, before change it Line Weight.
ActivePage.Shapes(connections(i)).Cells("LineWeight").Formula = "0.5 pt"
I'm working in Excel 2013 to (programmatically) add a straight line connector between the lower right hand corner of a rectangle that is part of a grouped shape with the endpoint of a grouped series of line segments. As it stands, I can't even seem to do this manually on the Excel worksheet that contains these shapes.
Problems include:
Only midpoints on the desired rectangle will accept the connector.
The grouped series of line segments don't even show a "connection point" for the terminating end of the straight line connector.
Here's a graphic of what I'm trying to do:
[I don't have 10 "reputation points" so I can't seem to post a picture of what I'm trying to do. Not an especially helpful feature! How do I get reputation points in this game?]
I've been able to create and name the two groups and thought it would be a cinch to work with them to add a connector, but that has not been the case.
Here's the code I've been working with:
Sub create_new_profile()
Dim firstRect As Shape
Dim firstLine As Shape
Set myDocument = Worksheets(1)
Set s = myDocument.Shapes
' Set firstRect = s.Range("shpNewGarage")
' Set firstLine = s.Range("shpProfile")
Dim Shp As Shape
' For Each Shp In myDocument.Shapes
For Each Shp In s
If Shp.Name = "shpNewGarage" Then
Set firstRect = Shp
Else
End If
Next Shp
' For Each Shp In myDocument.Shapes
For Each Shp In s
If Shp.Name = "shpProfile" Then
Set firstLine = Shp
Else
End If
Next Shp
firstRect.Select 'this works
firstLine.Select 'this works
' Set firstRect = s.AddShape(msoShapeRectangle, 100, 50, 200, 100)
' Set firstLine = s.AddShape(msoShapeRectangle, 300, 300, 200, 100)
' Set firstRect = ActiveSheet.Shapes.Range("shpNewGarage")
' Set firstLine = ActiveSheet.Shapes.Range("shpProfile")
Dim c As Shape
Set c = s.AddConnector(msoConnectorStraight, 0, 0, 100, 100)
' On Error Resume Next
With c.ConnectorFormat
**.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=1**
.EndConnect ConnectedShape:=firstLine, ConnectionSite:=1
' .BeginConnect ConnectedShape:="shpNewGarage", ConnectionSite:=1
' .EndConnect ConnectedShape:="shpProfile", ConnectionSite:=1
' .BeginConnect ConnectedShape:=ActiveSheet.Shapes.Range("shpNewGarage"), ConnectionSite:=1
' .EndConnect ConnectedShape:=ActiveSheet.Shapes.Range("shpProfile"), ConnectionSite:=1
c.RerouteConnections
End With
End Sub
This particular version of the code ends with a runtime error on the line immediately following the line:
With c.ConnectorFormat
Here's the error message:
[I don't have 10 "reputation points" so I can't seem to post a picture of the error message I'm getting. Again, how do I get reputation points?]
Any direction at all to help me accomplish this task programmatically would be greatly appreciated.
Thanks for explaining that I can now post images. That should help.
Here are the figures I'm working with:
The rectangle group (firstRect, "shpNewGarage") represents a new garage I plan to build between the existing one and the street. The profile group (firstLine, "shpProfile") represents the profile (side view/elevation) of the existing driveway (the light blue line.) The idea is to attach the new profile (red line) to the lower right corner of the new garage at one end and to the right end of the existing profile (curb) so that as I move the new garage up, down, right and left, the connector representing the new profile will remain attached to these points to show graphically the angle (grade) and length of the new driveway.
Here's the error message I receive when I run the code:
This looks like quite a hill to climb, as I am having problems even adding the connector to the desired points manually.
Thanks to all who have read/responded to my issue. Stackoverflow has been a great resource to me in the past, and this is the first time I've ever had to post my own fairly specific problem.
You explained everything very well, and the images you uploaded helped
What your code is doing seems to be correct, but the error is complaining about one of the parameters, and it could be the 2nd one:
.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=1
ConnectionSite: "A connection site on the shape specified by ConnectedShape. Must be an integer between 1 and the integer returned by the ConnectionSiteCount property of the specified shape"
I think your firstRect has a problem with the first Node: when you initially generate a rectangle it doesn't have connection points in the corners, and I'm not sure about the initial available nodes
A rectangle is a specific class of shape that must first be converted to a (generic) shape class: "You must apply the AddNodes method to a FreeformBuilder object at least once before you use the ConvertToShape method", in order to add connection points (nodes) to the corner
Another issue might be caused by groups. I'm not sure if you grouped the objects, but grouping may not allow direct access to connection points
As an exercise, I was able to draw lines between 2 rectangles the way you intended, but my lines are not actually connected to the shapes, so if I move one rectangle the lines will not move with it. Here is my code:
Option Explicit
Sub create_new_profile()
Dim ws As Worksheet
Dim shp1 As Shape
Dim shp2 As Shape
Dim line1 As Shape
Dim line2 As Shape
Set ws = Sheet1
With ws.Shapes
'AddShape: Left=10, Top=10, Width=50, Height=30
Set shp1 = .AddShape(msoShapeRectangle, 10, 10, 50, 30)
Set shp2 = .AddShape(msoShapeRectangle, 70, 50, 50, 30)
'AddConnector: BeginX=60, BeginY=10, EndX=120, EndY=50
Set line1 = .AddConnector(msoConnectorStraight, 60, 10, 120, 50)
Set line2 = .AddConnector(msoConnectorStraight, 60, 40, 120, 80)
End With
line1.Line.ForeColor.RGB = RGB(255, 0, 0) 'Color Red
line2.Line.ForeColor.RGB = RGB(255, 0, 0)
End Sub
and this is the end result:
.
If you need the lines to be linked to the rectangles, you'll have to convert the rectangles to shapes, then add corner connection points or nodes (msoEditingCorner), then add connector lines from one corner node of the first rectangle to the other corner node of the second rectangle
One of the ways to (manually) convert to shape, and record your actions to see the generated VBA code and objects used, is by right-clicking the shape and selecting "Edit Points":
Hope this helps a bit
'declare Variables
Dim osld As Slide
Dim oshp As Shape
Dim oeff As Effect
' SET objects
Set osld = ActivePresentation.Slides(7)
Set oshp = osld.Shapes("Star 1")
Set oeff = osld.TimeLine.MainSequence.AddEffect(Shape:=oshp, effectid:=msoAnimEffectChangeFillColor)
With oeff
.EffectParameters.Color2.RGB = RGB(Red:=10, Green:=45, Blue:=201)
.Timing.Duration = 2
End With
oshp.Left = oshp.Left + 100 ' Added to verify something was coming thru!
Sadly it still doesn't work... It compiles, but no effect on the slide...
I've updated the code to show your recommendations
NB: The fill color is defined at the creation of the shape
I added a + 100 to the left value of the shape just to make sure it was actually getting thru, it does move but it won't change color...
Is there an "official" list somewhere of what effects support what parameters?
Thanks for slugging thru this with me! :)
I understand your frustration: As mentioned in my comment, the Color1 property does not exist in PowerPoint 2010, yet the example given in the documentation for Color2 does use Color1 -- and, as a result, it doesn't compile!
The correct way is to give the shape a color, like this:
oshp.Fill.ForeColor.RGB = RGB(Red:=0, Green:=0, Blue:=255)
This will be the starting color. The animation effect can then change that color:
With oeff
.EffectParameters.Color2.RGB = RGB(Red:=0, Green:=255, Blue:=255)
.Timing.Duration = 2
End With
Note that Timing is a property of Effect, not of EffectParameters as in the code given in your question.