Automatically Show ShapeSheet of Current Shape - vba

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:
Press Alt+F8 keys and run St sub-routine.
Open ShapeSheet window for selected shape.
Select another shapes and so on...
Update with your code i get error like this.