Копирование свойств из разделов User-defined cells, Shape Data и Actions

CopySectionsUSA.md

Цель

Код выполняет копирование содержимого разделов от одной фигуры к другой.

Переносятся разделы:

• User-defined cells [U];
• Shape Data (aka Custom properties) [S];
• Actions [A].

Как применить

Последовательность действий

1. На пустом листе требуется разместить первой фигуру-источник, содержимое разделов которой требуется скопировать;
2. Далее добавляется фигура-приемник;
3. Запускается код

'On Error Resume Next
Dim shj As Shape, dst As Shape, rwd As Row, rws As Row
Set shj = ActivePage.Shapes.ItemFromID(1)
Set dst = ActivePage.Shapes.ItemFromID(2)

'dst.AddSection visSectionUser
For pcu = 0 To 4
dst.AddRow visSectionUser, pcu, 0
'dst.Section(visSectionUser).Row(pcu).Name = "user." & pcu + 1
dst.CellsSRC(visSectionUser, pcu, 0).RowNameU = pcu + 1 ' shj.CellsSRC(visSectionUser, pcu, 0).FormulaU
dst.CellsSRC(visSectionUser, pcu, 1).FormulaU = shj.CellsSRC(visSectionUser, pcu, 1).FormulaU
Next
dst.AddSection visSectionProp
For pcp = 0 To shj.Section(visSectionProp).Count - 1
dst.AddRow visSectionProp, pcp, 0
Set rwd = dst.Section(visSectionProp).Row(pcp)
rwd.Name = shj.Section(visSectionProp).Row(pcp).Name
dst.CellsSRC(visSectionProp, pcp, 0).FormulaU = shj.CellsSRC(visSectionProp, pcp, 0).FormulaU
dst.CellsSRC(visSectionProp, pcp, 1).FormulaU = shj.CellsSRC(visSectionProp, pcp, 1).FormulaU
dst.CellsSRC(visSectionProp, pcp, 2).FormulaU = shj.CellsSRC(visSectionProp, pcp, 2).FormulaU
dst.CellsSRC(visSectionProp, pcp, 3).FormulaU = shj.CellsSRC(visSectionProp, pcp, 3).FormulaU
dst.CellsSRC(visSectionProp, pcp, 4).FormulaU = shj.CellsSRC(visSectionProp, pcp, 4).FormulaU
dst.CellsSRC(visSectionProp, pcp, 5).FormulaU = shj.CellsSRC(visSectionProp, pcp, 5).FormulaU
dst.CellsSRC(visSectionProp, pcp, 6).FormulaU = shj.CellsSRC(visSectionProp, pcp, 6).FormulaU
dst.CellsSRC(visSectionProp, pcp, 7).FormulaU = shj.CellsSRC(visSectionProp, pcp, 7).FormulaU
dst.CellsSRC(visSectionProp, pcp, 8).FormulaU = shj.CellsSRC(visSectionProp, pcp, 8).FormulaU
dst.CellsSRC(visSectionProp, pcp, 14).FormulaU = shj.CellsSRC(visSectionProp, pcp, 14).FormulaU
dst.CellsSRC(visSectionProp, pcp, 15).FormulaU = shj.CellsSRC(visSectionProp, pcp, 15).FormulaU

'Set rw = shj.Section(visSectionProp).Row(pc)
'    cc = rw.Count
'    For c = 0 To cc
'        Debug.Print c, shj.CellsSRC(visSectionProp, pc, c).Name
'    Next
Next

'dst.AddSection visSectionAction
For pca = 0 To shj.Section(visSectionAction).Count - 1
dst.AddRow 240, pca, 0
Set rwd = dst.Section(visSectionAction).Row(pca)
rwd.Name = shj.Section(visSectionAction).Row(pca).Name
dst.CellsSRC(visSectionAction, pca, 0).FormulaU = shj.CellsSRC(visSectionAction, pca, 0).FormulaU

dst.CellsSRC(visSectionAction, pca, 3).FormulaU = shj.CellsSRC(visSectionAction, pca, 3).FormulaU
dst.CellsSRC(visSectionAction, pca, 4).FormulaU = shj.CellsSRC(visSectionAction, pca, 4).FormulaU
dst.CellsSRC(visSectionAction, pca, 5).FormulaU = shj.CellsSRC(visSectionAction, pca, 5).FormulaU
dst.CellsSRC(visSectionAction, pca, 6).FormulaU = shj.CellsSRC(visSectionAction, pca, 6).FormulaU
dst.CellsSRC(visSectionAction, pca, 7).FormulaU = shj.CellsSRC(visSectionAction, pca, 7).FormulaU
dst.CellsSRC(visSectionAction, pca, 8).FormulaU = shj.CellsSRC(visSectionAction, pca, 8).FormulaU
dst.CellsSRC(visSectionAction, pca, 9).FormulaU = shj.CellsSRC(visSectionAction, pca, 9).FormulaU

dst.CellsSRC(visSectionAction, pca, 14).FormulaU = shj.CellsSRC(visSectionAction, pca, 14).FormulaU
dst.CellsSRC(visSectionAction, pca, 15).FormulaU = shj.CellsSRC(visSectionAction, pca, 15).FormulaU
dst.CellsSRC(visSectionAction, pca, 16).FormulaU = shj.CellsSRC(visSectionAction, pca, 16).FormulaU
Next

MsgBox "Done"
End Sub

Готовые альтернативы

На русскоязычном форуме Visio пользователи выкладывали свои решения
Надстройка. Копирование свойств шейпа

Копирование свойств (на VBA)