Stencil not saving when editing Masters

[Jake Stride]

I'm having problems with the following macro saving. I'm trying to edit the masters on a number of stencils programmatically. The attached macro iterates through and does the changes to the masters if I already have the stencil in Edit Mode (red star) then after running I get the disk save icon. However if I haven't set the stencil to edit the macro runs but the changes aren't kept.

I have a feeling it's something to do with the way I'm opening the master copy but after several hours debuggin I'm pulling out my hair. Any help please?

Code Select Expand



Sub Generate()
    Dim intCounter As Integer
    Dim intMasterCount As Integer
    Dim vsoApplication As Visio.Application
    Dim vsoCurrentDocument As Visio.Document
    Dim vsoMasters As Visio.Masters

    Set vsoApplication = GetObject(, "visio.application")
 
    If vsoApplication Is Nothing Then
        MsgBox "Microsoft Office Visio is not loaded"
        Exit Sub

    End If


    Set vsoCurrentDocument = vsoApplication.ActiveDocument

    If vsoCurrentDocument Is Nothing Then
        MsgBox "No document is loaded"
        Exit Sub
    End If
   
    Debug.Print "--- Warming up the ion drive ---"
   
    ' Loop Through Doc
    For Each doco In vsoCurrentDocument.Application.Documents
   
        ' Check if it is a stencil
        If doco.Type = visTypeStencil Then
            ' This is a hack and needs to be fixed, only applies generation to Architmate stencil
            If (Left(doco.Title, 7) = "TEST - ") And (Right(doco.Title, 13) <> "Relationships") And (doco.Title <> "TEST - Footer") Then
                Debug.Print "--- Starting on " & doco.Title & " ---"
                ' Get each master on the stencil
                For Each archiMaster In doco.Masters
                    Dim vsoMaster As Visio.Master
                    Set vsoMaster = archiMaster
                    Debug.Print "- Updating Master: "; vsoMaster.name
                   
                    ' Dim Shp As Visio.Shape
                    ' Set Shp = GetShapeByName("Sheet.7", vsoMaster.Shapes)

                    EditMaster vsoMaster
                   
                    'If Not (Shp Is Nothing) Then
                    '    Debug.Print Shp.name
                    '    If Shp.name = vsoMaster.name Then
                    '        Debug.Print "Editing Known Master: " & Shp.name
                    '    End If
                    ' End If
                   
                    ' Set Shp = Nothing
                Next
            ElseIf (Right(doco.Title, 13) <> "Relationships") Then
                ' Alert if we can't parse a template that isn't a relationship one
                MsgBox "Template not parsed: " & doco.Title
            End If
        End If
    Next


   
End Sub

Public Function GetShapeByName(name As String, shps As Visio.Shapes) As Visio.Shape

  On Error GoTo Err
  Set GetShapeByName = shps(name)
 
  Exit Function
 
Err:
  Set GetShapeByName = Nothing
  Exit Function
End Function

