Форум пользователей Visio
http://visio.getbb.ru/

Копирование листа
http://visio.getbb.ru/viewtopic.php?f=6&t=1049
Страница 3 из 4

Автор:  Shishok [ 14 ноя 2016, 23:38 ]
Заголовок сообщения:  Re: Копирование листа

Цитата:
Наверное, в Visio можно сделать аналогично.

Можно, конечно:
Код:
Dim oDoc As Visio.Document
Set oDoc = Application.Documents.Add("")
' Код
' Код
oDoc.SaveAs "path\filename.vsd"
oDoc.Close

Автор:  Alex_ST [ 15 ноя 2016, 13:06 ]
Заголовок сообщения:  Re: Копирование листа

Ребята, всё оказалось намного проще!
Читаем внимательно Справку по методам Shape.Copy & Shape.Paste и видим, что у обоих методов, оказывается, есть флаги методов копирования/вставки:
visCopyPasteNormal == 0 - Default value. Shapes are copied/pasted to the center of the active window.
visCopyPasteNoTranslate == 1 - Shapes are copied/pasted to their original coordinate locations
Поэтому никакоая возня с группировкой, правкой формул и разгруппировкой, похоже, НЕ НУЖНА!
Сейчас буду пробовать.
За одно подумаю, как бы поэлегантнее CellsSRC страницы передать новой странице?
Ну не нравится мне поэлементный копипаст :evil:
Тем более, что 8 элементов, боюсь, маловато будет. Надо ещё и ориентацию страницы копировать, и из visRowPageLayout ещё 5 параметров.
В общем, надо попробовать цикл хотя бы присобачить.

Автор:  Shishok [ 15 ноя 2016, 13:25 ]
Заголовок сообщения:  Re: Копирование листа

Я смотрю ты глубоко погрузился в объектную модель Visio. :)
По поводу:
Цитата:
За одно подумаю, как бы поэлегантнее CellsSRC страницы передать новой странице?

А это не увидел? http://visio.getbb.ru/viewtopic.php?f=15&t=1047

Автор:  Alex_ST [ 15 ноя 2016, 13:53 ]
Заголовок сообщения:  Re: Копирование листа

