Câu hỏi Hợp nhất các tệp Visio


Tôi biết tôi có thể làm điều này bằng tay bằng cách sử dụng sao chép / dán nhưng tôi đang tìm kiếm một cách đơn giản hơn.

Có ai biết một cách nhanh chóng và dễ dàng để hợp nhất các tài liệu Visio? Tôi có một số tệp Visio vsd, tất cả đều là cùng loại tài liệu nội bộ (Flowchart - US Units). Mỗi trong số này có từ 1 đến 15 trang. Tôi muốn kết hợp tất cả chúng thành một tệp Visio.

Tôi đang sử dụng Visio for Enterprise Architects (11.4301.8221) vì vậy nếu có một thủ tục để làm điều đó trong phiên bản đó, đó là những gì tôi đang tìm kiếm, nhưng một công cụ của bên thứ 3 hoặc một macro sẽ làm việc là tốt.


4
2017-11-04 19:21


gốc




Các câu trả lời:


Điều này không thể dễ dàng được thực hiện, bởi vì Visio không cung cấp một phương thức .Copy tốt đẹp trên đối tượng trang trong Visio.

Điều này có thể được thực hiện thông qua VBA, nhưng nó không đơn giản như tôi nghĩ.

Tôi sẽ dán một số mã VBA dưới đây mà bạn có thể sử dụng bằng cách truyền một mảng tên tệp trong đó sẽ sao chép trong tất cả các trang trong mỗi tài liệu đó. Tuy nhiên, lưu ý rằng nó sẽ không sao chép bất kỳ giá trị shapesheet cấp trang nào, vì nó quá liên quan đến tôi bây giờ ... vì vậy nếu bạn chỉ đơn giản là sao chép các hình dạng, điều này sẽ làm việc cho bạn (phụ TryMergeDocs là những gì tôi đã sử dụng để kiểm tra điều này, và dường như nó hoạt động tốt) ...

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



Cảm ơn bạn. Tôi sẽ thử điều đó ngay hôm nay! nếu nó hoạt động, tôi sẽ trở lại để bỏ phiếu cho bạn và chấp nhận câu trả lời như đã hứa. - David Stratton
Necroing đến một mức độ, nhưng bạn có thể sử dụng Visio.ActivePage.SelectAll phương pháp thay vì đi xe đạp qua chúng - David Colwell


Tôi đã có vấn đề tương tự, nhưng cũng muốn sao chép nền của một trang. Vì vậy tôi đã thêm dòng sau trong thủ tục CopyPage:

DestPage.Background = CopyPage.Background

Và thêm một vòng lặp khác trên CurrDoc.Pages trong thủ tục MergeDocuments:

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

Thủ tục SetBackground rất đơn giản:

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

Và điều này đã hiệu quả. Có lẽ sb sẽ thấy nó hữu ích.


3
2018-02-01 16:47



+1. Nice bổ sung, và tôi đặt cược nó sẽ rất hữu ích! - David Stratton


Cảm ơn tất cả vì đã chia sẻ một giải pháp.

Hãy để tôi sao chép / dán "hợp nhất" của giải pháp của Jon và bổ sung của user26852 :-)

Đây là macro đầy đủ làm việc như một sự quyến rũ đối với tôi:

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

Một điều mặc dù: Tôi đã phải kiểm tra lại "khóa" trên một lớp tôi đã có trên các trang của tôi. Tôi cho rằng "các thuộc tính lớp" không được Macro truyền bá. Đối với tôi, đó không phải là vấn đề lớn để khóa lại tất cả các lớp nền của tôi. Nhưng đối với một người nào khác nó có thể là giá trị nó để tìm thêm một chút về cách sao chép / dán các thuộc tính lớp quá.


2
2017-09-03 13:53





Tôi đã gặp sự cố này và đã khắc phục sự cố bằng cách sử dụng hàm Chèn đối tượng.

  • Chọn 'Chèn' từ thanh công cụ
  • Chọn 'Đối tượng' từ trình đơn thả xuống
  • Chọn 'Tạo từ tệp'
  • Chọn 'Microsoft Office Visio Drawing'
  • Chọn 'Liên kết tới tệp'
  • Nhấp vào 'Duyệt'
  • Chọn tệp bạn muốn chèn
  • Nhấp vào 'Mở'
  • Nhấp vào 'OK'

Tệp VSD sẽ được chèn dưới dạng ảnh, có thể được cập nhật bằng cách mở tệp gốc hoặc bằng cách nhấp đúp và mở Visio cho 'Đối tượng'.


1
2018-06-27 18:28





Tải xuống Visio Super Utilities từ:
http://www.sandrila.co.uk/visio-utilities/ 

Quá trình cài đặt được cung cấp cho tệp install_readme.txt trong gói đã tải xuống. Vui lòng tham khảo phần cài đặt. Sau khi cài đặt Visio Super Utilities, hãy sử dụng các bước sau để kết hợp tài liệu Visio

  1. Mở 2 tài liệu Visio bạn muốn kết hợp.
  2. Đi tới Add-Ins -> SuperUtils -> Document -> Sao chép tài liệu sang tài liệu khác

Lặp lại điều này cho mỗi tài liệu nguồn.


1
2018-03-18 09:55





Cảm ơn kịch bản cực kỳ hữu ích. Tôi đã thêm một số dòng, để làm cho kịch bản tương thích hơn với addon kỹ thuật quy trình. (Điều này được kích hoạt nếu bạn đang vẽ các đường ống và van và các công cụ với visio) Để vô hiệu hóa việc đánh số tự động hoặc gắn thẻ khi chạy vba-script, hãy thêm các dòng sau vào đầu:

' 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

và cuối cùng:

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

Tôi nghĩ rằng bạn sẽ chỉ cần điều này, nếu bạn đang chạy kịch bản với một tài liệu đã tồn tại như là mục tiêu. Có lẽ ai đó khác sẽ thấy điều này hữu ích.


0
2018-06-15 16:17