This worked for me on Xl97 and Xl2000 .... sory don't have Xl95
Option Explicit
Const strAttrShC As String = "VB_ProcData.VB_Invoke_Func = "
Const strAttrSub As String = "Attribute "
Const strFoobar As String = "ZZZZzzzz"
Dim strShortCuts() As String
Dim j As Integer
Sub mGetShortCutKeys()
'// By Ivan F Moala
'//
http://www.XcelFiles.com
'// Testing done Xl97 & 2000
'// Needs a Reference to MS Visual Basics for Applications
Extensibilty lib
Dim strTempModFile As String
Dim NoComponents As Long
Dim i As Integer
Dim VBP As Object
Set VBP = ActiveWorkbook.VBProject
NoComponents = VBP.VBComponents.Count
'// Set a Temp path
strTempModFile = ActiveWorkbook.Path & Application.PathSeparator &
"Tmp.Txt"
'// inialize count
j = 0
On Error Resume Next
For i = 1 To NoComponents
'// We only want Modules
If VBP.VBComponents(i).Type = 1 Then
With VBP.VBComponents(i)
'// Export The ActiveWorkbooks CodeModule
.Export strTempModFile
ReadAttribute strTempModFile
End With
End If
Next
'// Now display it to a Sheet
With ActiveWorkbook
.Sheets.Add
.ActiveSheet.[A1].Resize(UBound(strShortCuts()) + 1, 1) = _
Application.WorksheetFunction.Transpose(strShortCuts())
.ActiveSheet.Columns("A").Columns.AutoFit
.ActiveSheet.Columns("A").Columns.HorizontalAlignment = xlLeft
End With
Erase strShortCuts()
End Sub
Function ReadAttribute(strBas As String) As String
Dim strTxt As String
Dim handle As Long
Dim Pos As Long
Dim NewPos As Long
Dim PosSub As String
Dim x As Integer
Dim ShortCutKey As String
Dim SubName As String
Dim blnShift As Boolean
'// Open bas file in binary mode
handle = FreeFile
Open strBas For Binary As #handle
'// Parse enougth spaces for text
strTxt = Space(LOF(handle))
'// Read the string IN and Close the file
Get #handle, , strTxt
Close #handle
'// Lets get the ShortCut Key!
Pos = 0: NewPos = 0: x = 0
Do
Pos = InStr(NewPos + 1, strTxt, strAttrShC)
ShortCutKey = Mid(strTxt, Pos + Len(strAttrShC) + 1, 1)
'// Is it a shortCut
If ShortCutKey = " " Then GoTo Skip
If Pos Then
'// Build SC Key
blnShift = (Asc(ShortCutKey) < 97)
ShortCutKey = IIf(blnShift, "Ctrl + shift + " &
ShortCutKey, "Ctrl + " & ShortCutKey)
x = Pos
Do Until PosSub = " "
PosSub = Mid(strTxt, x - 1, 1)
x = x - 1
Loop
SubName = Mid(strTxt, x, Pos - x - 1)
ReDim Preserve strShortCuts(j)
strShortCuts(j) = "Sub Routine Name:= " & SubName & _
" [ ShortCut:= " & ShortCutKey & " ]"
j = j + 1
PosSub = strFoobar
End If
Skip:
NewPos = Pos
Loop Until Pos = 0
'// Cleanup - Delete it
Kill strBas
End Function