Shishok писал(а):
А это не увидел?
Там ссылка на файл на Яндекс.Диске. А я с работы до него не достаю. Но, судя по обсуждению, там копирование по одному параметру. Так я и сам уже когда-то делал. Вот подпрограмма с комментариями из моего старого проекта, в котором изо всех открытых документов листы собирались в один новый:Содержимое спрятано под спойлер ↓
Спойлер:
Код:
Private Sub Copy_Page_SetUp(newPage As Visio.Page, curPage As Visio.Page)
   newPage.Background = curPage.Background
   newPage.BackPage = curPage.BackPage

   ' CellsSRC property returns a Cell object that represents a ShapeSheet cell identified by section, row, and column indices.
   ' objRet = object.CellsSRC (section, row, column)
   ' visSectionObject == 1 -  Stores general non-repeating properties of an object
   ' visRowPage == 10 - Index of the row in visSectionObject that defines page or master properties (shape of type visTypePage).
   ' visRowPrintProperties == 25 Index of the row in visSectionObject of a document that defines printing properties. (Print Properties section in the ShaptSheet window.)
   ' visRowPageLayout == 24 Index of the row in visSectionObject of a page or master that defines placement and routing

   'newPage.PageSheet.CellsSRC(1, 10, visPageWidth).FormulaU = _
    curPage.PageSheet.CellsSRC(1, 10, visPageWidth).FormulaU ' visPageWidth == 0
   newPage.PageSheet.Cells("PageWidth") = curPage.PageSheet.Cells("PageWidth")

   'newPage.PageSheet.CellsSRC(1, 10, visPageHeight).FormulaU = _
    curPage.PageSheet.CellsSRC(1, 10, visPageHeight).FormulaU ' visPageHeight == 1
   newPage.PageSheet.Cells("PageHeight") = curPage.PageSheet.Cells("PageHeight")

   newPage.PageSheet.CellsSRC(1, 10, visPageScale).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 10, visPageScale).FormulaU ' visPageScale == 4

   newPage.PageSheet.CellsSRC(1, 10, visPageDrawingScale).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 10, visPageDrawingScale).FormulaU ' visPageDrawingScale == 5

   newPage.PageSheet.CellsSRC(1, 10, visPageDrawSizeType).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 10, visPageDrawSizeType).FormulaU ' visPageDrawSizeType == 6

   newPage.PageSheet.CellsSRC(1, 25, visPrintPropertiesLeftMargin).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 25, visPrintPropertiesLeftMargin).FormulaU ' visPrintPropertiesLeftMargin == 0

   newPage.PageSheet.CellsSRC(1, 25, visPrintPropertiesRightMargin).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 25, visPrintPropertiesRightMargin).FormulaU ' visPrintPropertiesRightMargin == 1

   newPage.PageSheet.CellsSRC(1, 25, visPrintPropertiesTopMargin).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 25, visPrintPropertiesTopMargin).FormulaU ' visPrintPropertiesTopMargin == 2

   newPage.PageSheet.CellsSRC(1, 25, visPrintPropertiesBottomMargin).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 25, visPrintPropertiesBottomMargin).FormulaU ' visPrintPropertiesBottomMargin == 3

   newPage.PageSheet.CellsSRC(1, 25, visPrintPropertiesPageOrientation).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 25, visPrintPropertiesPageOrientation).FormulaU ' visPrintPropertiesPageOrientation == 16

   newPage.PageSheet.CellsSRC(1, 25, visPrintPropertiesPaperKind).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 25, visPrintPropertiesPaperKind).FormulaU ' visPrintPropertiesPaperKind == 17


   newPage.PageSheet.CellsSRC(1, 24, visPLOLineToNodeX).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 24, visPLOLineToNodeX).FormulaU ' visPLOLineToNodeX == 16

   newPage.PageSheet.CellsSRC(1, 24, visPLOBlockSizeX).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 24, visPLOBlockSizeX).FormulaU ' visPLOBlockSizeX == 18

   newPage.PageSheet.CellsSRC(1, 24, visPLOBlockSizeY).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 24, visPLOBlockSizeY).FormulaU ' visPLOBlockSizeY == 19

   newPage.PageSheet.CellsSRC(1, 24, visPLOAvenueSizeX).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 24, visPLOAvenueSizeX).FormulaU ' visPLOAvenueSizeX == 20

   newPage.PageSheet.CellsSRC(1, 24, visPLOAvenueSizeY).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 24, visPLOAvenueSizeY).FormulaU ' visPLOAvenueSizeY == 21

   newPage.PageSheet.CellsSRC(1, 24, visPLOLineToLineY).FormulaU = _
   curPage.PageSheet.CellsSRC(1, 24, visPLOLineToLineY).FormulaU ' visPLOLineToLineY == 23

End Sub
но это монструозно и не красиво! Сейчас думаю, как бы циклами с использованием коллекций или словарей вместо массивов сделать. Благо время сейчас на работе есть.
И, к стати, твою процедурку Duplucate_Here я уже покоцал и протестировал с флагами копи-паста. Только пока ещё красоту не навёл. Отлично работает!Содержимое спрятано под спойлер ↓
Спойлер:
Код:
Sub Duplucate_Here()
   Dim arrPage(7) As String, oPage As Visio.Page, oPage1 As Visio.Page
   Set oPage = ActivePage
   Call GetPageSettings(oPage, arrPage)
   ActiveWindow.SelectAll
   ActiveWindow.Selection.Copy (1)

   Set oPage1 = ActiveDocument.Pages.Add
   Call SetPageSettings(oPage1, arrPage)
   oPage1.Paste (1)

   ActiveWindow.Page = oPage
   ActiveWindow.DeselectAll
   Set oPage = Nothing
   Set oPage1 = Nothing
End Sub

Автор:  Tumanov [ 15 ноя 2016, 14:55 ]
Заголовок сообщения:  Re: Копирование листа

Цитата:
Поэтому никакоая возня с группировкой, правкой формул и разгруппировкой, похоже, НЕ НУЖНА!

Правка формул и группировка - они не на пустом месте появились...
Тупое копирование шейпов - оно проходит для примитивной графики, но начинает ошибаться при наличии формул. Если копируется шейп, ссылающийся на шейп, который еще не скопирован, то формула неизбежно будет искажена. Ну не на что сослаться только что вставленному шейпу.
Так что все упрощения - они могут и выглядеть крутыми и даже тестироваться хорошо... Но только в своей области применения.

