Macro Shortcut Word

 'Creado por WordDesdeCero.es.
Option Explicit
Sub ListCompositeShortcuts()
Dim oDoc As Word.Document
Dim oDocTemp As Word.Document
Dim oKey As KeyBinding
Dim oTbl_1 As Word.Table, oTbl_2 As Word.Table
Dim oRng As Word.Range
Dim lngIndex As Long
Dim oRow As Word.Row

  'Create a new document for listing composite shortcuts.
  Set oDoc = Documents.Add(, , wdNewBlankDocument)
  Set oRng = oDoc.Range
  System.Cursor = wdCursorWait
  Application.ScreenUpdating = False
  CustomizationContext = NormalTemplate 'or the template\document to evaluate.
  'List and sort custom keybindings.
  For lngIndex = 1 To KeyBindings.Count
    Set oKey = KeyBindings(lngIndex)
    oRng.InsertAfter vbCr & oKey.KeyCategory & vbTab & oKey.Command _
                   & vbTab & oKey.KeyString
    'Update status bar.
    Application.StatusBar = "Processing custom keybinding " & lngIndex & " of " & _
                             KeyBindings.Count & ".  Please wait."
    DoEvents
  Next lngIndex
  'Show progress to user.
  With Application
    .ScreenUpdating = True
    .ScreenRefresh
    .ScreenUpdating = False
  End With
  'Convert text to table or create table. Leave empty paragraph beginning the document.
  oRng.MoveStart wdParagraph, 1
  If Len(oRng.Text) > 2 Then
    Set oTbl_1 = oRng.ConvertToTable
  Else
    Set oTbl_1 = oRng.Tables.Add(oRng, 2, 3)
  End If
  'Format table.
  With oTbl_1
    .Style = "Tabla con cuadrícula 1 clara"
    .Range.NoProofing = True
    With .Rows
      .Add BeforeRow:=oTbl_1.Rows(1)
      .Add BeforeRow:=oTbl_1.Rows(1)
    End With
    With .Rows(1)
      .HeadingFormat = True
      With .Range
      .Cells.Merge
        With .Cells(1).Range
          .ParagraphFormat.Alignment = wdAlignParagraphCenter
          .Text = ": Configuración actual del teclado | Teclas personalizadas"
          .Font.Bold = True
        End With
      End With
    End With
    With .Rows(2)
      .HeadingFormat = True
      .Shading.BackgroundPatternColor = wdColorGray10
      .Cells(1).Range.Text = "Categoría"
      .Cells(2).Range.Text = "Nombre/Símbolo"
      .Cells(3).Range.Text = "Combinación de teclas de acceso directo"
    End With
    For lngIndex = 3 To .Rows.Count
      Select Case Left(.Rows(lngIndex).Cells(1).Range.Text, _
             Len(.Rows(lngIndex).Cells(1).Range.Text) - 2)
        Case "1": .Rows(lngIndex).Cells(1).Range.Text = "Command"
        Case "2": .Rows(lngIndex).Cells(1).Range.Text = "Macro"
        Case "3": .Rows(lngIndex).Cells(1).Range.Text = "Font"
        Case "4": .Rows(lngIndex).Cells(1).Range.Text = "BuildingBlock\AutoText"
        Case "5": .Rows(lngIndex).Cells(1).Range.Text = "Style"
        Case "6": .Rows(lngIndex).Cells(1).Range.Text = "Symbol"
      End Select
    Next lngIndex
    'Sort on category.
    .Sort True, 1
  End With
  'Add and format document title.
  With oDoc.Paragraphs(1).Range
    .InsertBefore "Lista compuesta de accesos directos"
    .Style = "Título 1"
  End With
  'Show progress to user.
  With Application
    .ScreenUpdating = True
    .ScreenRefresh
    .ScreenUpdating = False
  End With
  'Add paragraph separator.
  oRng.InsertAfter vbCr
  oRng.Collapse wdCollapseEnd
  'Create the built-in list using the Word command.
  Application.ListCommands ListAllCommands:=0
  'This creates a new active document.
  Set oDocTemp = ActiveDocument
  'Clean up Word 2003 list.
  With Application
    If .Version < 12# Then
      .ScreenUpdating = True
      .ScreenRefresh
      .ScreenUpdating = False
      .StatusBar = "Processing temporary list.  Please wait"
      With oDocTemp.Tables(1)
        .Columns(4).Delete
        For lngIndex = oDocTemp.Tables(1).Rows.Count To 1 Step -1
          Set oRow = oDocTemp.Tables(1).Rows(lngIndex)
          If Len(oRow.Cells(2).Range) = 2 Then
            oRow.Delete
          End If
          DoEvents
        Next lngIndex
      End With
    End If
  End With
  'Get the list (table) and kill the document.
  oDocTemp.Range.Copy
  oDocTemp.Close wdDoNotSaveChanges
  'Ensure the composite list is the active document.
  oDoc.Activate
  'Paste the copied table into the composite list.
  oRng.Paste
  Set oTbl_2 = oDoc.Tables(2)
  'Format table.
  With oTbl_2
    .Style = "Tabla con cuadrícula 1 clara"
    With .Range
      .Font.Bold = False
      .NoProofing = True
    End With
    .PreferredWidthType = wdPreferredWidthPercent
    .PreferredWidth = 100
    .Rows.Add BeforeRow:=oTbl_2.Rows(1)
     With .Rows(1)
      .HeadingFormat = True
      With .Range
        .Cells.Merge
        With .Cells(1).Range
          .ParagraphFormat.Alignment = wdAlignParagraphCenter
          .Text = "Configuración actual del teclado -  Comandos Word incorporados"
          .Font.Bold = True
        End With
      End With
    End With
    For lngIndex = 2 To .Rows.Count
      Application.StatusBar = "Processing built-in keybinding " & lngIndex - 1 _
                              & " of " & oTbl_2.Rows.Count - 1 & ".  Please wait."
      With .Rows(lngIndex)
        .Cells(2).Merge .Cells(3)
        .Cells(2).Range.Text = Replace(.Cells(2).Range.Text, vbCr, "")
      End With
      DoEvents
    Next lngIndex
    With .Rows(2)
      .HeadingFormat = True
      .Shading.BackgroundPatternColor = wdColorGray10
      .Cells(1).Range.Text = "Nombre del comando"
      .Cells(2).Range.Text = "Combinación de teclas de acceso directo"
    End With
    .Range.Cells.DistributeWidth
  End With
  'Prevent (or try to prevent) a blank page at end of document.
  Do While Len(oDoc.Paragraphs.Last.Previous.Range) = 1
   oDoc.Paragraphs.Last.Previous.Range.Delete
  Loop
  Set oRng = oDoc.Paragraphs.Last.Range
  With oRng
   .Paragraphs(1).SpaceBefore = 0
   .Paragraphs(1).SpaceAfter = 0
   .Paragraphs(1).Range.Font.Size = 1
  End With
lbl_Exit:
  System.Cursor = wdCursorNormal
  Beep
  With Application
    .StatusBar = "Finished!!"
    .ScreenUpdating = True
    .ScreenRefresh
  End With
  Exit Sub
End Sub