Greetings friends.
I have a question how to copy and paste all shape data values from one shape to another.
I have a document with lots of pages and on every page there is a shape with lots of shape data fields.
I want to transfer from first page to all next pages the shape data values.
I dont want to copy/paste the shape, because it is linked to another shapes in the page. I want only to transfer the values.
Any ideas ?
Thanks in advance :)
Would you care to try out my:
http://www.paulherber.co.uk/visio-utilities/
It can do copy/paste of ShapeData (or Custom Properties as they used to be called).
Select the shape you wish to copy from,
SuperUtils -> Shape -> Copy -> Custom Properties
now select the shape(s) you wish to copy to:
SuperUtils -> Shape -> Paste -> Custom Properties
Hmm, I thought I'd changed that menu to show it as ShapeData on Visio 2007 onwards. I shall do a new release ... probably tomorrow now.
Unfortunately, i use visio at work and my bosses have problem paying a license :/
I'm watching this utility from quite some time... :)
Sorry!
one week ago one user from our russian forum asked same question.
My advice: use Paul Herber's utility or use macro like this
Private Sub CopyProp()
' first time select shape which have shape data
' next select another shapes
Dim vsoSel As Visio.Selection
Dim vsoShpFst As Visio.Shape
Dim vsoShpSec As Visio.Shape
Dim x As Integer
Dim vsoCellF As Visio.Cell, vsoCellS As Visio.Cell
Dim vsoRow As Visio.Row
Dim iRF%, iRS%, iTotCount%, stMsgTot$, intSecShp%, booISeeClone As Boolean
Set vsoSel = ActiveWindow.Selection
If vsoSel.Count < 2 Then
MsgBox "Operation interupted. You must selected more than two shapes", vbCritical + vbOKOnly, "Error"
Exit Sub
End If
Set vsoShpFst = vsoSel(1)
For intSecShp = 2 To vsoSel.Count
iTotCount = 0
Set vsoShpSec = vsoSel(intSecShp)
For x = 242 To 243
For iRF = 0 To vsoShpFst.RowCount(x) - 1
Set vsoCellF = vsoShpFst.CellsSRC(x, iRF, 0)
booISeeClone = False
For iRS = 0 To vsoShpSec.RowCount(x) - 1
Set vsoCellS = vsoShpSec.CellsSRC(x, iRS, 0)
If vsoCellS.RowName = vsoCellF.RowName Then
booISeeClone = True
Exit For
End If
Next iRS
If booISeeClone = False Then
vsoShpSec.AddRow x, vsoShpSec.RowCount(x) + 1, visTagDefault
j = vsoShpSec.RowCount(x) - 1
vsoShpSec.CellsSRC(x, j, 0).RowName = vsoCellF.RowName
iTotCount = iTotCount + 1
Else
j = iRS
End If
For Z = 0 To vsoShpSec.RowsCellCount(x, iRS)
Set vsoCellS = vsoShpSec.CellsSRC(x, j, Z)
Set vsoCellF = vsoShpFst.CellsSRC(x, iRF, Z)
vsoCellS.FormulaU = vsoCellF.FormulaU
Next Z
Next iRF
Next x
stMsgTot = stMsgTot + vsoShpSec.NameU + Chr(32) + "add rows: " & iTotCount & Chr(13)
Next
MsgBox stMsgTot
End Sub
Nikolay's (http://visguy.com/vgforum/index.php?action=profile;u=380) advice: use Shape Data Sets
https://www.youtube.com/watch?v=Wqh9voTlOso
http://office.microsoft.com/en-001/visio-help/add-data-to-shapes-HA102749230.aspx
PS ooops, my advice don't work with shapes on different pages!
Also you can
1. add your stamp to document stencil (create new master)
2. Add some shape datas in this master
3. Drop this master to different pages and fill there their shape datas
David Parker has this written up in one of his books. I think he may also have it in his blog on his site.
http://blog.bvisual.net/
al edlund
Thanks.
The solution in david parkers blog did the thing.
I have edited the code verry little bit andadd a user form to select wich pages of the file i need to trasfer the shape data . (trick is that the sape is always called "foot" and it is on every needed page :) )
Thanks for the idea :)
Option Explicit
'Author : David Parker, Microsoft MVP (Visio)
'Date : 2nd Feb 2009
'Purpose: Demonstrate how shape data can be transferred from one shape to another
Sub CopyFromSelectedSourceToTargets()
'Transfer matching data rows from the primary selected shape to all other selected shapes
Const allCells As Boolean = False
Const forceAdd As Boolean = False
Const matchByName As Boolean = True
Const matchByLabel As Boolean = True
Dim vSource As Variant
Dim nodes As Variant
Dim j As Double
Dim h As Double
vSource = GetSourceData(ActivePage.Shapes.Item("foot"), allCells)
Dim shp As Visio.Shape
Dim iShp As Variant
copy_foot.TextBox2 = ""
copy_foot.Show
iShp = copy_foot.TextBox2
nodes = Split(iShp, " ")
For j = 0 To UBound(nodes)
h = nodes(j)
Set shp = ActiveDocument.Pages(h).Shapes.Item("foot")
If SetTargetData(shp, allCells, forceAdd, matchByName, matchByLabel, vSource) Then
MsgBox "èíôîðìàöèÿòà áåøå êîïèðàíà íà ñòðàíèöà " & h
Else
MsgBox "Data failed to transfer to " & shp.Name
End If
Next j
End Sub
Public Function GetSourceData(ByVal shp As Visio.Shape, ByVal allCells As Boolean) As Variant
'Get the data from a shape, optionally getting all cells
On Error GoTo errHandler
Dim iRows As Integer
iRows = shp.RowCount(Visio.VisSectionIndices.visSectionProp)
If iRows = 0 Then
GetSourceData = Nothing
Exit Function
End If
Dim iCellsPerRow As Integer
If allCells Then
iCellsPerRow = 11
Else
iCellsPerRow = 3
End If
ReDim avarFormulaArray(1 To (iRows * iCellsPerRow)) As Variant
Dim iRow As Integer
Dim iCellPerRow As Integer
Dim iCell As Integer
For iRow = 0 To iRows - 1
For iCellPerRow = 1 To iCellsPerRow
iCell = (iRow * iCellsPerRow) + 1
avarFormulaArray(iCell) = shp.CellsSRC(Visio.VisSectionIndices.visSectionProp, iRow, Visio.VisCellIndices.visCustPropsValue).RowNameU
avarFormulaArray(iCell + 1) = shp.CellsSRC(Visio.VisSectionIndices.visSectionProp, iRow, Visio.VisCellIndices.visCustPropsLabel).FormulaU
avarFormulaArray(iCell + 2) = shp.CellsSRC(Visio.VisSectionIndices.visSectionProp, iRow, Visio.VisCellIndices.visCustPropsValue).FormulaU
If allCells Then
avarFormulaArray(iCell + 3) = shp.CellsSRC(Visio.VisSectionIndices.visSectionProp, iRow, Visio.VisCellIndices.visCustPropsPrompt).FormulaU
avarFormulaArray(iCell + 4) = shp.CellsSRC(Visio.VisSectionIndices.visSectionProp, iRow, Visio.VisCellIndices.visCustPropsType).FormulaU
avarFormulaArray(iCell + 5) = shp.CellsSRC(Visio.VisSectionIndices.visSectionProp, iRow, Visio.VisCellIndices.visCustPropsFormat).FormulaU
avarFormulaArray(iCell + 6) = shp.CellsSRC(Visio.VisSectionIndices.visSectionProp, iRow, Visio.VisCellIndices.visCustPropsSortKey).FormulaU
avarFormulaArray(iCell + 7) = shp.CellsSRC(Visio.VisSectionIndices.visSectionProp, iRow, Visio.VisCellIndices.visCustPropsInvis).FormulaU
avarFormulaArray(iCell + 8) = shp.CellsSRC(Visio.VisSectionIndices.visSectionProp, iRow, Visio.VisCellIndices.visCustPropsAsk).FormulaU
avarFormulaArray(iCell + 9) = shp.CellsSRC(Visio.VisSectionIndices.visSectionProp, iRow, Visio.VisCellIndices.visCustPropsLangID).FormulaU
avarFormulaArray(iCell + 10) = shp.CellsSRC(Visio.VisSectionIndices.visSectionProp, iRow, Visio.VisCellIndices.visCustPropsCalendar).FormulaU
End If
Next iCellPerRow
Next iRow
GetSourceData = avarFormulaArray
exitHere:
Exit Function
errHandler:
MsgBox Err.Description, vbCritical, "GetSourceData"
Resume exitHere
End Function
Public Function SetTargetData(ByVal shp As Visio.Shape, ByVal allCells As Boolean, _
ByVal forceAdd As Boolean, ByVal matchByName As Boolean, ByVal matchByLabel As Boolean, _
ByVal aryData As Variant) As Boolean
'Set the data on surce shape, optionally copying all cells, forcing an add, matching by row name or label
On Error GoTo errHandler
Dim iCellsPerRow As Integer
If allCells Then
iCellsPerRow = 11
Else
iCellsPerRow = 3
End If
Dim totalCells As Integer
totalCells = UBound(aryData)
If totalCells = 0 Then
SetTargetData = False
Exit Function
End If
Dim iRows As Integer
iRows = shp.RowCount(Visio.VisSectionIndices.visSectionProp)
If shp.SectionExists(Visio.VisSectionIndices.visSectionProp, Visio.VisExistsFlags.visExistsAnywhere) = False Then
shp.AddSection Visio.VisSectionIndices.visSectionProp
End If
Dim iRowsAddedToTarget As Integer
Dim iRowTarget As Integer
Dim iRow As Integer
Dim iCell As Integer
Dim rowName As String
Dim rowLabel As String
Dim iRowTest As Integer
For iRow = 1 To totalCells Step iCellsPerRow
iRowTarget = -1
rowName = aryData(iRow)
rowLabel = aryData(iRow + 1)
If matchByName Then
'Firstly, test if row name exists
If Not shp.CellExistsU("Prop." & rowName, Visio.visExistsAnywhere) = 0 Then
iRowTarget = shp.CellsU("Prop." & rowName).Row
End If
End If
If iRowTarget < 0 And matchByLabel Then
'Secondly, test if label exists
For iRowTest = 0 To shp.RowCount(Visio.VisSectionIndices.visSectionProp) - 1
If UCase(shp.CellsSRC(Visio.VisSectionIndices.visSectionProp, iRowTest, Visio.VisCellIndices.visCustPropsLabel).ResultStr("")) = UCase(rowLabel) Then
iRowTarget = iRowTest
Exit For
End If
Next iRowTest
End If
If forceAdd And iRowTarget < 0 Then
If matchByName Then
iRowTarget = shp.AddNamedRow(Visio.VisSectionIndices.visSectionProp, rowName, 0)
Else
iRowTarget = shp.AddRow(Visio.VisSectionIndices.visSectionProp, shp.RowCount(Visio.VisSectionIndices.visSectionProp), 0)
End If
End If
If iRowTarget > -1 Then
setCellFormula shp, Visio.VisSectionIndices.visSectionProp, iRowTarget, Visio.VisCellIndices.visCustPropsLabel, aryData(iRow + 1)
setCellFormula shp, Visio.VisSectionIndices.visSectionProp, iRowTarget, Visio.VisCellIndices.visCustPropsValue, aryData(iRow + 2)
If allCells Then
setCellFormula shp, Visio.VisSectionIndices.visSectionProp, iRowTarget, Visio.VisCellIndices.visCustPropsPrompt, aryData(iRow + 3)
setCellFormula shp, Visio.VisSectionIndices.visSectionProp, iRowTarget, Visio.VisCellIndices.visCustPropsType, aryData(iRow + 4)
setCellFormula shp, Visio.VisSectionIndices.visSectionProp, iRowTarget, Visio.VisCellIndices.visCustPropsFormat, aryData(iRow + 5)
setCellFormula shp, Visio.VisSectionIndices.visSectionProp, iRowTarget, Visio.VisCellIndices.visCustPropsSortKey, aryData(iRow + 6)
setCellFormula shp, Visio.VisSectionIndices.visSectionProp, iRowTarget, Visio.VisCellIndices.visCustPropsInvis, aryData(iRow + 7)
setCellFormula shp, Visio.VisSectionIndices.visSectionProp, iRowTarget, Visio.VisCellIndices.visCustPropsAsk, aryData(iRow + 8)
setCellFormula shp, Visio.VisSectionIndices.visSectionProp, iRowTarget, Visio.VisCellIndices.visCustPropsLangID, aryData(iRow + 9)
setCellFormula shp, Visio.VisSectionIndices.visSectionProp, iRowTarget, Visio.VisCellIndices.visCustPropsCalendar, aryData(iRow + 10)
End If
End If
Next iRow
SetTargetData = True
exitHere:
Exit Function
errHandler:
MsgBox Err.Description, vbCritical, "SetTargetData"
Resume exitHere
End Function
Private Sub setCellFormula(ByVal shp As Visio.Shape, _
ByVal iSect As Integer, ByVal iRow As Integer, ByVal iCell As Integer, _
ByVal formula As String)
'Transfer cell formula if different
If Not shp.CellsSRC(iSect, iRow, iCell).FormulaU = formula Then
shp.CellsSRC(iSect, iRow, iCell).FormulaForceU = formula
End If
End Sub