Автор:  Shishok [ 15 ноя 2016, 15:13 ]
Заголовок сообщения:  Re: Копирование листа

Цитата:
Но, судя по обсуждению, там копирование по одному параметру

Что это значит?
Там копирование целыми секциями(разделами). Например за раз копируется вот это все:

Изображение

Автор:  Alex_ST [ 15 ноя 2016, 16:15 ]
Заголовок сообщения:  Re: Копирование листа

Shishok писал(а):
Там копирование целыми секциями(разделами)
Ну я же говорил:
Alex_ST писал(а):
Там ссылка на файл на Яндекс.Диске. А я с работы до него не достаю
Значит, моё предположение о том, что
Alex_ST писал(а):
… судя по обсуждению, там копирование по одному параметру.
оказалось не верным. Из дома вечером посмотрю.
Tumanov писал(а):
Тупое копирование шейпов - оно проходит для примитивной графики
ну, это значит - для меня :)
Значит так: с копированием свойств страницы сейчас пока заниматься не буду.
Займусь копированием не выделяемых по ActiveWindow.SelectAll подложек ( шейпов, у которых .CellsC(visLayerLock)=True ).
Это, похоже, совсем не сложно сделать с использованием словарей.
А уже в конце проекта можно будет попробовать сделать не фиксированное, а динамически изменяемое в зависимости от количества открытых документов меню для выбора Destination. (На Excel у меня это получалось, но в Visio может быть засада с событиями - пока не вник как с ними работать. Посмотрим)

Автор:  Alex_ST [ 15 ноя 2016, 17:38 ]
Заголовок сообщения:  Re: Копирование листа

Ну вот. Разлочивание слоёв перед копированием и залочивание их обратно сделалСодержимое спрятано под спойлер ↓
Спойлер:
Код:
Sub Duplucate_Here()
   Dim arrPage(7) As String, oPage As Visio.Page, oNewPage As Visio.Page
   Dim xLayer As Visio.Layer
   Dim oDict As Object
   Set oDict = CreateObject("Scripting.Dictionary")
   For Each xLayer In ActiveWindow.Page.Layers   ' UnLock слоёв с запоминанием их индексов и имён в словаре
      With xLayer
         If .CellsC(visLayerLock) Then oDict.Item(.Index) = .Name: .CellsC(visLayerLock) = 0
      End With
   Next xLayer

   Set oPage = ActivePage
   ' ====== копирование рисунков =========
   ActiveWindow.SelectAll
   ActiveWindow.Selection.Copy (1)
   ActiveWindow.DeselectAll
   For Each xLayer In ActiveWindow.Page.Layers      ' Lock слоёв, запомненных в словаре
      With xLayer
         If oDict.Exists(.Index) Then .CellsC(visLayerLock) = 1
      End With
   Next xLayer

   ' ====== новая страница в текущем документе =========
   Set oNewPage = ActiveDocument.Pages.Add   ' после создания страница АКТИВИЗИРУЕТСЯ !!!
   Call GetPageSettings(oPage, arrPage)   ' запомнить установки копируемой страницы
   Call SetPageSettings(oNewPage, arrPage)

   oNewPage.Paste (1)
   For Each xLayer In ActiveWindow.Page.Layers   ' Lock слоёв, запомненных в словаре
      With xLayer
         If oDict.Exists(.Index) Then .CellsC(visLayerLock) = 1
      End With
   Next xLayer

   ActiveWindow.Page = oPage
   Set oPage = Nothing
   Set oNewPage = Nothing
   Set oDict = Nothing
End Sub
Процедуры GetPageSettings и SetPageSettings завтра объединю в одну CopyPageSettings

Автор:  Alex_ST [ 16 ноя 2016, 13:28 ]
Заголовок сообщения:  Re: Копирование свойств (на VBA)

