Вопрос Слияние файлов Visio


Я знаю, что могу сделать это вручную, используя copy / paste, но я ищу более простой способ.

Кто-нибудь знает быстрый и простой способ слияния документов Visio? У меня есть несколько файлов vsd Visio, все из которых являются одним и тем же внутренним типом документа (Блок-схема - US Units). Каждый из них имеет от 1 до 15 страниц. Я хотел бы объединить их все в один файл Visio.

Я использую Visio для Enterprise Architects (11.4301.8221), поэтому, если в этой версии есть процедура для этого, это то, что я ищу, но также будет работать сторонний инструмент или макрос.


4
2017-11-04 19:21


происхождения




ответы:


Это нелегко сделать, потому что Visio не обеспечивает хороший метод .Copy на объекте страницы в Visio.

Это можно сделать через VBA, но это не так просто, как мне кажется.

Я вставлю код VBA ниже, который вы можете использовать, передав массив имен файлов, которые будут копироваться на всех страницах в каждом из этих документов. Обратите внимание, однако, что он не скопирует значения таблиц на уровне страницы, так как это сейчас слишком сложно для меня ... поэтому, если вы просто копируете фигуры, это должно работать на вас (подпрограмма TryMergeDocs - это то, что я использовал для проверки этого, и, похоже, он хорошо работает) ...

Private Sub TryMergeDocs()
    Dim Docs() As Variant
    Docs = Array("C:\Tmp\JunkVSD\Drawing1.vsd", "C:\Tmp\JunkVSD\Drawing2.vsd", "C:\Tmp\JunkVSD\Drawing3.vsd")
    MergeDocuments Docs
End Sub

Sub MergeDocuments(FileNames() As Variant, Optional DestDoc As Visio.Document)
    ' merge into a new document if no document is provided
    On Error GoTo PROC_ERR
    If DestDoc Is Nothing Then
        Set DestDoc = Application.Documents.Add("")
    End If

    Dim CheckPage As Visio.Page
    Dim PagesToDelete As New Collection
    For Each CheckPage In DestDoc.Pages
        PagesToDelete.Add CheckPage
    Next CheckPage
    Set CheckPage = Nothing

    ' loop through the FileNames array and open each one, and copy each page into destdoc
    Dim CurrFileName As String
    Dim CurrDoc As Visio.Document
    Dim CurrPage As Visio.Page, CurrDestPage As Visio.Page
    Dim CheckNum As Long
    Dim ArrIdx As Long
    For ArrIdx = LBound(FileNames) To UBound(FileNames)
        CurrFileName = CStr(FileNames(ArrIdx))
        Set CurrDoc = Application.Documents.OpenEx(CurrFileName, visOpenRO)
        For Each CurrPage In CurrDoc.Pages
            Set CurrDestPage = DestDoc.Pages.Add()
            With CurrDestPage
                On Error Resume Next
                Set CheckPage = DestDoc.Pages(CurrPage.Name)
                If Not CheckPage Is Nothing Then
                    While Not CheckPage Is Nothing ' handle duplicate names by putting (#) after the original name
                        CheckNum = CheckNum + 1
                        Set CheckPage = Nothing
                        Set CheckPage = DestDoc.Pages(CurrPage.Name & "(" & CStr(CheckNum) & ")")
                    Wend
                    CurrDestPage.Name = CurrPage.Name & "(" & CStr(CheckNum) & ")"
                Else
                    CurrDestPage.Name = CurrPage.Name
                End If
                On Error GoTo PROC_ERR
                Set CheckPage = Nothing
                CheckNum = 0

                ' copy the page contents over
                CopyPage CurrPage, CurrDestPage

            End With
            DoEvents
        Next CurrPage
        DoEvents
        Application.AlertResponse = 7

        CurrDoc.Close
    Next ArrIdx

    For Each CheckPage In PagesToDelete
        CheckPage.Delete 0
    Next CheckPage

PROC_END:
    Application.AlertResponse = 0
    Exit Sub

PROC_ERR:
    MsgBox Err.Number & vbCr & Err.Description
    GoTo PROC_END
End Sub

