Automatically Show ShapeSheet of Current Shape

Question

I do a lot of Visio ShapeSheet editing and it would save me a tremendous amount of time to automatically switch to the current shape's sheet when I select a new shape. Let's assume I only have 1 ShapeSheet open, only select 1 Shape, and have all the windows docked on the Visio app (I don't have RegEdit powers to change this).

So far, I've got the following VBA code in ThisDocument:

Private WithEvents vsoWin as Visio.Window

Private Sub ThisDocument_RunModeEntered(ByRef doc as IVDocument)
    'Just assume this is the correct window
    Set vsoWin = ActiveWindow
End Sub

Private Sub vsoWin_SelectionChanged(ByRef win as IVWindow)
    'If nothing is selected, leave
    If vsoWin.Selection.Count < 1 Then Exit Sub

    'Look for a ShapeSheet (Window.SubType = 3)
    For each oWin in Application.Windows
        If oWin.Subtype = 3 Then
            Application.ScreenUpdating = False    'Pause screen to prevent jitter
            oWin.Close                            'Delete old ShapeSheet
            vsoWin.Selection(1).OpenSheetWindow   'Make new ShapeSheet
            Application.ScreenUpdating = True     'Update visuals
            Exit For                              'Stop looking for ShapeSheets
        End If
    Next
Exit Sub

(The above code is written from memory since I don't have access to Visio at the moment. Please forgive any minor errors)

This code works, but I'm hoping for a less jittery result. Application.ScreenUpdating = False doesn't seem to do anything in this case: I still briefly witness the old ShapeSheet closing, the drawing window resizing, then the new ShapeSheet opening. Swapping the order (open new window > close old window) is a little less chaotic, but not great. Using Application.Minimize to hide the swap instead is slightly better on the eyes, but still not a smooth transition.

My question: Is there a smoother way to display the active shape's ShapeSheet?

Answer 1

This code works at my side! I just add variable which related with Visio Application - vsoApp.

Private WithEvents vsoWin As Visio.Window
Private WithEvents vsoApp As Visio.Application

Sub st()
Set vsoWin = ActiveWindow ' initialize Window variable
Set vsoApp = Application ' initialize Application variable
End Sub

Private Sub ThisDocument_RunModeEntered(ByRef doc As IVDocument)
    'Just assume this is the correct window
    Set vsoWin = ActiveWindow
End Sub

Private Sub vsoApp_SelectionChanged(ByVal Window As IVWindow)
    'If nothing is selected, leave
    
    If vsoWin.Selection.Count < 1 Then Exit Sub

    'Look for a ShapeSheet (Window.SubType = 3)
    For Each oWin In Application.Windows
        If oWin.SubType = 3 Then
            Application.ScreenUpdating = False    'Pause screen to prevent jitter
            oWin.Close                            'Delete old ShapeSheet
            vsoWin.Selection(1).OpenSheetWindow   'Make new ShapeSheet
            Application.ScreenUpdating = True     'Update visuals
            Exit For                              'Stop looking for ShapeSheets
        End If
    Next

End Sub

My workaround:

1. Press Alt+F8 keys and run St sub-routine.
2. Open ShapeSheet window for selected shape.
3. Select another shapes and so on...
   

---

Update with your code i get error like this.