I know I can do this manually by using copy/paste but I'm looking for a simpler way.
Does anyone know of a quick and easy way to merge Visio documents? I have several Visio vsd files, all of which are the same internal document type (Flowchart - US Units). Each of these has between 1 and 15 pages. I'd like to combine them all into one Visio file.
I'm using Visio for Enterprise Architects (11.4301.8221) so if there's a procedure for doing it in that version, that's what I'm looking for, but a 3rd party tool or a macro would work as well.
06 Answers
This can't easily be done, because Visio doesn't provide a nice .Copy method on the page object in Visio.
This can be done through VBA, but it is not as straightforward as I think it should be.
I'll paste some VBA code below that you can use by passing an array of filenames in that will copy in all pages in each of those documents. Note however it will not copy any page-level shapesheet values, as that's just too involved for me now...so if you're simply copying shapes, this should work for you (The TryMergeDocs sub is what I used to test this, and its seems to work well)...
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 SubI had similar problem, but wanted also to copy background of a page. Therefore I added the following line in CopyPage procedure:
DestPage.Background = CopyPage.BackgroundAnd added another loop over CurrDoc.Pages in MergeDocuments procedure:
For Each CurrPage In CurrDoc.Pages Set CurrDestPage = DestDoc.Pages(CurrPage.Name) SetBackground CurrPage, CurrDestPage
Next CurrPageThe procedure SetBackground is very 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 SubAnd this worked. Maybe sb will find it useful.
1Thanks all for sharing a solution.
Let me copy/paste the "merge" of Jon's solution and user26852's addition :-)
This is the full macro that worked like a charm for me:
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 SubOne thing though: I had to re-check "lock" on a layer I had on my pages. I assume the "layer properties" do not get propagated by the Macro. For me that wasn't a big deal to re-lock all my background layers. But for someone else it might be worth it to look a little bit further on how to copy/paste the layer properties too.
I ran into this issue, and overcame the problem using the Insert Object function.
- Select 'Insert' from the toolbar
- Select 'Object' from the drop down menu
- Select 'Create from file'
- Select 'Microsoft Office Visio Drawing'
- Select 'Link to file'
- Click on 'Browse'
- Select the file you want to insert
- Click 'Open'
- Click 'OK'
The VSD file will be inserted as a picture, that can be updated by opening the original file, or by double clicking and opening Visio for the 'Object'.
Download Visio Super Utilities from:
The installation is given the install_readme.txt in the downloaded package. Please refer to the installation. After Visio Super Utilities is installed, use the following steps to combine Visio documents
- Open the 2 Visio documents you wish to combine.
- Go to Add-Ins -> SuperUtils -> Document -> Copy Document to other Document
Repeat this for each source document.
1Thanks for the extremly helpful script. I added some lines, to make the script more compatible with the process engineering addon. (This gets activated if you are drawing pipes and valves and stuff with visio) In order to disable automatic numbering or tagging when running the vba-script add the following lines at the beginning:
' 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 Ifand these at the end:
If (PEEnabled) Then DestDoc.DocumentSheet.Cells("User.PEUserOptions") = prevPEUserOptions
End IfI think you will only need this, if you are running the script with an already existing document as target. Perhaps somebody else will find this helpful.
