Excel -AddIn创建后退前进导航按钮

Thesaurus

1. Class ApplicationEventClass
========================================
Public WithEvents ExcelAppEvents As Application

Private Sub Class_Initialize()
    Set ExcelAppEvents = Application
End Sub

Private Sub Class_Terminate()
    Set ExcelAppEvents = Nothing
End Sub

Private Sub ExcelAppEvents_SheetActivate(ByVal Sh As Object)
    dictNavigate.Add dictNavigate.Keys(dictNavigate.Count - 1) + 1, ActiveCell.Address(external:=True)
    dictWbListCurrPos(Sh.Parent.Name) = dictNavigate.Count
    lLastPosBeforeManualActive = 0

    Call RefreshRibbonControl("btnBack")
    Call RefreshRibbonControl("btnForward")
End Sub

Private Sub ExcelAppEvents_SheetDeactivate(ByVal Sh As Object)
    Dim sRgAddr As String
    Dim sLastRgAddr As String
    Dim sWb As String
    Dim sSheet As String
    Dim sLastWb As String
    Dim sLastSheet As String
    Dim sActiveWbName As String
    Dim i As Long

    If lLastPosBeforeManualActive <= 0 Then Exit Sub

    sActiveWbName = ActiveWorkbook.Name

    sLastRgAddr = dictNavigate(lLastPosBeforeManualActive)
    sLastWb = Replace(Replace(Split(sLastRgAddr, "]")(0), "[", ""), "'", "")
    sLastSheet = Replace(Split(Split(sLastRgAddr, "]")(1), "!")(0), "'", "")

    For i = lLastPosBeforeManualActive + 1 To dictNavigate.Keys(dictNavigate.Count - 1)
        If Not dictNavigate.Exists(i) Then GoTo next_pos

        sRgAddr = dictNavigate(i)
        sWb = Replace(Replace(Split(sRgAddr, "]")(0), "[", ""), "'", "")
        sSheet = Replace(Split(Split(sRgAddr, "]")(1), "!")(0), "'", "")

        If sWb = sLastWb Then
            dictNavigate.Remove i
        End If
next_pos:
    Next
End Sub

Private Sub ExcelAppEvents_WorkbookActivate(ByVal Wb As Workbook)
    If Not dictWbListCurrPos.Exists(Wb.Name) Then dictWbListCurrPos.Add Wb.Name, 1

    If dictNavigate.Count <= 0 Then
        dictNavigate.Add 1, ActiveCell.Address(external:=True)
    Else
        dictNavigate.Add dictNavigate.Keys(dictNavigate.Count - 1) + 1, ActiveCell.Address(external:=True)
    End If
End Sub



2. AddIn Thisworkbook

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set ApplicationClass = Nothing
    Set dictNavigate = Nothing
    Set dictWbListCurrPos = Nothing

    Application.OnKey "%{LEFT}"
    Application.OnKey "%{RIGHT}"
End Sub


Private Sub Workbook_Open()
    Call sub_WorkBookInitialization

    Application.OnKey "%{LEFT}", "subMain_NavigateBack"
    Application.OnKey "%{RIGHT}", "subMain_NavigateForward"

    ThisWorkbook.Saved = True
End Sub

Public Sub sub_WorkBookInitialization()
    Set dictNavigate = New Dictionary
    Set dictWbListCurrPos = New Dictionary
    lLastPosBeforeManualActive = 0

    Call fConnectEventHandler
End Sub


3. Module A (Main Function )

Public dictNavigate As Dictionary
Public dictWbListCurrPos As Dictionary
Public lLastPosBeforeManualActive As Long


Public ApplicationClass As ApplicationEventClass

Function fConnectEventHandler()
    On Error Resume Next
    Set ApplicationClass = New ApplicationEventClass
End Function

