自动显示当前形状的ShapeSheet

Question

我做了大量的Visio ShapeSheet编辑，当我选择新的形状时，自动切换到当前形状的工作表将节省我大量的时间。让我们假设我只打开了一个ShapeSheet，只选择了一个形状，并且所有的窗口都停靠在Visio上(我没有RegEdit的能力来改变这一点)。

到目前为止，我已经在ThisDocument中获得了以下VBA代码

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

(以上代码是从内存中编写的，因为我目前无法访问Visio。请原谅任何小错误)

这段代码可以工作，但我希望得到一个不那么紧张的结果。在这种情况下，Application.ScreenUpdating = False似乎什么也不做:我仍然简要地看到旧的ShapeSheet关闭，绘图窗口调整大小，然后是新的ShapeSheet打开。交换顺序(打开新窗口>关闭旧窗口)稍微少了一些混乱，但不是很好。相反，使用Application.Minimize来隐藏交换是稍微好一些的，但仍然不是一个平稳的过渡。

我的问题是：是否有更流畅的方式显示活动形状的ShapeSheet?

Answer 1

这个代码在我身边工作！我只是添加了与相关的变量。

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

我的解决办法：

Alt+F8

• 按下键并运行St sub-routine.

1. Open ShapeSheet窗口，用于选定的shape.
2. Select、其他形状等.

​