Shishok,
Копаясь с копированием листа и не видя твою (т.к. ЯД с работы закрыт собаками-сисадминами :evil: ), я написал такую процедуру копирования свойств листов:Содержимое спрятано под спойлер ↓
Спойлер:
Код:
Private Sub Duplicate_Page_CellsSRC(oPageFrom As Visio.Page, oPageTo As Visio.Page)
   Dim arSection(): arSection = Array(visSectionObject)
   Dim arRow(): arRow = Array(visRowPage, visRowPrintProperties, visRowPageLayout)
   Dim iSection, iRow, iColumn
   For Each iSection In arSection
      For Each iRow In arRow
         For iColumn = 0 To 255
            On Error Resume Next
            oPageTo.PageSheet.CellsSRC(iSection, iRow, iColumn) = oPageFrom.PageSheet.CellsSRC(iSection, iRow, iColumn)
            'Debug.Print oPageFrom.Name & "CellsSRC(" & iSection & "," & iRow & "," & iColumn & ").FormulaU = " & oPageFrom.PageSheet.CellsSRC(iSection, iRow, iColumn)
         Next iColumn
      Next iRow
   Next iSection
End Sub
Главное преимущество, ИМХО, - "всё в одном" без усложнения вызовом других процедур.
И к тому же при необходимости работы с другими объектами копируемые секции и ряды элементарно можно либо просто изменить в коде, либо переделать процедуру в универсальную, добавив ей в аргументы массивы сканируемых параметров, а не задавая их внутри.

Автор:  Shishok [ 16 ноя 2016, 13:38 ]
Заголовок сообщения:  Re: Копирование свойств (на VBA)

Ну приблизительно и у меня так же.
Но это только для, так сказать , штатных секций страницы.
А вот Shape Data, User Defined Cells, Scratch, Actions, Hyperlinks и Layers - это отдельная песня. Ну может оно тебе и не надо.

Автор:  Alex_ST [ 16 ноя 2016, 13:42 ]
Заголовок сообщения:  Re: Копирование листа

Alex_ST писал(а):
Процедуры GetPageSettings и SetPageSettings завтра объединю в одну CopyPageSettings
Переделал.
Кроме того, обнаружил, что .Index у слоя может измениться при копировании и потому не правильно восстановиться из словаря. Переделал на запоминание в словаре .Name залоченных слоёв.
Вроде бы работает. Проверьте кто-нибудь ещё, пожалуйста.
Duplucate_HereСодержимое спрятано под спойлер ↓
Спойлер:
Код:
Sub Duplucate_Here()
   Dim arrPage(7) As String
   Dim oPage As Visio.Page, oNewPage As Visio.Page
   Dim xLayer As Visio.Layer
   Dim oDict As Object
   Set oDict = CreateObject("Scripting.Dictionary")
   For Each xLayer In ActiveWindow.Page.Layers   ' UnLock слоёв с запоминанием их индексов и имён в словаре
      With xLayer
         If .CellsC(visLayerLock) Then oDict.Item(.Name) = .Index: .CellsC(visLayerLock) = 0
      End With
   Next xLayer
   Set oPage = ActivePage
   ' ====== копирование рисунков =========
   ActiveWindow.SelectAll
   ActiveWindow.Selection.Copy (1)
   ActiveWindow.DeselectAll
   For Each xLayer In ActiveWindow.Page.Layers      ' Lock слоёв, запомненных в словаре
      With xLayer
         If oDict.Exists(.Name) Then .CellsC(visLayerLock) = 1
      End With
   Next xLayer
   ' ====== новая страница в текущем документе =========
   Set oNewPage = ActiveDocument.Pages.Add
   Call Duplicate_Page_CellsSRC(oPage, oNewPage)   ' копировать установки текушей страницы в новую
   oNewPage.Paste (1)
   For Each xLayer In ActiveWindow.Page.Layers   ' Lock слоёв, запомненных в словаре
      With xLayer
         If oDict.Exists(.Name) Then .CellsC(visLayerLock) = 1
      End With
   Next xLayer
   ActiveWindow.Page = oPage
   Set oPage = Nothing
   Set oNewPage = Nothing
   Set oDict = Nothing