Function fNavigateStackNextPositionToMoveBack(Optional ByRef sWb As String, Optional ByRef sSheet As String) As Long
    Dim lCurrPos As Long
    Dim lNextPos As Long
    Dim sRgAddr As String
    Dim sActiveWbName As String
    Dim i As Long

    lNextPos = 0
    If dictNavigate.Count <= 0 Then Exit Function

    sActiveWbName = ActiveWorkbook.Name
    lCurrPos = dictWbListCurrPos(sActiveWbName)

    For i = lCurrPos - 1 To dictNavigate.Keys(0) Step -1
        If Not dictNavigate.Exists(i) Then GoTo next_pos

        sRgAddr = dictNavigate(i)
        sWb = Replace(Replace(Split(sRgAddr, "]")(0), "[", ""), "'", "")
        sSheet = Replace(Split(Split(sRgAddr, "]")(1), "!")(0), "'", "")

        If sWb <> sActiveWbName Then GoTo next_pos

        If fSheetExists(sSheet, , Workbooks(sWb)) Then
            If sSheet = Workbooks(sWb).ActiveSheet.Name Then
                dictNavigate.Remove (i)
                GoTo next_pos
            Else
                lNextPos = i
                Exit For
            End If
        Else
            dictNavigate.Remove (i)
        End If
next_pos:
    Next

    fNavigateStackNextPositionToMoveBack = lNextPos
End Function
Function fNavigateStackNextPositionToMoveForWard(Optional ByRef sWb As String, Optional ByRef sSheet As String) As Long
    Dim lCurrPos As Long
    Dim lNextPos As Long
    Dim sRgAddr As String
    Dim sActiveWbName As String
    Dim i As Long

    lNextPos = 0
    If dictNavigate.Count <= 0 Then Exit Function

    sActiveWbName = ActiveWorkbook.Name
    lCurrPos = dictWbListCurrPos(sActiveWbName)
    If lCurrPos >= dictNavigate.Keys(dictNavigate.Count - 1) Then Exit Function

    For i = lCurrPos + 1 To dictNavigate.Keys(dictNavigate.Count - 1)
        If Not dictNavigate.Exists(i) Then GoTo next_pos

        sRgAddr = dictNavigate(i)
        sWb = Replace(Replace(Split(sRgAddr, "]")(0), "[", ""), "'", "")
        sSheet = Replace(Split(Split(sRgAddr, "]")(1), "!")(0), "'", "")

        If sWb <> sActiveWbName Then GoTo next_pos

        If fSheetExists(sSheet, , Workbooks(sWb)) Then
            If sSheet = Workbooks(sWb).ActiveSheet.Name Then
                dictNavigate.Remove (i)
                GoTo next_pos
            Else
                lNextPos = i
                Exit For
            End If
        Else
            dictNavigate.Remove (i)
        End If
next_pos:
    Next

    fNavigateStackNextPositionToMoveForWard = lNextPos
End Function

Sub subMain_NavigateBack()
    Dim lNextPos As Long
    Dim sWb As String
    Dim sSheet As String

    lNextPos = fNavigateStackNextPositionToMoveBack(sWb, sSheet)

    If lNextPos > 0 Then
        Application.EnableEvents = False

        Workbooks(sWb).Activate
        Workbooks(sWb).Worksheets(sSheet).Visible = xlSheetVisible
        Workbooks(sWb).Worksheets(sSheet).Activate

        Application.EnableEvents = True

        dictWbListCurrPos(sWb) = lNextPos
        lLastPosBeforeManualActive = lNextPos
    End If

    Call RefreshRibbonControl("btnBack")
    Call RefreshRibbonControl("btnForward")
End Sub

Sub subMain_NavigateForward()
    Dim lNextPos As Long
    Dim sWb As String
    Dim sSheet As String

    lNextPos = fNavigateStackNextPositionToMoveForWard(sWb, sSheet)
    If lNextPos > 0 Then
        Application.EnableEvents = False

        Workbooks(sWb).Activate
        Workbooks(sWb).Worksheets(sSheet).Visible = xlSheetVisible
        Workbooks(sWb).Worksheets(sSheet).Activate

        Application.EnableEvents = True

        dictWbListCurrPos(sWb) = lNextPos
        lLastPosBeforeManualActive = lNextPos
    End If

    Call RefreshRibbonControl("btnBack")
    Call RefreshRibbonControl("btnForward")
End Sub

Thesaurus

Module Ribbon:
================================================
Option Explicit

#If VBA7 And Win64 Then  'Win64
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
#Else
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef source As Any, ByVal length As Long)
#End If

Public gRibbonObj_Utility As IRibbonUI


'=============================================================
Sub RefreshRibbonControl(sControl As String)
    If gRibbonObj_Utility Is Nothing Then Call fGetRibbonReference
    Call gRibbonObj_Utility.InvalidateControl(sControl)