Sub EditMaster(ByRef mst As Master)
    'http://www.visguy.com/2008/02/25/edit-visio-masters-programmaticallythe-right-way/
    Dim mstCopy As Visio.Master ' an object to hold a copy of mst...
    Dim Shp As Visio.Shape
    Dim shps As Visio.Shapes

    Set mstCopy = mst.Open
    Set shps = mstCopy.Shapes
   
    Set Shp = GetShapeByName("Sheet.5", shps)
                   
    If Not (Shp Is Nothing) And Shp.name <> "Group" Then
        Debug.Print "-- Checking Shape: " & Shp.name & " (Original Master - " & mst.name & ")"
               
        If ((Shp.name = mst.name) Or (mst.name = "Group")) Then
            Debug.Print "-- Editing Known Master (Generic): " & Shp.name
           
            'If (mst.name = "Group") Then
            '   Set Shp = shps("Sheet.5")
            'End If
           
            Set Layers = mstCopy.Layers
            Set Layer = Layers.Add(Shp.name)
            Layer.Add Shp, 1
           
            Debug.Print "Adding Layer"
           
            AddUDC Shp, "Primary_Colour_1", "RGB(230,84,0)"
           
           
            AddAction Shp, "Primary_Colour_1", "SETF(GetRef(User.Colour_To_Use),1)", "Orange", "003", "IF(User.Colour_To_Use = 1, TRUE, FALSE)", False
                       
        End If
       
        If ((Shp.name = mst.name) And (mst.name <> "Group")) Then
            Debug.Print "-- Editing Known Master: " & Shp.name
           
            'Set Shp = shps("Sheet.5")
   
            AddUDC Shp, "Box_Icon_Alignment", """left"""
           
            'Set up the actions
            AddAction Shp, "Icon_Left", "SETF(GetRef(User.Box_Icon_Alignment),""""""left"""""")&SETF(GetRef(Controls.Row_1),Controls.Row_1*-1)", "Icon Left", "002", "IF(STRSAME(User.Box_Icon_Alignment,""left""),TRUE,FALSE)", False
           
        ' Make the assumption that a connector has a Begin X which we don't want to be alerted to
        ElseIf Not (Shp.CellExistsU("BeginX", False)) Then
            Debug.Print "Master (" & mst.name & ") does not match shape: " & Shp.name
            MsgBox "Master (" & mst.name & ") does not match shape: " & Shp.name
        End If
    End If
                   
                    ' Set Shp = Nothing
    ' Check Sheet.7 Exists
        ' Get the name of the Sheet.7
        ' If Sheet.7.name is in array of shapes to update then apply updates
   
    Set Shp = Nothing

    mstCopy.Close


  Set mstCopy = Nothing
  Set mst = Nothing


End Sub


Sub AddUDC(ByRef Shp As Shape, UDCName As String, UDCVal, Optional UDCPrompt As String = "")

    If Not (Shp.SectionExists(visSectionUser, False)) Then
        Shp.AddSection (visSectionUser)
    End If

    If Not (Shp.CellExistsU("User." & UDCName, False)) Then
        ' Debug.Print "-- Adding Row: User." & UDCName
        Shp.AddNamedRow visSectionUser, UDCName, visTagDefault
    ' We don't want to change the default colour
    ElseIf UDCName <> "Colour_To_Use" Then
        ' Debug.Print "--- Updating (" & Shp.name & ") " & UDCName & " to: " & UDCVal
        Shp.Cells("User." & UDCName).FormulaForceU = UDCVal
    End If
   
   
    If UDCPrompt <> "" Then
        Shp.Cells("User." & UDCName & ".Prompt").FormulaU = Chr(34) & UDCPrompt & Chr(34)
        ' Debug.Print "-- Updating " & UDCName & " prompt to: " & UDCPrompt
    End If
End Sub

Sub AddAction(ByRef Shp As Shape, ActionName As String, ActionVal, ActionMenu, ActionSortKey As String, ActionChecked, ActionReadOnly)

    If Not (Shp.SectionExists(visSectionAction, False)) Then
        Shp.AddSection (visSectionAction)
    End If

    If Not (Shp.CellExistsU("Actions." & ActionName, False)) Then
        ' Debug.Print "-- Adding Row: Actions." & ActionName
        Shp.AddNamedRow visSectionAction, ActionName, visTagDefault
    End If
    ' Debug.Print "--- Updating (" & Shp.name & ") " & ActionName & ".Action to: " & ActionName
    Shp.Cells("Actions." & ActionName & ".Action").FormulaForceU = ActionVal
   
    ' Debug.Print "--- Updating (" & Shp.name & ") " & ActionName & ".Menu to: " & ActionMenu
    Shp.Cells("Actions." & ActionName & ".Menu").FormulaForceU = Chr(34) & ActionMenu & Chr(34)
   
    ' Debug.Print "--- Updating (" & Shp.name & ") " & ActionName & ".SortKey to: " & ActionSortKey
    Shp.Cells("Actions." & ActionName & ".SortKey").FormulaForceU = Chr(34) & ActionSortKey & Chr(34)
   
    ' Debug.Print "--- Updating (" & Shp.name & ") " & ActionName & ".Checked to: " & ActionChecked
    Shp.Cells("Actions." & ActionName & ".Checked").FormulaForceU = ActionChecked
   
    ' Debug.Print "--- Updating (" & Shp.name & ") " & ActionName & ".ReadOnly to: " & ActionReadOnly
    Shp.Cells("Actions." & ActionName & ".ReadOnly").FormulaForceU = ActionReadOnly
   
End Sub