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