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.