Copy using VBA

[Firkins]

I'm looking for some code to create copies of a shape.
I'm wanting to select a shape and then run some code that will ask me "How
high?", and "How many rows?". Using that information the code will duplicate
the shape the required height and rows. I need the duplicated shapes to be
stacked on top of each other and the rows a small distance apart (.5 inches).

Example. height of 3, rows of 4 would create.

x x x x
x x x x
x x x x

 

[John Goldsmith]

Hello Firkins,

Have a go with the code below:

Sub DupeShapesGrid()
Dim shpOriginal As Shape
Dim shpNew As Shape
Dim dblXOffset As Double
Dim dblYOffset As Double
Dim iCols As Integer
Dim iRows As Integer
Dim i As Integer
Dim j As Integer

Set shpOriginal = ActiveWindow.Selection.PrimaryItem

If Not shpOriginal Is Nothing Then
'Set grid offsets
dblXOffset = 0.5
dblYOffset = 0.5

iCols = CInt(InputBox("Enter number of columns:", "Duplicate shape -
Columns"))
iRows = CInt(InputBox("Enter number of rows:", "Duplicate shape -
Rows"))

For i = 0 To iCols - 1
For j = 0 To iRows - 1
If Not (i = 0 And j = 0) Then
Set shpNew = shpOriginal.Duplicate
shpNew.CellsU("PinX").FormulaU = _
shpOriginal.CellsU("PinX").Result(visInches) +
(dblXOffset * i)
shpNew.CellsU("PinY").FormulaU = _
shpOriginal.CellsU("PinY").Result(visInches) -
(dblYOffset * j)
End If
Next j
Next i
End If

End Sub

Hope that helps.

Best regards

John

John Goldsmith
www.visualSignals.co.uk

 

[Mark Nelson [MS]]

This is a feature in the product as well:
Tools > Add-ons > Visio Extras > Array Shapes

--
Mark Nelson
Office Graphics - Visio
Microsoft Corporation

This posting is provided "AS IS" with no warranties, and confers no rights.

 

[Firkins]

I don't think I explained myself clear enough. Sorry. I need the duplicated
boxes to stack (Bottom of new box on the top of the old tote). So a column 5
high would stretch from the top of the page to the bottom. Depending on the
size of the box. I need the Rows to be spaced a small distance apart (.5
inches). A 5 column 2 row would almost look like an exel grid with a small
distance between column of 5. The code you have puts all the boxes on top of
the original.

Thank you for your help

 

[Firkins]

I don't have "Array Shapes" in my Visio Extras. How do I get it?

 

[John Goldsmith]

No, the code does do what you want, as far as I understand you. However if
you page scale is reasonably large then perhaps you're not seeing the effect
of 0.5 in?

If you draw a rectangle and ensure that it's 0.5inches square (View / Size &
Position window) the code will stack them next to each other. If you then
want to play with the gaps between the shapes, you'll need to change the
X/YOffset variables to the dims you want.

The only other thing to check is that the code isn't break over a line
somewhere. Here's the same code without indentation:

Sub DupeShapesGrid()
Dim shpOriginal As Shape
Dim shpNew As Shape
Dim dblXOffset As Double
Dim dblYOffset As Double
Dim iCols As Integer
Dim iRows As Integer
Dim i As Integer
Dim j As Integer

Set shpOriginal = ActiveWindow.Selection.PrimaryItem

If Not shpOriginal Is Nothing Then
'Set grid offsets
dblXOffset = 0.5
dblYOffset = 0.5

iCols = CInt(InputBox("Enter number of columns:", _
"Duplicate shape - Columns"))
iRows = CInt(InputBox("Enter number of rows:", _
"Duplicate shape - Rows"))

For i = 0 To iCols - 1
For j = 0 To iRows - 1
If Not (i = 0 And j = 0) Then
Set shpNew = shpOriginal.Duplicate
shpNew.CellsU("PinX").FormulaU = _
shpOriginal.CellsU("PinX").Result(visInches) + (dblXOffset * i)
shpNew.CellsU("PinY").FormulaU = _
shpOriginal.CellsU("PinY").Result(visInches) - (dblYOffset * j)
End If
Next j
Next i
End If

End Sub

Let me know how you get on.

Best regards

John

John Goldsmith
www.visualSignals.co.uk

 

[John Goldsmith]

The Array Shapes add-on is only in Professional version, not Standard I'm
afraid, although I should have mentioned this in my first post. Thanks
Mark.

Best regards

John

John Goldsmith
www.visualSignals.co.uk

 

[Firkins]

Sorry. I know what I forgot to mention now. My boxes will vary in size. I
need the VBA to check what size the box is that way it knows how far to
offset and place the duplicates. My scale is 1 in = 1 ft. I will have boxes
ranging in size from 1ft x 3in to 4ft x 2ft. The .5 in is the space between
columns. Rows will have no spacing one box ends the duplicate starts. Sorry
if I haven't been clear. Its hard to describe things in just text.

Thanks again

 

[John Goldsmith]

OK, so you just need to add the Width and Height of the orignal shape into
the equation and ignore the YOffset:

Sub DupeShapesGrid()
Dim shpOriginal As Shape
Dim shpNew As Shape
Dim dblXOffset As Double
Dim dblYOffset As Double
Dim dblOrigWidth As Double
Dim dblOrigHeight As Double
Dim iCols As Integer
Dim iRows As Integer
Dim i As Integer
Dim j As Integer

Set shpOriginal = ActiveWindow.Selection.PrimaryItem

If Not shpOriginal Is Nothing Then
'Set grid offsets
dblXOffset = 0.5
dblYOffset = 0.5

'Get original shape dims
dblOrigWidth = shpOriginal.CellsU("Width").Result(visInches)
dblOrigHeight = shpOriginal.CellsU("Height").Result(visInches)

iCols = CInt(InputBox("Enter number of columns:", _
"Duplicate shape - Columns "))
iRows = CInt(InputBox("Enter number of rows:", _
"Duplicate shape - Rows "))

For i = 0 To iCols - 1
For j = 0 To iRows - 1
If Not (i = 0 And j = 0) Then
Set shpNew = shpOriginal.Duplicate
shpNew.CellsU("PinX").FormulaU = _
shpOriginal.CellsU("PinX").Result(visInches) + _
(dblOrigWidth * i) + (dblXOffset * i)
shpNew.CellsU("PinY").FormulaU = _
shpOriginal.CellsU("PinY").Result(visInches) - _
(dblOrigHeight * j)
End If
Next j
Next i
End If

End Sub

Hope that helps.

Best regards

John

John Goldsmith
www.visualSignals.co.uk

 

[Firkins]

That works perfect! You are a VB master.

Thank you