End Sub
Duplucate_Here_ToСодержимое спрятано под спойлер ↓
Спойлер:
Код:
Sub Duplucate_Here_To()
   Dim arrPage(7) As String
   Dim oPage As Visio.Page, oNewPage As Visio.Page
   Dim oActiveDoc As Visio.Document, oOtherDoc As Visio.Document, oDoc As Visio.Document
   Dim oActiveWindow As Visio.Window
   Dim xLayer As Visio.Layer
   Dim oDict As Object
   Set oDict = CreateObject("Scripting.Dictionary")
   For Each xLayer In ActiveWindow.Page.Layers   ' UnLock слоёв с запоминанием их индексов и имён в словаре
      With xLayer
         If .CellsC(visLayerLock) Then oDict.Item(.Name) = .Index: .CellsC(visLayerLock) = 0
      End With
   Next xLayer
   Set oActiveDoc = ActiveDocument
   Set oActiveWindow = ActiveWindow
   Set oPage = ActivePage
   ' ====== копирование рисунков =========
   ActiveWindow.SelectAll
   ActiveWindow.Selection.Copy (1)
   ActiveWindow.DeselectAll
   For Each xLayer In ActiveWindow.Page.Layers      ' Lock слоёв, запомненных в словаре
      With xLayer
         If oDict.Exists(.Name) Then .CellsC(visLayerLock) = 1
      End With
   Next xLayer
   ' ==== назначение документа, куда копировать =====
   ' необходимо доработать - добавить выбор документа
   For Each oDoc In Application.Documents
      If oDoc.Name <> oActiveDoc.Name Then
         'If Not LCase(oDoc.Name) Like "*.vss*" Then
         If oDoc.Type = 1 Then   '1 == visTypeDrawing
            Set oOtherDoc = oDoc
            Exit For
         End If
      End If
   Next
   ' ====== новая страница в новом документе =========
   Set oNewPage = oOtherDoc.Pages.Add
   Call Duplicate_Page_CellsSRC(oPage, oNewPage)   ' копировать установки текушей страницы в новую
   oNewPage.Paste (1)
   For Each xLayer In ActiveWindow.Page.Layers      ' Lock слоёв, запомненных в словаре
      With xLayer
         If oDict.Exists(.Name) Then .CellsC(visLayerLock) = 1
      End With
   Next xLayer

   oActiveWindow.Activate
   Set oActiveWindow = Nothing
   Set oActiveDoc = Nothing
   Set oPage = Nothing
   Set oOtherDoc = Nothing
   Set oNewPage = Nothing
   Set oDict = Nothing
End Sub
Duplicate_Page_CellsSRCСодержимое спрятано под спойлер ↓
Спойлер:
Код:
Private Sub Duplicate_Page_CellsSRC(oPageFrom As Visio.Page, oPageTo As Visio.Page)
   Dim arSection(): arSection = Array(visSectionObject)
   Dim arRow(): arRow = Array(visRowPage, visRowPrintProperties, visRowPageLayout)
   Dim iSection, iRow, iColumn
   For Each iSection In arSection
      For Each iRow In arRow
         For iColumn = 0 To 255
            On Error Resume Next
            oPageTo.PageSheet.CellsSRC(iSection, iRow, iColumn) = oPageFrom.PageSheet.CellsSRC(iSection, iRow, iColumn)
            'Debug.Print oPageFrom.Name & "CellsSRC(" & iSection & "," & iRow & "," & iColumn & ").FormulaU = " & oPageFrom.PageSheet.CellsSRC(iSection, iRow, iColumn)
         Next iColumn
      Next iRow
   Next iSection
End Sub
Ну а возможность выбора книги, куда копировать, выложу позже.
Сначала поэкспериментирую в в любимом и привычном Excel, а потом уже переложу на Visio/
Боюсь, правда, что без использования юзер-формы и модулей класса не обойтись. А это - отдельные модули проекта, что затрудняет его копирование, т.к. приходится делать жёсткую привязку к их именам. Да и с модулями класса я очень слаб, к сожалению :oops:

Автор:  Alex_ST [ 16 ноя 2016, 13:56 ]
Заголовок сообщения:  Re: Копирование свойств (на VBA)

Ну в принципе-то моя процедура хоть и привязана к объектам, но принцип сканирования по трём массивам параметров применим практически везде.
Я, к стати, специально именно поэтому не стал сканировать только по одному нужному мне значению секции, а задал её как массив из одного элемента:
Код:
Dim arSection(): arSection = Array(visSectionObject)

Автор:  Alex_ST [ 16 ноя 2016, 13:59 ]
Заголовок сообщения:  Re: Копирование свойств (на VBA)

Shishok писал(а):
А вот Shape Data, User Defined Cells, Scratch, Actions, Hyperlinks и Layers - это отдельная песня.
С Shape Data, User Defined Cells, Scratch, Actions, Hyperlinks я ещё пока не сталкивался (просто не было необходимости), а вот с Layers никаких затруднений не возникло при сканировании для копирования листов. При этом там я процедуру запоминания в словаре упростил до запоминания только значений .CellsC(visLayerLock) , но ничего не мешало пробежаться по всем значениям каждого слоя и запоминать массивы.

