Visio

Combine Visio Files – VBA

This bit of code will combined all the lists you state in the array and merge them into one visio file.
The part in Bold is the only place the array file locations is set, amend this to your files.
Enjoy
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