List Userform Hotkeys

I hate trying to figure out which hotkeys are available when I need to add a control to a userform, so I wrote a procedure to list them.

Sub ListHotKeys(uf As UserForm)
   
    Dim ctl As Control
    Dim aKeys() As String
    Dim sKey As String
    Dim i As Long, j As Long
   
    For Each ctl In uf.Controls
        sKey = ""
       
        'Not all controls have this property
        On Error Resume Next
            sKey = ctl.Accelerator
        On Error GoTo 0
       
        If Len(sKey)> 0 Then
            i = i + 1
            ReDim Preserve aKeys(1 To i)
            aKeys(i) = sKey
        End If
    Next ctl
   
    For i = LBound(aKeys) To UBound(aKeys) - 1
        For j = i + 1 To UBound(aKeys)
            If aKeys(i)> aKeys(j) Then
                sKey = aKeys(i)
                aKeys(i) = aKeys(j)
                aKeys(j) = sKey
               
            End If
        Next j
    Next i
   
    For i = 1 To UBound(aKeys)
        Debug.Print aKeys(i)
    Next i
       
End Sub

6 Comments

  1. Peter Carr:

    Hi. I have often wondered if similar code can be written to detect what keyboard shortcuts are in use by currently open macros. Any thoughts?

  2. Jon Peltier:

    Nice. You need a second column for the caption of the accelerated control.

  3. sam:

    Peter,

    There is an addin from Ivan F - Called List Shortcut keys - check out his website

    Sam

  4. Simon Murphy:

    Peter
    Shortcut keys are a hidden property of a procedure. You can see them if you export the module and then open it in a text editor. Ivan may have (/will have) a more refined way.

  5. Ken:

    The download link on Ivan F's website (http://www.xcelfiles.com/GetShortCutKeys.html) doesn't seem to be working.

  6. yRadunchev:

    Found on some Japanese VBA forum and a little bit re-written:

    Sub GetShortCutKeys()

    Dim DefPath As String
    Dim FNo As Integer
    Dim LineBuf As String
    Dim i As Integer
    Dim buf() As String
    Dim bufName As String
    Dim bufKeyName As String
    Dim vbc As Object
    Const AT1 As String = "Attribute "
    Const AT2 As String = "VB_Invoke_Func ="
    Const TMPF As String = "Temp1.bas"

    DefPath = ThisWorkbook.Path & "\"
     With ThisWorkbook.VBProject
     For Each vbc In .VBComponents
     .VBComponents(vbc.Name).Export Filename:=DefPath & TMPF
     FNo = FreeFile()
     Open DefPath & TMPF For Input As #FNo
     While Not EOF(FNo)
      Line Input #FNo, LineBuf
      If InStr(1, LineBuf, "Sub", vbTextCompare) = 1 Then
       bufName = Mid$(LineBuf, InStr(LineBuf, "Sub") + 4)
      End If
      If InStr(LineBuf, AT1) = 1 And InStr(LineBuf, AT2)> 0 Then
       ReDim Preserve buf(i)
       bufKeyName = " : Ctrl + " & Mid$(LineBuf, InStrRev(LineBuf, "=") + 3, 1)
       buf(i) = bufName & bufKeyName
       
       Debug.Print bufName; bufKeyName
       i = i + 1
       bufName = ""
      End If
      LineBuf = ""
     Wend
     Close #FNo
     Kill DefPath & TMPF
     Next
     End With
     MsgBox Join(buf, vbCrLf)
     
    End Sub

Leave a comment