検索結果がどこにあるか分からない事件 ② 拡大してみる

昨日は、検索して選択したセルがどこにあるかを直感的に理解するために、選択したセルが一番左上になるようにしてみた。
infoment.hatenablog.com

しかしこれだと、任意のセルをポチポチと選ぶたび派手にスクロールしてしまい、とても使い勝手が悪い。そこでまず、この機能を切り替え式にしてみよう。
f:id:Infoment:20190627225347p:plain

手始めとして、今までにも何度か登場した、右クリックメニューを追加・削除するクラスモジュールを準備する。

クラスモジュール（MenuControlClass）

Sub AddMenu(myCaption As String, myAction As String)
    Dim Newb(1)
    Set Newb(0) = Application.CommandBars("Cell").Controls.Add()
    Set Newb(1) = Application.CommandBars("List Range Popup").Controls.Add()

    Dim i As Long
        For i = 0 To 1
            Newb(i).Caption = myCaption
            Newb(i).OnAction = myAction
            Newb(i).BeginGroup = False
        Next i
End Sub


Sub DelMenu()
    Application.CommandBars("Cell").Reset
    Application.CommandBars("List Range Popup").Reset
End Sub

次いで、標準モジュールに、以下のサブプロシージャなどを実装する。

標準モジュール

拡大表示モード切替用変数

Public ScopeMode As Boolean

ファイル起動・終了に合わせたメニューの追加・削除

Sub Auto_Open()
    ScopeMode = False
    Call ChangeMenuMode
End Sub

Sub Auto_Close()
    Dim MCC As MenuControlClass
    Set MCC = New MenuControlClass
        MCC.DelMenu
End Sub

拡大表示モードの交互反転用

Sub ChangeScopeMode()
    ScopeMode = Not ScopeMode
    If ScopeMode = False Then
        ActiveSheet.UsedRange.Rows(1).Select
        ActiveWindow.Zoom = True
        If ActiveWindow.Zoom < 30 Then
            ActiveWindow.Zoom = 30
        End If
        Range("A1").Select
    End If
    Call ChangeMenuMode
End Sub

Sub ChangeMenuMode()
    Dim MCC As MenuControlClass
    Set MCC = New MenuControlClass
        MCC.DelMenu
        MCC.AddMenu myCaption(ScopeMode), "ChangeScopeMode"
End Sub

Private Function myCaption(scope_mode As Boolean) As String
    Select Case scope_mode
        Case True
            myCaption = "選択拡大モード：ＯＦＦ"
        Case False
            myCaption = "選択拡大モード：ＯＮ"
    End Select
End Function

最後に、対象となるシートにSelectionChangeイベントを設定する。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If ScopeMode = False Then Exit Sub

    Application.EnableEvents = False
    ActiveWindow.Zoom = 250
    Application.Goto Selection, True

    Application.EnableEvents = True
End Sub