Home » Questions » Computers [ Ask a new question ]

Merge Visio files

Merge Visio files

I know I can do this manually by using copy/paste but I'm looking for a simpler way.

Asked by: Guest | Views: 77
Total answers/comments: 3
Guest [Entry]

"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 Sub"
Guest [Entry]

"Thanks 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 Sub

One 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."
Guest [Entry]

"Thanks 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 If

and these at the end:

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

I 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."