Question Fusionner des fichiers Visio


Je sais que je peux le faire manuellement en utilisant le copier / coller mais je cherche un moyen plus simple.

Est-ce que quelqu'un connaît un moyen rapide et facile de fusionner des documents Visio? J'ai plusieurs fichiers Visio vsd, qui sont tous du même type de document interne (Organigramme - Unités américaines). Chacun d'entre eux a entre 1 et 15 pages. Je voudrais les combiner tous en un seul fichier Visio.

J'utilise Visio pour Enterprise Architects (11.4301.8221) donc s'il existe une procédure pour le faire dans cette version, c'est ce que je recherche, mais un outil tiers ou une macro fonctionnerait aussi bien.


4
2017-11-04 19:21


origine




Réponses:


Cela ne peut pas être facilement fait, car Visio ne fournit pas une méthode .Copy agréable sur l'objet de la page dans Visio.

Cela peut se faire par VBA, mais ce n’est pas aussi simple que je le pense.

Je vais coller un code VBA ci-dessous que vous pouvez utiliser en passant un tableau de noms de fichiers dans ce qui copiera dans toutes les pages de chacun de ces documents. Notez cependant que cela ne copiera aucune valeur de feuille de forme au niveau de la page, car cela est trop compliqué pour moi maintenant ... donc si vous copiez simplement des formes, cela devrait fonctionner pour vous (le sous-programme TryMergeDocs est ce que j'ai utilisé pour et ça semble bien fonctionner) ...

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



Je vous remercie. Je vais essayer ça aujourd'hui! Si ça marche, je serai de retour pour vous voter et accepter la réponse comme promis. - David Stratton
Necroing dans une certaine mesure, mais vous pouvez utiliser le Visio.ActivePage.SelectAll méthode au lieu de faire du vélo à travers eux - David Colwell


J'ai eu un problème similaire, mais je voulais aussi copier le fond d'une page. J'ai donc ajouté la ligne suivante dans la procédure CopyPage:

DestPage.Background = CopyPage.Background

Et ajouté une autre boucle sur CurrDoc.Pages dans la procédure MergeDocuments:

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

La procédure SetBackground est très simple:

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

Et cela a fonctionné. Peut-être que sb le trouvera utile.


3
2018-02-01 16:47



+1. Belle addition, et je parie que ce sera utile! - David Stratton


Merci à tous pour partager une solution.

Permettez-moi de copier / coller le "fusionner" de la solution de Jon et de l'ajout de user26852 :-)

C'est la macro complète qui a fonctionné comme un charme pour moi:

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

Une chose cependant: j'ai dû re-vérifier "lock" sur un calque que j'avais sur mes pages. Je suppose que les "propriétés de couche" ne sont pas propagées par la macro. Pour moi, ce n'était pas une grosse affaire de refermer tous mes calques d'arrière-plan. Mais pour quelqu'un d'autre, cela vaut la peine de chercher un peu plus sur la manière de copier / coller les propriétés du calque.


2
2017-09-03 13:53





J'ai rencontré ce problème et j'ai surmonté le problème en utilisant la fonction Insérer un objet.

  • Sélectionnez "Insérer" dans la barre d'outils
  • Sélectionnez "Objet" dans le menu déroulant
  • Sélectionnez 'Créer à partir d'un fichier'
  • Sélectionnez 'Microsoft Office Visio Drawing'
  • Sélectionnez 'Link to file'
  • Cliquez sur 'Parcourir'
  • Sélectionnez le fichier que vous souhaitez insérer
  • Cliquez sur 'Ouvrir'
  • Cliquez sur OK'

Le fichier VSD sera inséré comme une image, qui peut être mis à jour en ouvrant le fichier d'origine, ou en double-cliquant et en ouvrant Visio pour «l'objet».


1
2018-06-27 18:28





Téléchargez Visio Super Utilities depuis:
http://www.sandrila.co.uk/visio-utilities/ 

L'installation reçoit le fichier install_readme.txt dans le package téléchargé. Veuillez vous référer à l'installation. Une fois que Visio Super Utilities est installé, utilisez les étapes suivantes pour combiner des documents Visio

  1. Ouvrez les 2 documents Visio que vous souhaitez combiner.
  2. Allez dans les compléments -> SuperUtils -> Document -> Copier le document dans un autre document

Répétez cette opération pour chaque document source.


1
2018-03-18 09:55





Merci pour le script extrêmement utile. J'ai ajouté quelques lignes pour rendre le script plus compatible avec l'addon à l'ingénierie de processus. (Ceci est activé si vous dessinez des tuyaux et des vannes et des choses avec visio) Afin de désactiver la numérotation ou le marquage automatique lors de l'exécution du script vba, ajoutez les lignes suivantes au début:

' 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

et ceux-ci à la fin:

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

Je pense que vous n'en aurez besoin que si vous exécutez le script avec un document déjà existant comme cible. Peut-être que quelqu'un d'autre trouvera cela utile.


0
2018-06-15 16:17