Frage Visio-Dateien zusammenführen


Ich weiß, dass ich das manuell mit Copy / Paste machen kann, aber ich suche nach einem einfacheren Weg.

Kennt jemand eine schnelle und einfache Möglichkeit, Visio-Dokumente zusammenzuführen? Ich habe mehrere Visio vsd-Dateien, die alle den gleichen internen Dokumenttyp (Flussdiagramm - US-Einheiten) sind. Jeder von ihnen hat zwischen 1 und 15 Seiten. Ich möchte sie alle in einer Visio-Datei kombinieren.

Ich verwende Visio for Enterprise Architects (11.4301.8221). Wenn es in dieser Version ein Verfahren dafür gibt, suche ich genau danach, aber ein Tool von Drittanbietern oder ein Makro funktionieren auch.


4
2017-11-04 19:21


Ursprung




Antworten:


Dies kann nicht einfach durchgeführt werden, da Visio keine nützliche .Copy-Methode für das Seitenobjekt in Visio bereitstellt.

Dies kann über VBA geschehen, aber es ist nicht so einfach, wie ich denke, dass es sein sollte.

Ich füge etwas VBA-Code ein, den Sie verwenden können, indem Sie ein Array von Dateinamen übergeben, das auf allen Seiten in jedem dieser Dokumente kopiert wird. Beachten Sie jedoch, dass keine Shapesheet-Werte auf Seitenebene kopiert werden, da dies für mich jetzt zu aufwendig ist. Wenn Sie also nur Shapes kopieren, sollte das für Sie funktionieren. (Mit dem TryMergeDocs-Sub habe ich das getestet. und es scheint gut zu funktionieren) ...

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



Vielen Dank. Ich werde das heute ausprobieren! Wenn es funktioniert, werde ich zurückkommen, um Sie zu stimmen und die Antwort wie versprochen anzunehmen. - David Stratton
Bis zu einem gewissen Grad nekrierend, aber Sie können das verwenden Visio.ActivePage.SelectAll Methode statt durch sie zu fahren - David Colwell


Ich hatte ähnliches Problem, aber wollte auch den Hintergrund einer Seite kopieren. Daher habe ich die folgende Zeile in CopyPage-Prozedur hinzugefügt:

DestPage.Background = CopyPage.Background

Und fügte eine weitere Schleife über CurrDoc.Pages in MergeDocuments-Prozedur hinzu:

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

Die Prozedur SetBackground ist sehr einfach:

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

Und das hat funktioniert. Vielleicht finden sie es nützlich.


3
2018-02-01 16:47



+1. Nette Ergänzung, und ich wette, es wird hilfreich sein! - David Stratton


Vielen Dank für die gemeinsame Nutzung einer Lösung.

Lass mich die "Zusammenführung" von Jons Lösung und dem Zusatz von user26852 kopieren / einfügen :-)

Das ist das volle Makro, das für mich wie ein Zauber wirkte:

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

Eine Sache allerdings: Ich musste die "Sperre" für eine Ebene, die ich auf meinen Seiten hatte, erneut prüfen. Ich gehe davon aus, dass die "Layer-Eigenschaften" nicht vom Makro propagiert werden. Für mich war das keine große Sache, alle meine Hintergrundschichten wieder zu sperren. Aber für jemand anderen könnte es sich lohnen, ein bisschen weiter darüber zu schauen, wie man die Layereigenschaften auch kopiert / einfügt.


2
2017-09-03 13:53





Ich bin auf dieses Problem gestoßen und habe das Problem mit der Funktion Objekt einfügen überwunden.

  • Wählen Sie "Einfügen" aus der Symbolleiste
  • Wählen Sie "Objekt" aus dem Dropdown-Menü
  • Wählen Sie 'Aus Datei erstellen'
  • Wählen Sie "Microsoft Office Visio-Zeichnung"
  • Wählen Sie "Link zur Datei"
  • Klicken Sie auf "Durchsuchen"
  • Wählen Sie die Datei aus, die Sie einfügen möchten
  • Klicken Sie auf "Öffnen"
  • OK klicken'

Die VSD-Datei wird als ein Bild eingefügt, das durch Öffnen der Originaldatei oder durch Doppelklicken und Öffnen von Visio für das Objekt aktualisiert werden kann.


1
2018-06-27 18:28





Laden Sie Visio Super Utilities von:
http://www.sandrila.co.uk/visio-utilities/ 

Die Installation erhält die Datei install_readme.txt im heruntergeladenen Paket. Bitte beachten Sie die Installation. Nachdem Visio Super Utilities installiert wurde, führen Sie die folgenden Schritte aus, um Visio-Dokumente zu kombinieren

  1. Öffnen Sie die 2 Visio-Dokumente, die Sie kombinieren möchten.
  2. Gehen Sie zu Add-Ins -> SuperUtils -> Dokument -> Dokument in anderes Dokument kopieren

Wiederholen Sie dies für jedes Quelldokument.


1
2018-03-18 09:55





Danke für das extrem hilfreiche Skript. Ich habe einige Zeilen hinzugefügt, um das Skript kompatibler mit dem Process Engineering Addon zu machen. (Dies wird aktiviert, wenn Sie Rohre und Ventile zeichnen und Dinge mit visio) Um die automatische Nummerierung oder Markierung beim Ausführen des vba-Skripts zu deaktivieren, fügen Sie am Anfang folgende Zeilen hinzu:

' 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

und diese am Ende:

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

Ich denke, Sie brauchen das nur, wenn Sie das Skript mit einem bereits existierenden Dokument als Ziel ausführen. Vielleicht wird jemand anderes das hilfreich finden.


0
2018-06-15 16:17