Sub KeystrokesRestoreAll() ' Paul Beverley - Version 20.07.17 ' Creates keybindings from a list Beep myResponse = MsgBox("KeystrokesRestoreAll:" & vbCr & vbCr & _ "Please use this macro with great caution; it could" _ & vbCr & "seriously mess up your keystroke allocations," _ & vbCr & "if you're not careful." & vbCr & vbCr & "Continue?", _ vbQuestion + vbYesNoCancel, "KeystrokesRestoreAll") If myResponse <> vbYes Then Exit Sub On Error GoTo ReportIt numKS = 0 nowPara = ActiveDocument.range(0, Selection.Paragraphs(1).range.End).Paragraphs.Count If nowPara <> 1 Then myResponse = MsgBox("Start from top of list?", vbQuestion + vbYesNo) If myResponse = vbYes Then nowPara = 1 End If For i = nowPara To ActiveDocument.Paragraphs.Count Set myPara = ActiveDocument.Paragraphs(i).range.Duplicate myLine = myPara.Text If Left(myLine, 1) = "#" Then GoTo theEnd myLine = Replace(myLine, vbCr, "") tabPos = InStr(myLine, vbTab) If Len(myLine) > 1 And tabPos > 0 Then ' First find the category myCategory = Left(myLine, tabPos - 1) myLine = Mid(myLine, tabPos + 1) ' Find the command and keystroke tabPos = InStr(myLine, vbTab) myItem = Left(myLine, tabPos - 1) ks = Mid(myLine, tabPos + 1) kCode = 0 If InStr(ks, "Ctrl+") > 0 Then kCode = kCode + 512 ks = Replace(ks, "Ctrl+", "") End If If InStr(ks, "Alt+") > 0 Then kCode = kCode + 1024 ks = Replace(ks, "Alt+", "") End If If InStr(ks, "Shift+") > 0 Then kCode = kCode + 256 ks = Replace(ks, "Shift+", "") End If ' Ordinary capital letters If ks Like "[A-Z]" Then aCode = Asc(UCase(ks)) ks = "" End If ' Ordinary numbers If ks Like "[0-9]" Then aCode = Asc(UCase(ks)) ks = "" End If ' F keys If Left(ks, 1) = "F" And Len(ks) > 1 Then aCode = 111 + Val(Replace(ks, "F", "")) ks = "" End If Select Case ks Case "!": aCode = wdKey1: kCode = kCode + 256 ' Shifted number 1 Case """": aCode = wdKey2: kCode = kCode + 256 ' Shifted number 2 Case ChrW(163): aCode = wdKey3: kCode = kCode + 256 ' Shifted number 3 Case "$": aCode = wdKey4: kCode = kCode + 256 ' Shifted number 4 Case "%": aCode = wdKey5: kCode = kCode + 256 ' Shifted number 5 Case "^": aCode = wdKey6: kCode = kCode + 256 ' Shifted number 6 Case "&": aCode = wdKey7: kCode = kCode + 256 ' Shifted number 7 Case "*": aCode = wdKey8: kCode = kCode + 256 ' Shifted number 8 Case "(": aCode = wdKey9: kCode = kCode + 256 ' Shifted number 9 Case ")": aCode = wdKey0: kCode = kCode + 256 ' Shifted number 0 Case "'": aCode = 192 Case "-": aCode = wdKeyHyphen ' The - key Case "#": aCode = 222 Case ",": aCode = wdKeyComma ' The , key Case ".": aCode = wdKeyPeriod ' The key Case "/": aCode = wdKeySlash Case ":": aCode = wdKeySemiColon: kCode = kCode + 256 Case ";": aCode = wdKeySemiColon ' The ; key Case "?": aCode = wdKeySlash: kCode = kCode + 256 Case "@": aCode = 192: kCode = kCode + 256 Case "[": aCode = wdKeyOpenSquareBrace ' The ] key Case "\": aCode = wdKeyBackSlash ' The \ key Case "]": aCode = wdKeyCloseSquareBrace ' The ] key Case "_": aCode = wdKeyHyphen ' Does it need? kCode = kCode + 256 Case "`": aCode = 223 Case "{": aCode = wdKeyOpenSquareBrace: kCode = kCode + 256 Case "}": aCode = wdKeyCloseSquareBrace: kCode = kCode + 256 Case "~": aCode = 222: kCode = kCode + 256 Case "+": aCode = wdKeyEquals ' kCode = kCode + 256 Case "<": aCode = wdKeyComma: kCode = kCode + 256 Case "=": aCode = wdKeyEquals ' The = key Case ">": aCode = wdKeyPeriod: kCode = kCode + 256 Case "Backspace": aCode = wdKeyBackspace ' The Backspace key Case "Clear (Num 5)": aCode = wdKeyNumeric5: kCode = kCode + 256 Case "Delete": aCode = wdKeyDelete ' The Delete key Case "Down": aCode = 40 ' The Down Cursor key Case "End": aCode = 35 ' The EndD key Case "Home": aCode = wdKeyHome ' The HOME key Case "Insert": aCode = wdKeyInsert ' The Insert key Case "Left": aCode = 37 ' The Left Cursor key Case "Num -": aCode = wdKeyNumericSubtract ' The - key on the keypad Case "Num *": aCode = wdKeyNumericMultiply ' The * key on the keypad Case "Num /": aCode = wdKeyNumericDivide ' The / key on the keypad Case "Num +": aCode = wdKeyNumericAdd ' The + key on the keypad Case "Num 0": aCode = wdKeyNumeric0 ' The 0 key on the keypad Case "Num 1": aCode = wdKeyNumeric1 ' The 1 key on the keypad Case "Num 2": aCode = wdKeyNumeric2 ' The 2 key on the keypad Case "Num 3": aCode = wdKeyNumeric3 ' The 3 key on the keypad Case "Num 4": aCode = wdKeyNumeric4 ' The 4 key on the keypad Case "Num 5": aCode = wdKeyNumeric5 ' The 5 key on the keypad Case "Num 6": aCode = wdKeyNumeric6 ' The 6 key on the keypad Case "Num 7": aCode = wdKeyNumeric7 ' The 7 key on the keypad Case "Num 8": aCode = wdKeyNumeric8 ' The 8 key on the keypad Case "Num 9": aCode = wdKeyNumeric9 ' The 9 key on the keypad Case "Page Down": aCode = 34 ' The Page Down key Case "Page Up": aCode = 33 ' The Page Up key Case "Return": aCode = wdKeyReturn ' The Enter or Return key Case "Right": aCode = 39 ' The Right Cursor key Case "Space": aCode = wdKeySpacebar ' The Spacebar key Case "Up": aCode = 38 ' The Up Cursor key End Select Select Case myCategory Case "Symbol": myCat = wdKeyCategorySymbol Case "Font": myCat = wdKeyCategoryFont Case "Style": myCat = wdKeyCategoryStyle Case "Command": myCat = wdKeyCategoryCommand Case "Macro": myCat = wdKeyCategoryMacro Case Else: myCat = 0 End Select If myCat = 0 Then myPara.Select Selection.Collapse wdCollapseStart Beep MsgBox ("Not valid keybinding, I don't think.") Exit Sub End If kCode = kCode + aCode KeyBindings.Add KeyCode:=kCode, _ KeyCategory:=myCat, Command:=myItem numKS = numKS + 1 End If Next i theEnd: myPara.Select Selection.Collapse wdCollapseStart Beep MsgBox ("Restored: " & numKS & " key assignments") ReportIt: If Err.Number = 5346 Then myPara.Select Selection.Collapse wdCollapseStart Beep MsgBox ("Couldn't find " & myCategory & ": " & myItem) End If End Sub