Search code examples
vbavisio

Remove all macros from a visio 2013 file


I have a Viso 2013 .vstm file that launches a VBA macro on document creation (template instanciation when a user opens the template manually). This macro populates the created drawing from a datasource. When finished, I would like to save programatically (from VBA) the drawing that has been generated as a .vsdx file, i.e. with all VBA macros that were used to populate the drawing being removed.

My questions are:

  1. Is it possible to remove all macros programatically from a VBA macro (Visio 2013) which is in the .vstm file itself without causing the VBA Macro to fail and if yes, how can I do it ?

  2. If 1. is not possible, how can I force programatically Visio to save to .vsdx a drawing that has macros (i.e. save ignoring all macros)

  3. If 2. is not possible, how can I copy current drawing (everything except macros) to a new Drawing which should then be savable to .vsdx?

I have tried the following:

  1. Deleting all lines with VBProject.VBComponents.Item(index).CodeModule.DeleteLines causes the macro to fail with "End Function is missing" (I have checked and there is no missing End Function anywhere, my guess is that the macro probably deletes the code that hasn't been executed yet, which in turn causes this error)

  2. Save and SaveEX do not work either, I get a "VBProjects cannot be saved in macro-free files" error/message, even if I add a Application.AlertResponse = IDOK prior to the call to Save / SaveEx.

Here follows a sample code.

Private Sub RemoveVBACode()
    ' If document is a drawing remove all VBA code
    ' Works fine however execution fails as all code has been deleted (issue 1)
    If ActiveDocument.Type = visTypeDrawing Then
        Dim i As Integer
        With ActiveDocument.VBProject
            For i = .VBComponents.Count To 1 Step -1
                .VBComponents.Item(i).CodeModule.DeleteLines 1, .VBComponents.Item(i).CodeModule.CountOfLines
            Next i
        End With
        On Error GoTo 0
    End If
End Sub

Private Sub SaveAsVSDX(strDataFilePath As String)
    RemoveVBACode
    Application.AlertResponse = IDOK
    ' Next line fails at runtime (issue 2), the same occurs when using Save
    ThisDocument.SaveAsEx strDataFilePath, visSaveAsWS + visSaveAsListInMRU
    Application.AlertResponse = 0
End Sub

The code that starts the execution of the Macro is the following event:

' This procedure runs when a Visio document is
' created. I.e., when the template (.vstm) is opened.
Private Sub Document_DocumentCreated(ByVal Doc As IVDocument)
    ' ...
    SaveAsVSDX (strDataFilePath)
    ' ...
End Sub

Solution

  • I finally found a way to achieve what I wanted : generate a macro-less visio drawing, from a macro-enabled drawing.

    What IS NOT possible from my understanding :

    • Have vba code that removes modules / class modules that is launched through an event such as Document_DocumentCreated. The best I could achieve is to remove the content of ThisDocument vba visio object, but all code in modules / class modules were not removable (note that if the macro is called manually, everything works like a charm, but this was not what I wanted to achieve).
    • Saving a a drawing instanciated from a vstm template as a macro-less vsdx file.

    What IS possible (and is my solution to the third part of the question) :

    • Instead of loading datasource into the drawing instanciated from the vstm file, have the macro do the following:

      1. select all shapes that appear on the page of the drawing that has been instanciated
      2. group them
      3. copy them
      4. create a new Document
      5. setup the page of the new document (orientation, size, disable snapping and gluing)
      6. paste the group into the first page of the newly created document
      7. center the drawing on the new document
    • Then load the datasource into the newly created document and link data to existing Shapes

    • Finaly you can save the new document as vsdx

    With lots of shapes (more than 400) this takes some time (around 10 seconds), but it works.

    Here is the code of the class module that generates the document.

    Option Explicit
    'Declare private variables accessible only from within this class
    Private m_document As Document
    Private m_dataSource As DataSourceFile
    Private m_longDataRecordsetID As Long
    
    Public Function Document() As Document
        Set Document = m_document
    End Function
    
    Private Sub CreateDocument()
        ' I consider here that the active window is displaying the diagram to
        ' be copied
        ActiveWindow.ViewFit = visFitPage
        ActiveWindow.SelectAll
    
        Dim activeGroup As Shape
        Set activeGroup = ActiveWindow.Selection.Group
        activeGroup.Copy
        ActiveWindow.DeselectAll
    
        Set m_document = Application.Documents.Add("")
        ' I need an A4 document
        m_document.Pages(1).PageSheet.CellsSRC(visSectionObject, visRowPage, visPageWidth).FormulaU = "297 mm"
        m_document.Pages(1).PageSheet.CellsSRC(visSectionObject, visRowPage, visPageHeight).FormulaU = "210 mm"
        m_document.Pages(1).PageSheet.CellsSRC(visSectionObject, visRowPrintProperties, visPrintPropertiesPageOrientation).FormulaForceU = "2"
        m_document.Pages(1).PageSheet.CellsSRC(visSectionObject, visRowPrintProperties, visPrintPropertiesPaperKind).FormulaForceU = "9"
        m_document.SnapEnabled = False
        m_document.GlueEnabled = False
        m_document.Pages(1).Paste
        m_document.Pages(1).CenterDrawing
    End Sub
    
    Private Sub LoadDataSource()
        Dim strConnection As String
        Dim strCommand As String
        Dim vsoDataRecordset As Visio.DataRecordset
        strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                           & "User ID=Admin;" _
                           & "Data Source=" + m_dataSource.DataSourcePath + ";" _
                           & "Mode=Read;" _
                           & "Extended Properties=""HDR=YES;IMEX=1;MaxScanRows=0;Excel 12.0;"";" _
                           & "Jet OLEDB:Engine Type=34;"
        strCommand = "SELECT * FROM [Data$]"
        Set vsoDataRecordset = m_document.DataRecordsets.Add(strConnection, strCommand, 0, "Data")
        m_longDataRecordsetID = vsoDataRecordset.ID
    End Sub
    
    Private Function CheckDataSourceCompatibility() As Boolean
        Dim visRecordsets As Visio.DataRecordsets
        Dim varRowData As Variant
        Set visRecordsets = m_document.DataRecordsets
        varRowData = visRecordsets(1).GetRowData(1)
        If varRowData(3) = "0.6" Then
            CheckDataSourceCompatibility = True
        Else
            MsgBox "Using invalid DataSource version, aborting. You shoud use data format version 0.6."
            CheckDataSourceCompatibility = False
        End If
    End Function
    
    Private Sub LinkDataToShapes()
        Application.ActiveWindow.SelectAll
        Dim ColumnNames(1) As String
        Dim FieldTypes(1) As Long
        Dim FieldNames(1) As String
        Dim IDsofLinkedShapes() As Long
        ColumnNames(0) = "ID"
        FieldTypes(0) = Visio.VisAutoLinkFieldTypes.visAutoLinkCustPropsLabel
        FieldNames(0) = "ID"
        Application.ActiveWindow.Selection.AutomaticLink m_longDataRecordsetID, ColumnNames, FieldTypes, FieldNames, 10, IDsofLinkedShapes
        Application.ActiveWindow.DeselectAll
    End Sub
    
    Public Function GenerateFrom(dataSource As DataSourceFile) As Boolean
        Set m_dataSource = dataSource
    
        'Store diagram services
        Dim DiagramServices As Integer
        DiagramServices = ActiveDocument.DiagramServicesEnabled
        ActiveDocument.DiagramServicesEnabled = visServiceVersion140
    
        ' Create a new document that contains only shapes
        CreateDocument
    
        ' Load datasource
        LoadDataSource
    
        ' Check datasource conformity
        If CheckDataSourceCompatibility Then
            ' Link data recordset to Visio shapes
            LinkDataToShapes
            GenerateFrom = True
        Else
            GenerateFrom = False
        End If
    
        'Restore diagram services
        ActiveDocument.DiagramServicesEnabled = DiagramServices
    End Function
    

    Hope this helps.