Sub CopyPage(CopyPage As Visio.Page, DestPage As Visio.Page)
    Dim TheSelection As Visio.Selection
    Dim CurrShp As Visio.Shape
    DoEvents
    Visio.Application.ActiveWindow.DeselectAll

    DestPage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageHeight).Formula = CopyPage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageHeight).ResultIU
    DestPage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageWidth).Formula = CopyPage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageWidth).ResultIU

    Set TheSelection = Visio.ActiveWindow.Selection

    For Each CurrShp In CopyPage.Shapes
        TheSelection.Select CurrShp, visSelect
        DoEvents
    Next

    TheSelection.Copy visCopyPasteNoTranslate
    DestPage.Paste visCopyPasteNoTranslate

    TheSelection.DeselectAll
End Sub

5
2017-11-06 15:08



Спасибо. Я попробую это сегодня! если это сработает, я вернусь, чтобы проголосовать за вас и принять ответ, как и было обещано. - David Stratton
Necroing до некоторой степени, но вы можете использовать Visio.ActivePage.SelectAll вместо того, чтобы ездить по ним - David Colwell


У меня была схожая проблема, но хотелось также скопировать фон страницы. Поэтому я добавил следующую строку в процедуру CopyPage:

DestPage.Background = CopyPage.Background

И добавил еще один цикл над CurrDoc.Pages в процедуре MergeDocuments:

For Each CurrPage In CurrDoc.Pages
    Set CurrDestPage = DestDoc.Pages(CurrPage.Name)
    SetBackground CurrPage, CurrDestPage
Next CurrPage

Процедура SetBackground очень проста:

Sub SetBackground(CopyPage As Visio.Page, DestPage As Visio.Page)
   If Not CopyPage.BackPage Is Nothing Then
       DestPage.BackPage = CopyPage.BackPage.Name
   End If
End Sub

И это сработало. Возможно, sb найдет это полезным.


3
2018-02-01 16:47



+1. Хорошее дополнение, и я уверен, что это будет полезно! - David Stratton


Спасибо всем за то, что вы приняли решение.

Позвольте мне скопировать / вставить «слияние» решения Джона и добавление пользователя26852 :-)

Это полный макрос, который работал как прелесть для меня:

Private Sub TryMergeDocs()
    Dim Docs() As Variant
    Docs = Array("C:\Tmp\JunkVSD\Drawing1.vsd", "C:\Tmp\JunkVSD\Drawing2.vsd", "C:\Tmp\JunkVSD\Drawing3.vsd")
    MergeDocuments Docs
End Sub

Sub MergeDocuments(FileNames() As Variant, Optional DestDoc As Visio.Document)
    ' merge into a new document if no document is provided
    On Error GoTo PROC_ERR
    If DestDoc Is Nothing Then
        Set DestDoc = Application.Documents.Add("")
    End If

    Dim CheckPage As Visio.Page
    Dim PagesToDelete As New Collection
    For Each CheckPage In DestDoc.Pages
        PagesToDelete.Add CheckPage
    Next CheckPage
    Set CheckPage = Nothing

    ' loop through the FileNames array and open each one, and copy each page into destdoc
    Dim CurrFileName As String
    Dim CurrDoc As Visio.Document
    Dim CurrPage As Visio.Page, CurrDestPage As Visio.Page
    Dim CheckNum As Long
    Dim ArrIdx As Long
    For ArrIdx = LBound(FileNames) To UBound(FileNames)
        CurrFileName = CStr(FileNames(ArrIdx))
        Set CurrDoc = Application.Documents.OpenEx(CurrFileName, visOpenRO)
        For Each CurrPage In CurrDoc.Pages
            Set CurrDestPage = DestDoc.Pages.Add()
            With CurrDestPage
                On Error Resume Next
                Set CheckPage = DestDoc.Pages(CurrPage.Name)
                If Not CheckPage Is Nothing Then
                    While Not CheckPage Is Nothing ' handle duplicate names by putting (#) after the original name
                        CheckNum = CheckNum + 1
                        Set CheckPage = Nothing
                        Set CheckPage = DestDoc.Pages(CurrPage.Name & "(" & CStr(CheckNum) & ")")
                    Wend
                    CurrDestPage.Name = CurrPage.Name & "(" & CStr(CheckNum) & ")"
                Else
                    CurrDestPage.Name = CurrPage.Name
                End If
                On Error GoTo PROC_ERR
                Set CheckPage = Nothing
                CheckNum = 0

                ' copy the page contents over
                CopyPage CurrPage, CurrDestPage
                SetBackground CurrPage, CurrDestPage

            End With

            DoEvents
        Next CurrPage
        DoEvents
        Application.AlertResponse = 7

        CurrDoc.Close
    Next ArrIdx

    For Each CheckPage In PagesToDelete
        CheckPage.Delete 0
    Next CheckPage