Автор:  Shishok [ 16 ноя 2016, 14:08 ]
Заголовок сообщения:  Re: Копирование листа

Проверил. Не копируются не видимые слои.
В принципе, собственно копирование секции слоев не нужно. Бросание на страницу шейпов принадлежащих какому то слою и так создает эти слои.

Автор:  Shishok [ 16 ноя 2016, 14:14 ]
Заголовок сообщения:  Re: Копирование листа

А вообще не копирование скрытых шейпов(когда они на невидимых слоях) можно сделать опцией.
Не нужен слой, условно - светильников, сделал слой с ними невидимым.

Автор:  Alex_ST [ 16 ноя 2016, 14:35 ]
Заголовок сообщения:  Re: Копирование листа

Shishok писал(а):
Проверил. Не копируются не видимые слои.
Ну так я для невидимых и не делал. Делал только для залоченных. А про то, что невидимые тоже не выбираются при ActiveWindow.SelectAll я, естественно, забыл... :oops:
Ща поправлю.
К стати, Duplucate_Here_To у меня почему-то работает, но не лочит слои в получателе… Буду проверять.
Да и я там ещё забыл процедуры GetPageSettings и SetPageSettings заменить на Duplicate_Page_CellsSRC. Правлю прямо там.

Автор:  Alex_ST [ 16 ноя 2016, 15:46 ]
Заголовок сообщения:  Re: Копирование листа

Alex_ST писал(а):
Duplucate_Here_To у меня почему-то работает, но не лочит слои в получателе…

Нашёл, где собака порылась.
Оказывается, после выполнения команды
Код:
Set oNewPage = ActiveDocument.Pages.Add
окно, содержащее oNewPage , активизируется и потому к нему можно обращаться как к ActiveWindow.Page (что в общем-то вполне логично).
Но после выполнения команды
Код:
Set oNewPage = oOtherDoc.Pages.Add
не только не автивизируется окно, содержащее oNewPage , но не активизируется даже и сам oOtherDoc
Поэтому к нему нельзя обращаться как к ActiveWindow.
Обновлённые процедуры здесь под спойлеромСодержимое спрятано под спойлер ↓
Спойлер:
Код:
Sub Duplucate_Here()
   Dim oPage As Visio.Page: Set oPage = ActivePage
   Dim oNewPage As Visio.Page
   Dim xLayer As Visio.Layer
   Dim oDict: Set oDict = CreateObject("Scripting.Dictionary")
   For Each xLayer In oPage.Layers   ' UnLock слоёв с запоминанием их индексов и имён в словаре
      If xLayer.CellsC(visLayerLock) = 1 Then oDict.Item(xLayer.Name) = xLayer.Index: xLayer.CellsC(visLayerLock) = 0
   Next xLayer
   ' ====== копирование рисунков =========
   With ActiveWindow: .SelectAll: .Selection.Copy (1): .DeselectAll: End With
   For Each xLayer In oPage.Layers      ' Lock слоёв, запомненных в словаре
      If oDict.Exists(xLayer.Name) Then xLayer.CellsC(visLayerLock) = 1
   Next xLayer
   ' ====== новая страница в текущем документе =========
   Set oNewPage = ActiveDocument.Pages.Add
   Call Duplicate_Page_CellsSRC(oPage, oNewPage)   ' копировать установки текушей страницы в новую
   oNewPage.Paste (1)
   For Each xLayer In oNewPage.Layers   ' Lock слоёв, запомненных в словаре
      If oDict.Exists(xLayer.Name) Then xLayer.CellsC(visLayerLock) = 1
   Next xLayer
   ActiveWindow.Page = oPage
   Set oPage = Nothing
   Set oNewPage = Nothing
   Set oDict = Nothing
End Sub

