After some trail and error from my previous post we went through batch converting 300+ Visio vsd files over to vsdx. Overall the files size was reduced by 70%, dropping from over 6 Gb to around 2Gb, and allowing the files to open/save to the network a lot quicker. The only caveat I found was Visio 64-bit is the best way to do this and is most stable, especially with files over 25Mb. Above about 33 – 35Mb and the 32-bit version would randomly crash. With that said I added in some basic error detection to skip corrupt Visio files, some user variables to keep personal info or remove along with deleting the original file or not, and the ability to do sub directories. Here is the modified code:

Public FilesAttempted As Integer
 Public FilesConverted As Integer
 Public FilesDeleted As Integer
 Public FilesSkipped As String

 Sub ConvertToVsdx()
   FilesAttempted = 0
   FilesConverted = 0
   FilesDeleted = 0
   FilesSkipped = ""
   Dim FileSystem As Object
   Set FileSystem = CreateObject("Scripting.FileSystemObject")
   Dim HostFolder As String
   Dim DeleteOriginal As Boolean
   Dim RemovePersonal As Boolean

   ''' HostFolder is directory to start it.  Change to your base directory.
   HostFolder = "T:\"
   ''' DeleteOriginal will delete the original file as long as the VSDX was created.  Either True or False
   DeleteOriginal = True
   ''' RemovePersonal will remove personal information from the file.  Reduces the size a little but you might want to keep the original info
   RemovePersonal = False

   DoFolder FileSystem.GetFolder(HostFolder), DeleteOriginal
   MsgBox "Conversion complete! " & vbCrLf & vbCrLf & "Files attempted: " & FilesAttempted & vbCrLf & "Files converted: " & FilesConverted & vbCrLf & "Files deleted: " & _
         FilesDeleted & vbCrLf & "Files with issues: " & vbCrLf & FilesSkipped, vbOKOnly + vbInformation, "Conversion Complete"
 End Sub
 
Sub DoFolder(Folder, DeleteOriginal)
     On Error GoTo ErrHandler:
     Dim SubFolder
     For Each SubFolder In Folder.SubFolders
         DoFolder SubFolder, DeleteOriginal
     Next
     Dim File
     For Each File In Folder.Files
         ' For each file name sure its a vsd and not a temp file
         If ((Right(File, 3) = "vsd") And (Right(File, 4) <> "~vsd")) Then
             FilesAttempted = FilesAttempted + 1
             ' Open the file
             Application.Documents.Open File
             ' Remote personal info if set
             If RemovePersonal = True Then
                 Application.ActiveDocument.RemovePersonalInformation = True
             End If
            ' Loop through each master then check across pages to see if it is used         
            Index = Application.ActiveDocument.Masters.Count
            While Index > 0
              bMasterUsed = False
              Set oMaster = Application.ActiveDocument.Masters.Item(Index)
                For Each oPage In Application.ActiveDocument.Pages
                  For Each oShape In oPage.Shapes
                    If oMaster.Name = oShape.Name Then
                      bMasterUsed = True
                    End If
                  Next
                Next
                ' if Not used delete it from the document stencil
                If bMasterUsed = False Then
                  oMaster.Delete
                End If
                Index = Index - 1
              Wend

              ' Save as a vsdx and increase our counter
              Application.ActiveDocument.SaveAs File & "x"
              Application.ActiveDocument.Close
              FilesConverted = FilesConverted + 1

              ' Delete the original if set and the new vsdx exists
              If ((DeleteOriginal = "True") And (FileExists(File & "x"))) Then
                SetAttr File, vbNormal
                Kill File
                FilesDeleted = FilesDeleted + 1
              End If
NextFile:
        End If
    Next
Done:
    Exit Sub

ErrHandler:
Debug.Print "Error encountered. Error number: " & Err.Number & " - Error description: " & Err.Description
  If File <> "" Then
    FilesSkipped = FilesSkipped & File & vbCrLf
    GoTo NextFile:
  End If
End Sub

Function FileExists(ByVal FileToTest As String) As Boolean
    FileExists = (Dir(FileToTest) <> "")
End Function

If you use this please let me know how it goes or any tweaks that need to be made.