Can any help please? I've been poring over forums for the past two days and cannot figure out how to write this program.
Scenario: Two objects have been grouped, one has a distinct RGB fill color, say 255,0,0, the other does not have any color. Lets call the two shapes shpA and shpB respectively.
Objective: User manually select the group and executes a vba macro. Based upon the user selection, the macro should subselect shpA and use it as the base shape for top alignment. Secondly I am trying to have it put a 0.5 in horizontal distance between shpA and shpB with shpA being on the left. I may be able to write the second part on my own or use a recorder to figure it out.
Obstacle: There is no set pattern to the two grouped shapes, only difference is once has color.
Additional Info: Not sure if this matters, but when I was trying to programmatically identify the shapes using the following code, the shapes were identified as "Sheet.247" and "Sheet.250"
Public Sub Item_Example()
Dim intCounter As Integer
Dim intShapeCount As Integer
Dim vsoShapes As Visio.Shapes
Set vsoShapes = ActiveDocument.Pages.Item(1).Shapes
Debug.Print "Shape Name List For..."
Debug.Print "Document: "; ActiveDocument.Name
Debug.Print "Page: "; ActiveDocument.Pages.Item(1).Name
intShapeCount = vsoShapes.Count
If intShapeCount > 0 Then
For intCounter = 1 To intShapeCount
Debug.Print " "; vsoShapes.Item(intCounter).Name
Next intCounter
Else
Debug.Print " No Shapes On Page"
End If
End Sub
Quote from: visioVBArookie on August 25, 2018, 10:49:05 PM
Two objects have been grouped, one has a distinct RGB fill color, say 255,0,0, the other does not have any color. Lets call the two shapes shpA and shpB respectively.
Quote from: visioVBArookie on August 25, 2018, 10:49:05 PM
Obstacle: There is no set pattern to the two grouped shapes, only difference is once has color.
What is your main question: how identify which shape in group have fill (solid fill pattern) ?
Yes. I am trying to use shpA (the shape with a solid fill) and use it as the primary shape to do an alignment.
Please try this code
Dim sh As Shape, shA As Shape, shB As Shape, ssh As Shape
Set sh = ActivePage.Shapes(1)
' check is first sub-shape have RGB sub-string in formula in FillForegnd cell *
If InStr(sh.Shapes(1).Cells("FillForegnd").Formula, "RGB") Then
Set shA = sh.Shapes(1)
Set shB = sh.Shapes(2)
Else
Set shA = sh.Shapes(2)
Set shB = sh.Shapes(1)
End If
* - IMHO Themes in Visio is evil ! I use Visio Online Plan2, I create new document, set No Themes option and when I look in shapesheet of each shape I find there
Hmmm... Why are you using some shape for the alignment?
Isn't easier just to open the group, and align the shapes normally (Group => Open)?
That should open the group contents in a separate window, where you can align the shapes inside of the group, with standard "Align" commands.
Thanks for the replies Surrogate and Nikolay.
Surrogate, it is not working based off of RGB. It is detecting the wrong one. I've linked a sample drawing i am trying to work with.
Nikolay, if there were only a few shapes then yes. I'll have hundreds to do which is why I want a macro.
Here is a link to the sample drawing file. BTW, no themes are used in this drawing.
https://www.dropbox.com/s/luxp2tf4bhujldz/sample.vsdx?dl=0 (https://www.dropbox.com/s/luxp2tf4bhujldz/sample.vsdx?dl=0)
Quote from: visioVBArookie on August 26, 2018, 02:11:35 AMit is not working based off of RGB. It is detecting the wrong one. I've linked a sample drawing i am trying to work with.
Of course my code can't works in this case, because in your sample document you another group structure !
Group do not contain two simple shapes. It contain two group shapes !
try new updated code
Sub visioVBArookie()
Dim sh As Shape, shA As Shape, shB As Shape
Set sh = ActivePage.Shapes(1)
' check is first sub-shape of first sub-shape have RGB sub-string in formula in FillForegnd cell
If InStr(sh.Shapes(1).Shapes(1).Cells("FillForegnd").Formula, "RGB") Then
Set shA = sh.Shapes(1)
Set shB = sh.Shapes(2)
Else
Set shA = sh.Shapes(2)
Set shB = sh.Shapes(1)
End If
pxa = shA.Cells("PinX")
shB.Cells("PinX").Formula = "Sheet." & shA.ID & "!Width*0.5+sheet." & shA.ID & "!PinX+33 mm"
ActiveWindow.DeselectAll
sh.UpdateAlignmentBox
MsgBox "TheEnd!"
End Sub
If first sub-shape have fill, we select second sub-shape an move it to right side
QuoteIf InStr(sh.Shapes(1).Shapes(1).Cells("FillForegnd").Formula, "RGB") Then
1. Cells ("FillForegnd") can contain both the RGB formula and the color index. In the second case, this condition will not work.
2. The term "the other does not have any color" is likely need treat as "FillPattern = 0"
-------
As I understood after some research, the value of color can be obtained as follows:
ActiveDocument.Colors(shp.Cells("FillForegnd").Result(251))
or
Hex(ActiveDocument.Colors(shp.Cells("FillForegnd").Result(251)))
Here is the related link on this forum:
http://visguy.com/vgforum/index.php?topic=1061.0
shp.Cells("FillForegnd").ResultStrU(visNoCast)
The above results in a raw string like "RGB(217, 150, 144)", independent on your Visio locale, themes applied or of the pre-defined colors used.
But if the color is specified using an index, then such expression will return not the value of the RGB, but the index. For example, 6.
You are right. Did not verify properly. Sorry for the misleading comment. It does not work for the index.
Sorry for OFFTOP: last time I create new documents rarely. Now I use Visio online plan 2, in this version all cells in Fill format/Line format sections contain formulas like Themeval/Themeguard/etc even I set 'No theme (https://www.youtube.com/watch?v=5-EbgLvhYbE)' option!
How prevent this ugly theme-related formulas ?
I know just one way - save document in vsd format. Anyone know alternatives?
Thank you Surrogate! Your second suggestion worked just as I had hoped. I have a few more things to touch up to make everything work as I had initially described. Once completed I will post the code in full.
I have a followup question. Not all shA are the same width and sometimes shB overlaps shA with this formula:
shB.Cells("PinX").Formula = "Sheet." & shA.ID & "!Width*0.5+sheet." & shA.ID & "!PinX+33 mm"
In my mind if the left edge of shA and shB were the same, shB should be moved the width of shA + fixed amount. What would need to be modified to achieve this?
I was able to figure out the answer to my last question once I realized the center of a shape is used to move it. For reference here is the final product.
Sub visioVBArookie()
' special thanks to Surrogate from visguy.com for writing the majority of this code
Dim sh, shA, shB As Shape
Dim shAwdth, shBwdth As Visio.Cell
Dim shBwdth2 As Integer
' use current selection
Set sh = ActiveWindow.Selection(1)
' check is first sub-shape of first sub-shape have RGB sub-string in formula in FillForegnd cell
If InStr(sh.Shapes(1).Shapes(1).Cells("FillForegnd").Formula, "RGB") Then
Set shA = sh.Shapes(1)
Set shB = sh.Shapes(2)
Else
Set shA = sh.Shapes(2)
Set shB = sh.Shapes(1)
End If
' top shape alignment with shA as the anchor
ActiveWindow.Select shA, visSubSelect
ActiveWindow.Select shB, visSubSelect
Application.ActiveWindow.Selection.Align visHorzAlignNone, visVertAlignTop, False
ActiveWindow.DeselectAll
ActiveWindow.Select sh, visSelect
sh.UpdateAlignmentBox
' the following move uses the center of the shapes
' get width of shA and shB
Set shAwdth = shA.Cells("width")
Set shBwdth = shB.Cells("width")
' the next line of code is more or less processed in this manor:
' 1) using shA as the anchor, align center of shB to left edge of shA; '"Sheet." & shA.ID & "!PinX
' 2) get half of shB width and add to get left edge of shA aligned with left edge of shB; ' +" & "(" & shBwdth / 2 & ")
' 3) add width of shA to get shapes side-by-side; +" & shAwdth
' 4) apply 2 mm padding between shapes; + 2 mm
shB.Cells("PinX").Formula = "Sheet." & shA.ID & "!PinX+ 2 mm+" & "(" & shBwdth / 2 & ")+" & shAwdth
sh.UpdateAlignmentBox
ActiveWindow.DeselectAll
End Sub
The location of the "reference" is determined by the LocPinX and LocPinY cells. By default, it is the center of the shape, i.e., width*0.5, and height*0.5, respectively.
Wapperdude