End Sub
Sub subRefreshRibbon()
    fGetRibbonReference.Invalidate
End Sub
Sub Excel_Utility_Onload(ribbon As IRibbonUI)
  Set gRibbonObj_Utility = ribbon
  
  fCreateAddNameUpdateNameWhenExists "nmRibbonPointer", ObjPtr(ribbon)
  'Names("nmRibbonPointer").RefersTo = ObjPtr(ribbon)
  
  gRibbonObj_Utility.ActivateTab "ERP_2010"
  ThisWorkbook.Saved = True
End Sub
Function fGetRibbonReference() As IRibbonUI
    If Not gRibbonObj_Utility Is Nothing Then Set fGetRibbonReference = gRibbonObj_Utility: Exit Function
   
    Dim objRibbon As Object
    Dim lRibPointer As LongPtr
   
    lRibPointer = [nmRibbonPointer]
    CopyMemory objRibbon, lRibPointer, LenB(lRibPointer)
   
    Set fGetRibbonReference = objRibbon
    Set gRibbonObj_Utility = objRibbon
    Set objRibbon = Nothing
End Function

'---------------------------------------------------------------------
Sub Button_onAction(control As IRibbonControl)
    Call fGetControlAttributes(control, "ACTION")
End Sub
Sub Utility_getImage(control As IRibbonControl, ByRef imageMso)
    Call fGetControlAttributes(control, "IMAGE", imageMso)
End Sub
Sub Utility_getLabel(control As IRibbonControl, ByRef label)
    Call fGetControlAttributes(control, "LABEL", label)
End Sub
Sub Utility_getSize(control As IRibbonControl, ByRef size)
    Call fGetControlAttributes(control, "SIZE", size)
End Sub
Sub Utility_getEnabled(control As IRibbonControl, ByRef val)
    If control.ID = "btnBack" Then
        val = CBool(fNavigateStackNextPositionToMoveBack > 0)
    ElseIf control.ID = "btnForward" Then
        val = CBool(fNavigateStackNextPositionToMoveForWard > 0)
    Else
    End If
End Sub
Sub Utility_getShowImage(control As IRibbonControl, ByRef ShowImage)
    Call fGetControlAttributes(control, "SHOW_IMAGE", ShowImage)
End Sub
Sub Utility_getSupertip(control As IRibbonControl, ByRef Supertip)
    Call fGetControlAttributes(control, "SUPERTIP", Supertip)
End Sub
Sub Utility_getScreentip(control As IRibbonControl, ByRef screentip)
    Call fGetControlAttributes(control, "SCREENTIP", screentip)
End Sub

'================== toggle button common function===========================================
Sub ToggleButtonToSwitchSheet_onAction(control As IRibbonControl, pressed As Boolean)
    Dim sht As Worksheet
    Set sht = fGetSheetByUIRibbonTag(control.Tag)
   
    If Not sht Is Nothing Then
        fToggleSheetVisibleFromUIRibbonControl pressed, sht, control
    End If
    Set sht = Nothing
End Sub

Sub ToggleButtonToSwitchSheet_getPressed(control As IRibbonControl, ByRef returnedVal)
    Dim sht As Worksheet
    Set sht = fGetSheetByUIRibbonTag(control.Tag)
   
    If sht Is Nothing Then
        returnedVal = False
    Else
        returnedVal = (sht.Visible = xlSheetVisible And ActiveSheet Is sht)
    End If
End Sub
Function fGetSheetByUIRibbonTag(ByVal asButtonTag As String) As Worksheet
    Dim sht As Worksheet
   
    If fSheetExistsByCodeName(asButtonTag, sht) Then
        Set fGetSheetByUIRibbonTag = sht
    Else
        MsgBox "The button's Tag is not corresponding to any worksheet in this workbook, please check the customUI.xml you prepared," _
            & " The design thought is that the button's tag is the name of a sheet, so that the common function ToggleButtonToSwitchSheet_onAction/getPressed can get a worksheet."
    End If
    Set sht = Nothing
End Function
Function fToggleSheetVisibleFromUIRibbonControl(ByVal pressed As Boolean, sht As Worksheet, control As IRibbonControl)
    If pressed Then
        If ActiveSheet.CodeName <> sht.CodeName Then
            fActiveVisibleSwitchSheet sht
        End If
    Else
        If ActiveSheet.CodeName <> sht.CodeName Then
            fActiveVisibleSwitchSheet sht
        Else
            fVeryHideSheet sht
        End If
    End If
   
    'fGetRibbonReference.InvalidateControl (control.id)
    fGetRibbonReference.Invalidate
