copy all shape data fields from one shape to another

Started by kiler40, October 28, 2014, 07:03:35 PM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

kiler40

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 :)

Paul Herber

#1
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.
Electronic and Electrical engineering, business and software stencils for Visio -

https://www.paulherber.co.uk/

kiler40

Unfortunately, i use visio at work and my bosses have problem paying a license :/
I'm watching this utility from quite some time... :)
Sorry!

Surrogate

#3
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 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!

Surrogate

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

aledlund

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


kiler40

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