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
Related
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 just want to connect 2 squares after selecting them.
My code below doesn't work, can't see how to fix it:
Sub ConnectSelectedShapes()
Dim shpFirst As Shape
Dim shpSecond As Shape
Dim shpShapes As Shapes
Set shapesRange = ActiveWindow.Selection.ShapeRange
Set shpFirst = shapesRange(1)
Set shpSecond = shapesRange(2)
With shpShapes.AddConnector(Type:=msoConnectorCurve, BeginX:=0, _
BeginY:=0, EndX:=100, EndY:=100).ConnectorFormat
.BeginConnect ConnectedShape:=shpFirst, ConnectionSite:=1
.EndConnect ConnectedShape:=shpSecond, ConnectionSite:=1
.Parent.RerouteConnections
End With
End Sub
You've delcared shpShapes, however you haven't defined it...
Set shpShapes = ActiveWindow.View.Slide.Shapes
And, of course, you'll need to make sure that 2 shapes have been selected before running the code.
Hope this helps!
I just started using VBA a few days ago. I noticed that some few commands do not seem to work on my computer and I was wondering whether this is due to my computer setup.
I am using VBA in PowerPoint 2013 on Windows 7 run via VMware Fusion (virtual machine) on MacOSX. I need to create a dynamic reference to the active slide, but several way of doing so broke my code:
Set oSl = Application.ActiveWindow.View.Slide
(as suggested here)
Set oSl = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideNumber)
(as suggested here)
Set oSl = ActiveWindow.Selection.SlideRange.SlideIndex
(as suggested here)
None of these worked for me. Since I just started using VBA I simply inserted Message Boxes after different parts of the code, and looked at when the boxes where no longer triggered - in this case always after the "oSl =" line that I replaced with the various other approaches delineated above. Additionally,
Set oSl = ActiveWindow.Selection.SlideRange(1)
also broke my code (as discussed here)
What DID work so far was
Set oSl = ActivePresentation.SlideS(1)
All the methods above that didn't work (but should) contain "ActiveWindow". It would be great if you could advise on whether there are errors in my approach to selecting the active slide or whether the issue might be that VBA can't access the "ActiveWindow" properly because my PowerPoint runs on a virtual machine. Should that be the case, is there another way to select the currently active slide without using ActiveWindow?
EDIT: I am trying to apply this to the following code in PowerPoint. Basically what I want to do is replace the line "oSl = ActivePresentation.SlideS(1)" with a line of code that won't always target slide 1 but whichever slide is currently active. My question is not so much HOW to do this - there are plenty of instructions on how to do it online. My question is WHY these approaches are not working for me.
Sub SelectionMacro()
Dim oSl As Slide
Dim oSh As Shape
Dim aArrayOfShapes() As Variant
Dim ShapeX As Shape
Dim N As Long
Dim Temp As Variant
Dim J As Long
Dim FadeEffect As Effect
Set oSl = ActivePresentation.SlideS(1)
'This section creates an array of all pictures on Slide1 called
'"aArrayOfShapes"
For Each oSh In oSl.Shapes
If oSh.Type = msoPicture Then
On Error Resume Next
Debug.Print UBound(aArrayOfShapes)
If Err.Number = 0 Then
ReDim Preserve aArrayOfShapes(1 To UBound(aArrayOfShapes) + 1)
Else
ReDim Preserve aArrayOfShapes(1 To 1)
End If
Set aArrayOfShapes(UBound(aArrayOfShapes)) = oSh
End If
Next
'This section creates a random index number within the bounds of the
'length of aArrayOfShapes and assigns the shape with that index number
'to the Shape object ShapeX
Randomize
NumberX = Int((UBound(aArrayOfShapes) - (LBound(aArrayOfShapes) - 1)) * Rnd) + LBound(aArrayOfShapes)
Set ShapeX = aArrayOfShapes(NumberX)
'This section shuffles aArrayOfShapes
For N = LBound(aArrayOfShapes) To UBound(aArrayOfShapes)
J = CLng(((UBound(aArrayOfShapes) - N) * Rnd) + N)
If N <> J Then
Set Temp = aArrayOfShapes(N)
Set aArrayOfShapes(N) = aArrayOfShapes(J)
Set aArrayOfShapes(J) = Temp
End If
Next N
'This section loops through all Shapes in aArrayOfShapes and
'fades them out one by one EXCEPT for ShapeX
For Each Shape In aArrayOfShapes
If ShapeX.Name <> Shape.Name Then
Set FadeEffect = oSl.TimeLine.MainSequence.AddEffect _
(Shape:=Shape, effectid:=msoAnimEffectFade, trigger:=msoAnimTriggerAfterPrevious)
With FadeEffect
.Timing.Duration = 0.5
.Exit = msoTrue
End With
End If
Next Shape
End Sub
I had similar problem.
Try to replace:
ActiveWindow.View.Slide.SlideNumber
with:
ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
It was what I needed in my project, maybe it helps you.
(disclaimer: i'm not a VBA programmer by occupation)
Attached to buttons in the Ribbon I have code to toggle the company logo in a Word Document.
One button for the logo type A, a second button for logo type B and a third for no logo (logo is preprintend on paper)
First I remove the logo with removeLogo and then i add it the requested logo with setLogoAt.
The first button click is fine (e.g. for Logo Type A), a logo is added to the header of the document. When i click an other button (e.g for Logo Type B) Word crashes (probably on removing the current logo)
What is wrong with my code (or less probably: with Word?)
Sub setLogoAt(left As Integer, path As String)
Dim logoShape As Shape
Dim anchorLocation As Range
Dim headerShapes As Shapes
Set logoShape = ActiveDocument. 'linebreks for readability
.Sections(1)
.Headers(wdHeaderFooterPrimary)
.Shapes
.AddPicture(FileName:=path, LinkToFile:=False,
SaveWithDocument:=True, left:=0,
Top:=0, Width:=100, Height:=80)
logoShape.name = "CompanyLogo"
logoShape.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
logoShape.RelativeVerticalPosition = wdRelativeVerticalPositionPage
logoShape.Top = CentimetersToPoints(0.1)
logoShape.left = CentimetersToPoints(left)
End Sub
Sub removeLogo()
Dim headerShapes As Shapes
Set headerShapes = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
Dim shapeToDelete As Shape
If (headerShapes.Count > 0) Then
If Not IsNull(headerShapes("CompanyLogo")) Then
Set shapeToDelete = headerShapes("CompanyLogo")
End If
End If
If Not (shapeToDelete Is Nothing) Then
shapeToDelete.Delete
End If
End Sub
edit
I steped trough my code. All is fine until I reach the line shapteToDelete.Delete in removeLogo. Here Word crashes hard, even while debugging. I'm using Word 2007 (and that is a requirement)
edit2
I cleared all macros, all normals.dot, all autoloading templates, then created a new document with the two routines above and this test method:
Sub test()
setLogoAt 5, "C:\path\to\logo.jpg"
removeLogo
setLogoAt 6, "C:\path\to\logo.jpg"
End Sub
When I run test it crashes in removeLogo at shapeToDelete.Delete.
Edit 3
I 'solved' the problem by first making the headers/footers view the active view in Word, then deleting the Shape and then returning to normal view. Very strange. It works but as a programmer I'm not happy.
Another potential solution is to try and select the shape first and then delete the selection:
shapeToDelete.Select
Selection.Delete
You would probably want to switch off screen updating if this works, else you'll get flickering as Word moves around the document.
I've experienced this problem before and normally with an automation error: "The object invoked has disconnected from its clients". I haven't yet found a solution.
However a good workaround is to hide the shape rather than delete it.
So:
shapeToDelete.Visible = False
This works:
I only have 2 boxes to hide so this isn't generic
Private Sub btnPrint_Click()
Dim hdrShapes As Shapes
Dim S As Shape
Dim aTohide(2) As String
Dim iNdx, i As Integer
iNdx = 0
' Hide buttons and print
Set hdrShapes = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Shapes
' GET BUTTON NAMES (ACTUALLY TEXT BOXES
For Each S In hdrShapes
If S.Type = msoTextBox Then
aTohide(iNdx) = S.Name
iNdx = iNdx + 1
End If
Next
' now hide , use the arrays as the for each statement crashes
For i = 0 To 1
hdrShapes(aTohide(i)).Visible = msoFalse
Next
' print it
With ActiveDocument
.PrintOut
End With
' and unhide the buttons
For i = 0 To 1
hdrShapes(aTohide(i)).Visible = msoTrue
Next
Set hdrShapes = Nothing
End Sub