Update to Batch Converting Visio Files

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.

Leave a Reply

Your email address will not be published. Required fields are marked *

This site uses Akismet to reduce spam. Learn how your comment data is processed.