Sub Duplucate_Here_To()
   Dim oActiveWindow As Visio.Window: Set oActiveWindow = ActiveWindow
   Dim oActiveDoc As Visio.Document: Set oActiveDoc = ActiveDocument
   Dim oPage As Visio.Page: Set oPage = ActivePage
   Dim oOtherDoc As Visio.Document
   Dim oNewPage As Visio.Page
   Dim xDoc As Visio.Document
   Dim xLayer As Visio.Layer
   Dim oDict: Set oDict = CreateObject("Scripting.Dictionary")
   For Each xLayer In oPage.Layers   ' UnLock слоёв с запоминанием их индексов и имён в словаре
      If xLayer.CellsC(visLayerLock) = 1 Then oDict.Item(xLayer.Name) = xLayer.Index: xLayer.CellsC(visLayerLock) = 0
   Next xLayer
   ' ====== копирование рисунков =========
   With ActiveWindow: .SelectAll: .Selection.Copy (1): .DeselectAll: End With
   For Each xLayer In oPage.Layers      ' Lock слоёв, запомненных в словаре
      If oDict.Exists(xLayer.Name) Then xLayer.CellsC(visLayerLock) = 1
   Next xLayer
   ' ==== назначение документа, куда копировать =====
   ' необходимо доработать - добавить выбор документа
   For Each xDoc In Application.Documents
      If xDoc.Name <> oActiveDoc.Name Then
         'If Not LCase(xDoc.Name) Like "*.vss*" Then
         If xDoc.Type = visTypeDrawing Then
            Set oOtherDoc = xDoc: Exit For
         End If
      End If
   Next
   ' ====== новая страница в новом документе =========
   Set oNewPage = oOtherDoc.Pages.Add
   Call Duplicate_Page_CellsSRC(oPage, oNewPage)   ' копировать установки текушей страницы в новую
   oNewPage.Paste (1)
   For Each xLayer In oNewPage.Layers      ' Lock слоёв, запомненных в словаре
      If oDict.Exists(xLayer.Name) Then xLayer.CellsC(visLayerLock) = 1
   Next xLayer
   oActiveWindow.Activate
   Set oActiveWindow = Nothing
   Set oActiveDoc = Nothing
   Set oPage = Nothing
   Set oOtherDoc = Nothing
   Set oNewPage = Nothing
   Set oDict = Nothing
End Sub

Private Sub Duplicate_Page_CellsSRC(oPageFrom As Visio.Page, oPageTo As Visio.Page)
   Dim arSection(): arSection = Array(visSectionObject)
   Dim arRow(): arRow = Array(visRowPage, visRowPrintProperties, visRowPageLayout)
   Dim iSection, iRow, iColumn
   For Each iSection In arSection
      For Each iRow In arRow
         For iColumn = 0 To 255
            On Error Resume Next
            oPageTo.PageSheet.CellsSRC(iSection, iRow, iColumn) = oPageFrom.PageSheet.CellsSRC(iSection, iRow, iColumn)
            'Debug.Print oPageFrom.Name & "CellsSRC(" & iSection & "," & iRow & "," & iColumn & ").FormulaU = " & oPageFrom.PageSheet.CellsSRC(iSection, iRow, iColumn)
         Next iColumn
      Next iRow
   Next iSection
End Sub
Исправить-то исправил, но по ходу дела возник вопрос: если известен лист oNewPage (As Visio.Page естественно), то какой командой можно активировать его окно?

Автор:  Shishok [ 16 ноя 2016, 16:10 ]
Заголовок сообщения:  Re: Копирование листа

Цитата:
если известен лист oNewPage (As Visio.Page естественно), то какой командой можно активировать его окно?

Если oNewPage находится в активном сейчас документе:
Код:
ActiveWindow.Page = oNewPage

А если не в активном, то сначала активируем окно этого документа:
Код:
Windows.ItemEx("заголовок окна этого документа").Activate

или:
Код:
Windows.Item("индекс окна в коллекции Windows").Activate

Автор:  Alex_ST [ 16 ноя 2016, 16:34 ]
Заголовок сообщения:  Re: Копирование листа

Shishok писал(а):
"заголовок окна этого документа"

Это ведь не oNewPage.Name ?
Это по крайней мере oOtherDoc.Name
Ну так как выглядит команда активации окна документа, содержащего oNewPage ?

Автор:  Shishok [ 16 ноя 2016, 16:51 ]
Заголовок сообщения:  Re: Копирование листа

Windows.ItemEx(oOtherDoc.Name).Activate

Страница 3 из 4 Часовой пояс: UTC + 3 часа [ Летнее время ]
Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group
http://www.phpbb.com/