Scal pliki Visio

Wiem, że mogę to zrobić ręcznie za pomocą funkcji kopiuj / wklej, ale szukam prostszego sposobu.

Czy ktoś wie o szybkim i łatwym sposobie scalania dokumentów Visio? Mam kilka plików Visio vsd, z których wszystkie są tego samego typu dokumentu wewnętrznego (Schemat blokowy - jednostki amerykańskie). Każda z nich ma od 1 do 15 stron. Chciałbym połączyć je wszystkie w jeden plik Visio.

Korzystam z Visio dla architektów korporacyjnych (11.4301.8221), więc jeśli jest taka procedura w tej wersji, właśnie tego szukam, ale narzędzie lub makro innej firmy również działałoby.

Nie można tego łatwo zrobić, ponieważ Visio nie zapewnia ładnej metody .Copy na obiekcie strony w Visio.

Można to zrobić za pomocą VBA, ale nie jest to tak proste, jak myślę, że powinno być.

Wkleję poniżej kod VBA, którego możesz użyć, przekazując tablicę nazw plików, która skopiuje się na wszystkich stronach w każdym z tych dokumentów. Zauważ jednak, że nie skopiuje żadnych wartości arkusza kształtów na poziomie strony, ponieważ jest to dla mnie zbyt skomplikowane ... więc jeśli po prostu kopiujesz kształty, powinno to działać dla Ciebie (podmenu TryMergeDocs to to, czego użyłem do przetestowania tego, i wydaje się, że działa dobrze) ...

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

Miałem podobny problem, ale chciałem też skopiować tło strony. Dlatego dodałem następujący wiersz w procedurze CopyPage:

DestPage.Background = CopyPage.Background

I dodał kolejną pętlę do CurrDoc.Pages w procedurze MergeDocuments:

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

Procedura SetBackground jest bardzo prosta:

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

I to zadziałało. Może komuś się to przyda.

Dziękujemy wszystkim za udostępnienie rozwiązania.

Pozwól mi skopiować / wkleić „scalenie” rozwiązania Jona i dodatku user26852 :-)

Oto pełne makro, które działało dla mnie jak urok:

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

Jedno tylko: musiałem ponownie sprawdzić „blokadę” na warstwie, którą miałem na swoich stronach. Zakładam, że „właściwości warstwy” nie są propagowane przez makro. Dla mnie nie było wielkim problemem ponowne zablokowanie wszystkich moich warstw tła. Ale dla kogoś innego może warto zastanowić się, jak skopiować / wkleić właściwości warstwy.

Natknąłem się na ten problem i przezwyciężyłem problem za pomocą funkcji Wstaw obiekt.

• Wybierz „Wstaw” z paska narzędzi
• Z rozwijanego menu wybierz „Obiekt”
• Wybierz „Utwórz z pliku”
• Wybierz „Microsoft Office Visio Drawing”
• Wybierz „Link do pliku”
• Kliknij „Przeglądaj”
• Wybierz plik, który chcesz wstawić
• Kliknij „Otwórz”
• Kliknij OK'

Plik VSD zostanie wstawiony jako obraz, który można zaktualizować, otwierając oryginalny plik lub klikając dwukrotnie i otwierając Visio dla „Obiektu”.

Pobierz Visio Super Utilities z:
http://www.sandrila.co.uk/visio-utilities/

Instalator otrzymuje plik install_readme.txt w pobranym pakiecie. Proszę odnieść się do instalacji. Po zainstalowaniu programu Visio Super Utilities wykonaj następujące czynności, aby połączyć dokumenty Visio

1. Otwórz 2 dokumenty Visio, które chcesz połączyć.
2. Przejdź do Dodatki -> SuperUtils -> Dokument -> Kopiuj dokument do innego dokumentu

Powtórz to dla każdego dokumentu źródłowego.

Dzięki za niezwykle pomocny skrypt. Dodałem kilka wierszy, aby skrypt był bardziej kompatybilny z dodatkiem do inżynierii procesowej. (Aktywuje się, jeśli rysujesz rury, zawory i inne rzeczy przy pomocy Visio) Aby wyłączyć automatyczne numerowanie lub tagowanie podczas uruchamiania skryptu vba, dodaj następujące wiersze na początku:

' 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

a te na końcu:

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

Myślę, że będzie to potrzebne tylko wtedy, gdy uruchamiasz skrypt z już istniejącym dokumentem jako celem. Być może ktoś inny uzna to za pomocne.