PROC_END:
    Application.AlertResponse = 0
    Exit Sub

PROC_ERR:
    MsgBox Err.Number & vbCr & Err.Description
    GoTo PROC_END
End Sub

Sub CopyPage(CopyPage As Visio.Page, DestPage As Visio.Page)
    Dim TheSelection As Visio.Selection
    Dim CurrShp As Visio.Shape
    DoEvents
    Visio.Application.ActiveWindow.DeselectAll

    DestPage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageHeight).Formula = CopyPage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageHeight).ResultIU
    DestPage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageWidth).Formula = CopyPage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageWidth).ResultIU
    DestPage.Background = CopyPage.Background


    Set TheSelection = Visio.ActiveWindow.Selection

    For Each CurrShp In CopyPage.Shapes
        TheSelection.Select CurrShp, visSelect
        DoEvents
    Next

    TheSelection.Copy visCopyPasteNoTranslate
    DestPage.Paste visCopyPasteNoTranslate

    TheSelection.DeselectAll
End Sub

Sub SetBackground(CopyPage As Visio.Page, DestPage As Visio.Page)
   If Not CopyPage.BackPage Is Nothing Then
       DestPage.BackPage = CopyPage.BackPage.Name
   End If
End Sub

Одна вещь: мне пришлось перепроверить «блокировку» на слое, который у меня был на моих страницах. Я предполагаю, что «свойства слоя» не распространяются на макрос. Для меня это было неважно, чтобы перекрыть все мои фоновые слои. Но для кого-то это может стоить немного подробнее о том, как скопировать / вставить свойства слоя.


2
2017-09-03 13:53





Я столкнулся с этой проблемой и преодолел проблему с помощью функции «Вставить объект».

  • Выберите «Вставить» на панели инструментов
  • Выберите «Объект» в раскрывающемся меню
  • Выберите «Создать из файла»
  • Выберите «Microsoft Office Visio Drawing»
  • Выберите «Ссылка на файл»
  • Нажмите «Обзор»
  • Выберите файл, который хотите вставить.
  • Нажмите «Открыть»
  • Нажмите «ОК»

Файл VSD будет вставлен как изображение, которое можно обновить, открыв исходный файл или дважды щелкнув и открыв Visio для «Объекта».


1
2018-06-27 18:28





Загрузить Visio Super Utilities из:
http://www.sandrila.co.uk/visio-utilities/ 

Установке предоставляется файл install_readme.txt в загруженном пакете. Пожалуйста, обратитесь к установке. После установки Visio Super Utilities выполните следующие шаги для объединения документов Visio

  1. Откройте два документа Visio, которые вы хотите объединить.
  2. Перейти к надстройкам -> SuperUtils -> Документ -> Копировать документ в другой документ

Повторите это для каждого исходного документа.


1
2018-03-18 09:55





Спасибо за чрезвычайно полезный скрипт. Я добавил несколько строк, чтобы сделать скрипт более совместимым с админом процесса разработки. (Это активируется, если вы рисуете трубы и клапаны и прочее с помощью visio). Чтобы отключить автоматическую нумерацию или тегирование при запуске vba-script, добавьте следующие строки в начале:

' Disable PE automatic editing while copying
Dim prevPEUserOptions As Integer
Dim PEEnabled As Integer
If  DestDoc.DocumentSheet.CellExists("User.PEUserOptions", 1) Then
    PEEnabled = 1
    prevPEUserOptions = DestDoc.DocumentSheet.Cells("User.PEUserOptions")
    DestDoc.DocumentSheet.Cells("User.PEUserOptions") = 0
End If

и это в конце:

If (PEEnabled) Then
    DestDoc.DocumentSheet.Cells("User.PEUserOptions") = prevPEUserOptions
End If

Я думаю, вам понадобится только это, если вы используете скрипт с уже существующим документом в качестве цели. Возможно, кто-то еще найдет это полезным.


0
2018-06-15 16:17