Modify the array then execute as a macro!
- Snag a list of your Visio items in Powershell:
ls | select "FullName"
- Make the array (roughly) in Word by replacing
^p
with:
", _^p "
You might get “too many line continuations”, just put a few files on the same line (removing the underscore).
- Add them to the array in this macro and use it in a new Visio document:
Private Sub TryMergeDocs() Dim Docs() As Variant Docs = Array("C:\Users\Mathew\Desktop\visio1.vsdx", "C:\Users\Mathew\Desktop\visio2.vsdx") 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