End Function

'---------------------------------------------------------------------


'================ dev facilities ==============================================
Sub btnListAllFunctions_onAction(control As IRibbonControl)
    sub_ListAllFunctionsOfThisWorkbook
End Sub
Sub btnExportSourceCode_onAction(control As IRibbonControl)
    sub_ExportModulesSourceCodeToFolder
End Sub
Sub btnGenNumberList_onAction(control As IRibbonControl)
    sub_GenNumberList
End Sub
Sub btnGenAlphabetList_onAction(control As IRibbonControl)
    sub_GenAlpabetList
End Sub
Sub btnListAllActiveXOnCurrSheet_onAction(control As IRibbonControl)
    Sub_ListActiveXControlOnActiveSheet
End Sub
Sub btnResetOnError_onAction(control As IRibbonControl)
    sub_ResetOnError_Initialize
End Sub
'------------------------------------------------------------------------------

Function fGetControlAttributes(control As IRibbonControl, sType As String, Optional ByRef val)
    If Not (sType = "LABEL" Or sType = "IMAGE" Or sType = "SIZE" Or sType = "ACTION" Or sType = "SHOW_IMAGE" Or sType = "SCREENTIP" Or sType = "SUPERTIP") Then
        fErr "wrong param to fGetControlAttributes: " & vbCr & "sType=" & sType & vbCr & "control=" & control.ID
    End If
   
    Select Case control.ID
        Case "btnBack"
            Select Case sType
                Case "LABEL":       val = "后退" & vbCr & "(Alt + 向左箭头)"
                Case "IMAGE":       val = "ScreenNavigatorBack"
                Case "SIZE":        val = "true"    'large=true, normal=false
                Case "SHOW_IMAGE":  val = "true"
                Case "SUPERTIP":    val = ""
                Case "SUPERTIP":    val = ""
                Case "SCREENTIP":   val = ""
                Case "ACTION":      Call subMain_NavigateBack
            End Select
        Case "btnForward"
            Select Case sType
                Case "LABEL":   val = "前进" & vbCr & "(Alt + 向右箭头)"
                Case "IMAGE":   val = "ScreenNavigatorForward"
                Case "SIZE":        val = "true"    'large=true, normal=false
                Case "SHOW_IMAGE":  val = "true"
                Case "SUPERTIP":    val = ""
                Case "SUPERTIP":    val = ""
                Case "SCREENTIP":   val = ""
                Case "SUPERTIP":    val = ""
                Case "SCREENTIP":   val = ""
                Case "ACTION":  Call subMain_NavigateForward
            End Select
        Case "btnFilterBySelected"
            Select Case sType
                Case "LABEL":   val = "以所选过滤"
                Case "IMAGE":   val = "FilterBySelection"
                Case "SIZE":        val = "true"    'large=true, normal=false
                Case "SHOW_IMAGE":  val = "true"
                Case "SUPERTIP":    val = ""
                Case "SUPERTIP":    val = ""
                Case "SCREENTIP":   val = ""
               
                Case "ACTION":  Call Sub_FilterBySelectedCells
            End Select
        Case "btnSortBySelected"
            Select Case sType
                Case "LABEL":   val = "以所选排序"
                Case "IMAGE":   val = "SortUp"
                Case "SIZE":        val = "true"    'large=true, normal=false
                Case "SHOW_IMAGE":  val = "true"
                Case "SUPERTIP":    val = ""
                Case "SUPERTIP":    val = ""
                Case "SCREENTIP":   val = ""
               
                Case "ACTION":  Call sub_SortBySelectedCells
            End Select
            
        Case "btnRemoveFilter"
            Select Case sType
                Case "LABEL":   val = "清除过滤"
                Case "IMAGE":   val = "FilterClearAllFilters"
                Case "SIZE":        val = "true"    'large=true, normal=false
                Case "SHOW_IMAGE":  val = "true"
                Case "SUPERTIP":    val = ""
                Case "SUPERTIP":    val = ""
                Case "SCREENTIP":   val = ""
               
                Case "ACTION":  Call Sub_RemoveFilterForAcitveSheet
            End Select
    End Select
End Function