Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "0{00020906-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "All_keyboard_shortcuts"
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)
  oDoc.TrackRevisions = False
  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 = "Table Grid"
    .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 = "Current Keyboard Settings - Custom Key Bindings"
          .Font.Bold = True
        End With
      End With
    End With
    With .Rows(2)
      .HeadingFormat = True
      .Shading.BackgroundPatternColor = wdColorGray10
      .Cells(1).Range.text = "Category"
      .Cells(2).Range.text = "Name/Symbol"
      .Cells(3).Range.text = "Shortcut Key Combination"
    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 "Composite Shortcut List"
    .style = "Title"
  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 = "Table Grid"
    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 = "Current Keyboard Settings - Built-in Word Commands"
          .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 = "Command Name"
      .Cells(2).Range.text = "Shortcut Key Combination"
    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



Attribute VB_Name = "AppObject"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit
Public WithEvents m_app As Application
Attribute m_app.VB_VarHelpID = -1
Private m_showEditCheckList As String
Private m_isClosing As Boolean
Private Const m_maxDeadTime = 480
Public Property Set app(anApplicationObject As Application)
    Set m_app = anApplicationObject
End Property

Public Property Get app() As Application
    Set app = m_app
End Property

Public Property Let showEditCheckList(s As String)
    m_showEditCheckList = s
End Property

Private Sub Class_Terminate()
    Debug.Print "AppObject terminate called: m_isClosing = " & m_isClosing
    If Not m_isClosing Then
        Exit Sub
    End If
End Sub

Private Sub m_app_DocumentBeforeClose(ByVal doc As Document, Cancel As Boolean)
    'Checklist for end of a paper. Runs automatically when closing a document
    'On Error Resume Next
    Dim i As Integer
    Dim askReminderTexts As Boolean
    Dim firstReminderText As Long
    Dim showEditCheckList As Boolean
    With doc
        For i = 1 To doc.Comments.count
            If doc.Comments(i).Contact = "ReminderText" Then
                askReminderTexts = True
                firstReminderText = i
                Exit For
            End If
        Next
        '.Bookmarks.ShowHidden = False
    End With
    If askReminderTexts Then
        Select Case MsgBox("There are still some ReminderText comments associated with this paper. Do you want to Keep them (Yes), Delete them (No) or Address them now (Cancel)?", vbYesNoCancel, "ReminderText Comments")
        Case vbYes
            ' clear ReminderText flag
            firstReminderText = 0
            Call writeReminderTexts(doc)
            ' remove them from the document
            Call removeAllReminderTextComments(doc)
        Case vbNo
            ' write any remaining reminderTexts
            If firstReminderText > 0 Then
                ' clear ReminderText flag
                firstReminderText = 0
                ' delete the remindertext file
                Call deleteAllReminderTexts(doc) 'call removeAllReminderTexts
            End If
        Case vbCancel
            Cancel = True
            doc.Comments(firstReminderText).Scope.Select
            doc.Windows(1).ScrollIntoView Selection.Range
            For i = 1 To 6
                doc.Comments(firstReminderText).Range.Font.color = wdColorPink
                doc.Application.ScreenRefresh
                doc.Comments(firstReminderText).Range.Font.color = wdColorAutomatic
                doc.Application.ScreenRefresh
            Next
            Exit Sub
        End Select
    Else
        Dim prefix As String
        Dim RTFilename As String
        If CustomPropertyExists(doc, "ReminderText") Then
            prefix = getCustomProperty(doc, "ReminderText")
            ' remove the stored prefix
            doc.CustomDocumentProperties("ReminderText").Delete
            RTFilename = getPathOnly(doc.FullName, True) & prefix & "_" & "remindertext.txt"
            If Dir$(RTFilename) <> "" Then
                Kill RTFilename
            End If
        End If
    End If
    
    Call clearSAMHighlightsAndBookMarks(doc, False, True)
    
    If m_showEditCheckList = "True" Then
        showEditCheckList = True
    ElseIf m_showEditCheckList = "False" Then
        showEditCheckList = False
    Else
        showEditCheckList = CBool(GetSetting("MegaMacro", "Options", "chkEditChecklist", "True"))
    End If
    If showEditCheckList Then
        If MsgBox("Did you remember to...:" & Chr(13) & "* Check the title?" & Chr(13) & "* Re-read the abstract?" & Chr(13) & "* Run Spellcheck?" & Chr(13) & "* Review all the comments?" & Chr(13) & "* Reject changes to the references?", vbYesNo, "Pre-upload checklist") = vbNo Then
            MsgBox "I appreciate your honesty. Go back and do it!"
            Cancel = True
            Exit Sub
        Else
            MsgBox "Great! Have a nice day!"
        End If
    End If
End Sub

Private Sub m_app_DocumentBeforeSave(ByVal doc As Document, SaveAsUI As Boolean, Cancel As Boolean)
'    Dim SN As SAMNavigationForm
    If doc.RemovePersonalInformation = True Then
        If MsgBox("This document is set to remove personal information on save, which means it will anonymize all edits to ""Author."" Do you want to remove that setting (Yes) or keep it (No)?", vbYesNo, "Anonymize Document on Save?") = vbYes Then
            doc.RemovePersonalInformation = False
        End If
    End If
'    On Error Resume Next
'    Set SN = SAM.getSAMNav
'    If SN.Visible = True Then
'        If err.number <> 0 Then
'            If SAM.getSAMNavCurrentDocumentName = doc.FullName Then
'                Call clearSAMHighlightsAndBookMarks(doc, False, True)
'            End If
'        End If
'    End If
    Call File_Management("Add", doc.FullName)
End Sub

Private Sub m_app_DocumentOpen(ByVal doc As Document)
    On Error Resume Next
    Debug.Print "Entering app_DocumentOpen"
    If IsProtectedViewWindow Then Exit Sub
    doc.RemovePersonalInformation = False
'    If getExtension(doc.Name) = ".tex" Then
'        DoEvents
'        Call LaTeX.openLaTeXDocument
'        DoEvents
'        Call doc.SaveAs2(getPathOnly(doc.FullName, True) & getFilenameWithoutExtension(doc.Name) & ".docx", wdFormatXMLDocument)
'    End If
    Call restoreReminderTexts(doc)
    If m_app Is Nothing Then
        initGlobals
    End If
    Call setTrackRevisions(doc)
End Sub

Private Sub m_app_NewDocument(ByVal doc As Document)
    'call StartEditTimer
    If m_app Is Nothing Then
        initGlobals
    End If
    'Debug.Print "Track Revisions set to " & setTrackRevisions(doc)
End Sub

Private Sub m_app_WindowActivate(ByVal doc As Word.Document, ByVal Wn As Word.Window)
    If IsProtectedViewWindow Then Exit Sub
    If m_app Is Nothing Then
        initGlobals
    End If
    Call checkDocUserName
End Sub



Private Sub m_app_Quit()
    Dim im As New installMacros
    Dim hotkeyfile As String
    hotkeyfile = im.MacroInstallBackupPath & "keyboard_shortcuts.txt"
    Call Export_Import_Keystrokes.saveKeyBindings(hotkeyfile)
    If Not fileExists(getMacroInstallBackupPath & "custom_autocorrect_entries.docx") Then
        Call exportCustomAutoCorrectEntries
    End If
    Call backupNormalDotm(True)
    m_isClosing = True
End Sub





Private Sub m_app_WindowDeactivate(ByVal doc As Document, ByVal Wn As Window)
    'Debug.Print "Window deactivated"
End Sub

Private Sub m_app_WindowSelectionChange(ByVal Sel As Selection)
    Call SAM.cursorMoved(Sel.Range)
End Sub

Attribute VB_Name = "Bootstrap"
Option Explicit
Global oApp As AppObject
Global Const FILE_MANAGEMENT_DELETE_DELAY = 15
Sub AutoOpen()
    Call initGlobals
End Sub
Sub AutoExec()
    On Error Resume Next
    Set VBE.ActiveVBProject = VBE.VBProjects("Normal")
    Debug.Print VBE.ActiveVBProject.Name
    If err.number <> 0 Then
        MsgBox "You need to allow Word to update the Research Square macros. To do that:" & vbCrLf & _
        "    1. Click File-->Options-->Trust Center" & vbCrLf & _
        " 2. Click the ""Trust Center Settings"" button." & vbCrLf & _
        "    3. Check the option named ""Trust access to the VBA project model.""" & vbCrLf & vbCrLf & _
        "After checking the option, exit Word and then open it again." & vbCrLf & vbCrLf & _
        "Optional: Press Ctrl-C to copy these directions (paste them into Notepad and follow the steps from there) "
        Exit Sub
    End If
    Dim norm As VBProject
    Dim aFilename As String
    Dim fromProject As VBProject
    Debug.Print "In Autoexec"
    ' the following two items are Office-version-specific
    Set norm = VBE.VBProjects("Normal")
    Select Case Application.Version
    Case "16.0"
        'Microsoft Office 16.0 Object Library
        norm.References.AddFromGuid "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}", 2, 8
        ' Microsoft Excel 16.0 Object Library
        norm.References.AddFromGuid "{00020813-0000-0000-C000-000000000046}", 1, 9
    Case "15.0"
        'Microsoft Office 15.0 Object Library
        norm.References.AddFromGuid "{2DF8D04C-5BFA-101B-BDE5-00AA0044DE52}", 2, 7
        ' Microsoft Excel 15.0 Object Library
        norm.References.AddFromGuid "{00020813-0000-0000-C000-000000000046}", 1, 8
    End Select
    
    ' All the rest of the libraries are common to both Office 15 (2013) and Office 16 (2016)
    'OLE Automation
    norm.References.AddFromGuid "{00020430-0000-0000-C000-000000000046}", 2, 0
    ' Microsoft Forms 2.0 Object Library
    norm.References.AddFromGuid "{0D452EE1-E08F-101A-852E-02608C4D0BB4}", 2, 0
    ' Microsoft VBScript Regular Expressions 5.5
    norm.References.AddFromGuid "{3F4DACA7-160D-11D2-A8E9-00104B365C9F}", 5, 5
    ' Microsoft Visual Basic for Applications Extensibility 5.3
    norm.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 3
    ' Microsoft Scripting Runtime
    norm.References.AddFromGuid "{420B2830-E718-11CF-893D-00A0C9054228}", 1, 0
    'Microsoft XML, v6.0
    norm.References.AddFromGuid "{F5078F18-C551-11D3-89B9-0000F81FE221}", 6, 0
    ' Microsoft VBScript Globals
    norm.References.AddFromGuid "{3EEF9758-35FC-11D1-8CE4-00C04FC2B185}", 1, 0
    ' Microsoft Shell Controls And Automation
    norm.References.AddFromGuid "{50A7E9B0-70EF-11D1-B75A-00A0C90564FE}", 1, 0
    Dim i As Integer
    If VBE.VBProjects.count >= 2 Then
        Set fromProject = VBE.VBProjects("Install")
        Set norm = VBE.VBProjects("Normal")
    End If
    If Not fromProject Is Nothing Then
        If Not norm Is Nothing And Not (fromProject Is norm) Then
            Debug.Print "Copying files from " & fromProject.Name & " to " & norm.Name
            ' check to see whether norm contains modules
            If norm.VBComponents.count > 1 Then ' ThisDocument
                MsgBox "This procedure only rebuilds a Normal.dotm project from scratch (one that does not already have code). Please export any custom modules, then delete Normal.dotm and run this installation again."
                Exit Sub
            End If
            Call transferModules(fromProject, norm)
            If norm.VBComponents.count = fromProject.VBComponents.count Then
                ' force custom autocorrect entries to update the next time Word is started
                SaveSetting "MegaMacro", "Options", "CustomAutoCorrectUpdateNeeded", "True"
                ' force autoupdate to run the next time Word is started
                SaveSetting "MegaMacro", "Options", "LastUpdateDate", "03/30/2018 11:03:23"
                MsgBox "Normal.dotm has been rebuilt. You will need to restart Word."
                Application.Quit
            Else
                MsgBox "Something went wrong. Close Word and delete your current copy of Normal.dotm and rename " & aFilename & " to ""Normal.dotm"" and then restart Word. "
                Exit Sub
            End If
        Else
            MsgBox "Unable to set references to the correct project types. The macros have not been installed properly."
        End If
    End If
ExitTransfer:
    Application.Run "removeUnneededModules"
    Debug.Print "The active project is Normal"
    'Debug.Print "Autoupdate skipped for beta testing."
    Application.Run "UpdateMacros.UpdateMacros"
    Dim hotkeyfile As String
    Call loadStockKeyboardShortcuts
    hotkeyfile = getMacroInstallBackupPath & "keyboard_shortcuts.txt"
    Debug.Print "Keyboard shortcut file is: " & hotkeyfile
    If hotkeyfile <> "" Then
        If Dir$(hotkeyfile) <> "" Then
            Call Export_Import_Keystrokes.readKeyBindings(hotkeyfile)
            Debug.Print "Custom keyboard shortcuts loaded."
            Call SaveSetting("MegaMacro", "Hotkeys", "Hotkeyfile", "")
        End If
    End If
    If GetSetting("MegaMacro", "Options", "CustomAutoCorrectUpdateNeeded", True) = "True" Then
        Call importCustomAutoCorrectEntries
        SaveSetting "MegaMacro", "Options", "CustomAutoCorrectUpdateNeeded", "False"
    End If
    If GetSetting("MegaMacro", "Options", "AutoCorrectUpdateNeeded", True) = "True" Then
        If Application.Run("updateAutoCorrectEntriesFromDictionary") = True Then
            SaveSetting "MegaMacro", "Options", "AutoCorrectUpdateNeeded", "False"
        End If
    End If
    ActiveDocument.TrackRevisions = CBool(GetSetting("MegaMacro", "Options", "chkTrackChanges", "False"))
    Call initGlobals
End Sub
Sub initGlobals()
    Debug.Print "Entering initGlobals"
    Dim reInit As Boolean
    If oApp Is Nothing Then
        Set oApp = New AppObject
    End If
    If oApp.app Is Nothing Then
        Set oApp.app = Application
    End If
End Sub
'Sub GoBack()
'    If Not ps Is Nothing Then
'        Selection.Start = ps.Cycle
'        Selection.End = Selection.Start
'        ActiveWindow.ScrollIntoView Selection.range
'    End If
'End Sub

Sub transferModules(fromProject As VBProject, toProject As VBProject)
    Dim comp As VBComponent
    Dim comp2 As VBComponent
    Dim tempPath As String
    Dim outfile As String
    tempPath = getTempPath & "RSMacros"
    If folderExists(tempPath) Then
        deleteFolder (tempPath)
    End If
    If Not folderExists(tempPath) Then
        createFolderRecursively tempPath
    End If
    tempPath = ensurePathTrailingSlash(tempPath)
    For Each comp In fromProject.VBComponents
        outfile = ""
        Select Case comp.Type
        Case vbext_ct_StdModule
            outfile = tempPath & comp.Name & ".bas"
        Case vbext_ct_ClassModule
            outfile = tempPath & comp.Name & ".cls"
        Case vbext_ct_MSForm
            outfile = tempPath & comp.Name & ".frm"
        Case Else
        
        End Select
        If outfile <> "" Then
            comp.Export outfile
            DoEvents
            toProject.VBComponents.Import outfile
            DoEvents
            deleteFile outfile, True
        End If
    Next
    Dim im As New installMacros
    ' set stock keyboard shortcuts
    loadStockKeyboardShortcuts
    ' set up Settings to restore personal keyboard shortcuts and AutoCorrect entries
    Dim hotkeyfile As String
    hotkeyfile = im.MacroInstallBackupPath & "keyboard_shortcuts.txt"
    SaveSetting "MegaMacro", "Hotkeys", "Hotkeyfile", hotkeyfile
    SaveSetting "MegaMacro", "Options", "AutoCorrectUpdateNeeded", "True"
    ' Microsoft Visual Basic for Applications Extensibility 5.3
    toProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 3
End Sub
Public Function CountUnneededModules() As Integer
    Dim aModule As VBComponent
    Dim v As Variant
    Dim norm As VBProject
    Set norm = VBE.VBProjects("Normal")
    Dim count As Integer
    Dim nameWithout1 As String
    For Each aModule In norm.VBComponents
        If Right$(aModule.Name, 1) = "1" Then
            count = count + 1
        End If
    Next
    CountUnneededModules = count
End Function

Sub loadStockKeyboardShortcuts()
    CustomizationContext = NormalTemplate
    'KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyBackspace), KeyCategory:=1, Command:="DecreaseIndent"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyF), KeyCategory:=1, command:="NavPaneSearch"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyJ), KeyCategory:=1, command:="ToolsThesaurusRR"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyQ), KeyCategory:=1, command:="FileExit"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyR), KeyCategory:=1, command:="RejectChangesSelected"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKey8), KeyCategory:=6, command:="°"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKey9), KeyCategory:=6, command:="·"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyA), KeyCategory:=2, command:="Normal.NewMacros.AutoAcceptAuthorRevisions"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyB), KeyCategory:=1, command:="UseBalloons"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyD), KeyCategory:=1, command:="ShowInsertionsAndDeletions"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyI), KeyCategory:=1, command:="NoInsertionDeletionBalloons"
    'KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyN), KeyCategory:=1, Command:="InsertAnnotation"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyP), KeyCategory:=2, command:="Normal.AJE_Core_Macros.c_pleaseensure"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyR), KeyCategory:=2, command:="Normal.AJE_Core_Macros.AARejectHighlightedComments"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyV), KeyCategory:=1, command:="PasteTextOnly"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyX), KeyCategory:=1, command:="RejectChangesSelected"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyComma), KeyCategory:=1, command:="PreviousChangeOrComment"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyComma), KeyCategory:=1, command:="PreviousChangeOrComment"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyHyphen), KeyCategory:=6, command:="—"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyPeriod), KeyCategory:=1, command:="NextChangeOrComment"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyPeriod), KeyCategory:=1, command:="NextChangeOrComment"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeySlash), KeyCategory:=1, command:="RejectChangesAndAdvance"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeySlash), KeyCategory:=1, command:="RejectChangesAndAdvance"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyR), KeyCategory:=1, command:="RejectChangesAndAdvance"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKey8), KeyCategory:=6, command:="×"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyA), KeyCategory:=2, command:="Normal.Change_View_Macros.ShowAllEdits"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyC), KeyCategory:=2, command:="Normal.AJE_Core_Macros.displayAutoCorrectCommentEntries"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyD), KeyCategory:=1, command:="ShowInsertionsAndDeletions"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyE), KeyCategory:=2, command:="Normal.Change_View_Macros.EditViewToggle"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyF), KeyCategory:=2, command:="Normal.Change_View_Macros.ShowNone"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyH), KeyCategory:=1, command:="ShowComments"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyN), KeyCategory:=6, command:="–"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyO), KeyCategory:=2, command:="Normal.Change_View_Macros.ShowOriginal"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyP), KeyCategory:=1, command:="ReviewingPaneVertical"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyR), KeyCategory:=1, command:="RejectChangesOrAdvance"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyS), KeyCategory:=2, command:="Normal.Change_View_Macros.ShowSimple"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyU), KeyCategory:=6, command:="µ"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyM), KeyCategory:=6, command:="µ"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyW), KeyCategory:=2, command:="Normal.AJE_Core_Macros.CountAllWordsWithoutReferences"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyY), KeyCategory:=1, command:="AcceptChangesOrAdvance"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyZ), KeyCategory:=1, command:="ViewZoomPageWidth"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeySlash), KeyCategory:=2, command:="Normal.AJE_Core_Macros.GoogleFetchQuotes"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyShift, wdKeyF), KeyCategory:=1, command:="ShowFormatting"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyShift, wdKeySlash), KeyCategory:=2, command:="Normal.AJE_Core_Macros.GoogleScholarFetchQuotes"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyControl, wdKeyShift, wdKeyN), KeyCategory:=2, command:="Normal.AJE_Core_Macros.newReminderText"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyN), KeyCategory:=2, command:="Normal.AJE_Core_Macros.nextReminderText"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyOpenSquareBrace), KeyCategory:=1, command:="PreviousComment"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyControl, wdKeyShift, wdKeyPeriod), KeyCategory:=1, command:="NextComment"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyCloseSquareBrace), KeyCategory:=1, command:="NextComment"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyShift, wdKeyE), KeyCategory:=2, command:="Normal.AJE_Core_Macros.CreateEditingSummary"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKeyEquals), KeyCategory:=2, command:="Normal.AJE_Core_Macros.insertThe"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyP), KeyCategory:=2, command:="Normal.AJE_Core_Macros.togglePlural"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyControl, wdKeyShift, wdKeyT), KeyCategory:=2, command:="Normal.AJE_Core_Macros.applyFormatting"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyControl, wdKeyShift, wdKeyM), KeyCategory:=2, command:="Normal.AJE_Core_Macros.moveComment"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyV), KeyCategory:=2, command:="Normal.AJE_Core_Macros.toggleVerbForms"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyComma), KeyCategory:=wdKeyCategoryMacro, command:="Normal.AJE_Core_Macros.moveSelectionLeft"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyPeriod), KeyCategory:=wdKeyCategoryMacro, command:="Normal.AJE_Core_Macros.moveSelectionRight"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyAlt, wdKeyShift, wdKeyEquals), KeyCategory:=wdKeyCategoryMacro, command:="Normal.AJE_Core_Macros.repeatSelectedRevision"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyAlt, wdKeyShift, wdKeyNumericAdd), KeyCategory:=wdKeyCategoryMacro, command:="Normal.AJE_Core_Macros.repeatSelectedRevision"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyHyphen), KeyCategory:=wdKeyCategoryMacro, command:="Normal.AJE_Core_Macros.toggleHyphen"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyAlt, wdKeyShift, wdKeyHyphen), KeyCategory:=wdKeyCategoryMacro, command:="Normal.AJE_Core_Macros.incorrect_edit_rejection"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyShift, wdKey9), KeyCategory:=wdKeyCategoryMacro, command:="Normal.AJE_Core_Macros.toggleParentheses"
End Sub
Sub prepRelease()
    Dim templateDir As String
    'Call RemoveblankspaceFromModules
    templateDir = VBE.VBProjects("Normal").Filename
    templateDir = left$(templateDir, InStrRev(templateDir, "\"))
    VBE.VBProjects("Normal").Name = "Install"
    Dim comp As VBComponent
    Set comp = VBE.VBProjects("Install").VBComponents("Russell")
    VBE.VBProjects("Install").VBComponents.Remove comp
    'KeyBindings.ClearAll
    If Dir$(templateDir & "installmacros.dotm") <> "" Then
        Kill templateDir & "installmacros.dotm"
    End If
    VBE.VBProjects("Install").SaveAs templateDir & "installmacros.dotm"
End Sub


Sub wasteTime(timeInSeconds As Double)
    Dim startTime As Double
    startTime = Timer
    Do While (Timer - startTime) < timeInSeconds
        'Debug.Print timer - startTime
        DoEvents
    Loop
End Sub
Sub File_Management_Delete_Old_Files()
    Dim oldFileFolder As String
    oldFileFolder = getUserRoamingAppDataPath & "ResearchSquare\Macros\OldFiles"
    If MsgBox("Warning! This operation will immediately--and permanently--delete all files and subfolders older than " & FILE_MANAGEMENT_DELETE_DELAY * 2 & " days from the following folder: " & vbCrLf & vbCrLf & oldFileFolder & vbCrLf & vbCrLf & "Do not continue unless you want that to happen." & vbCrLf & vbCrLf & "The deleted files are not recoverable. Do you want to continue?", vbCritical + vbYesNo, "Delete Old Files Now?") = vbYes Then
        MsgBox File_Management("DeleteOldFiles") & " file/s were deleted."
    End If
End Sub
Function File_Management(action As String, Optional Filename As String) As Long
    Dim oldFileFolder As String
    Dim fileCount As Long
    On Error GoTo Err_File_Management
    oldFileFolder = getUserRoamingAppDataPath & "ResearchSquare\Macros\OldFiles\"

    Select Case action
    Case "DeleteOldFiles"
        If Not folderExists(oldFileFolder) Then
            Call createFolder(oldFileFolder)
        End If
        fileCount = deleteFilesRecursively(getFolder(oldFileFolder))
    End Select
Exit_File_Management:
    File_Management = fileCount
    Exit Function
Err_File_Management:
    MsgBox "An error occurred while deleting files in your OldFiles folder (" & oldFileFolder & "). Error description: " & err.Description, vbCritical, "Error Deleting Old Files"
    Resume Exit_File_Management
End Function

Private Function deleteFilesRecursively(aFolder As Scripting.Folder) As Long
    Dim aSubFolder As Scripting.Folder
    Dim aFile As Scripting.file
    Dim fileCount As Long
    Dim oldFileFolder As String
    Dim opType As String
    On Error GoTo errDeleteFilesRecursively
    oldFileFolder = getUserRoamingAppDataPath & "ResearchSquare\Macros\OldFiles"
    If InStr(aFolder, oldFileFolder) = 0 Then
        Exit Function
    End If
    opType = "file"
    For Each aFile In aFolder.files
        If DateDiff("d", aFile.DateLastModified, Now) >= (FILE_MANAGEMENT_DELETE_DELAY * 2) Then
            Call logMessage("Deleted file from OldFiles " & format$(aFile.DateLastModified, "dd/mm/yyyy hh:mm:ss") & vbTab & aFile.Name)
            If aFile.Attributes And 1 Then ' read-only
                aFile.Attributes = aFile.Attributes - 1
            End If
            If aFile.Attributes And 1024 Then ' alias--link
                aFile.Attributes = aFile.Attributes - 1024
            End If
            aFile.Delete
            fileCount = fileCount + 1
        End If
nextFile:
    Next
    opType = "folder"
    For Each aSubFolder In aFolder.SubFolders
        fileCount = fileCount + deleteFilesRecursively(aSubFolder)
        If aSubFolder.files.count = 0 Or DateDiff("d", aSubFolder.DateLastModified, Now) >= (FILE_MANAGEMENT_DELETE_DELAY * 2) Then
            Call logMessage("Deleted subdirectory from OldFiles " & format$(aSubFolder.DateLastModified, "dd/mm/yyyy hh:mm:ss") & vbTab & aSubFolder.Name)
            If aSubFolder.Attributes And 1 Then ' read-only
                aSubFolder.Attributes = aSubFolder.Attributes - 1
            End If
            If aSubFolder.Attributes And 1024 Then ' alias--link
                aSubFolder.Attributes = aSubFolder.Attributes - 1024
            End If
            aSubFolder.Delete
            fileCount = fileCount + 1
        End If
nextFolder:
    Next
    deleteFilesRecursively = fileCount
exitDeleteFilesRecursively:
    Exit Function
errDeleteFilesRecursively:
    Select Case opType
    Case "file"
        Resume nextFile
    Case "folder"
        Resume nextFolder
    Case Else
        Resume exitDeleteFilesRecursively
    End Select
End Function

Attribute VB_Name = "ChangeRevisionName"
Attribute VB_Base = "0{76ABEA7E-D892-40C5-91DA-C4A6810B8B55}{FE164770-8D7E-4529-BE0A-1EB87D95D82D}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False









Option Explicit
Private m_fromName As String
Private m_toName As String
Private m_Result As Boolean
Public Property Set AuthorList(aDictionary As Scripting.Dictionary)
    Dim v As Variant
    Dim i As Integer
    lstFrom.clear
    lstFrom.ColumnCount = 2
    lstFrom.ColumnWidths = "90;40"
    With lstFrom
        For Each v In aDictionary.Keys
            .addItem
            .List(i, 0) = v
            .List(i, 1) = "(" & aDictionary(v) & ")"
            i = i + 1
        Next
    End With
End Property
Public Property Get result() As Boolean
    result = m_Result
End Property
Public Property Get fromName() As String
   fromName = m_fromName
End Property
Public Property Get toName() As String
   toName = m_toName
End Property

Private Sub cmdCancel_Click()
    m_Result = False
    Me.Hide
End Sub

Private Sub cmdOK_Click()
    Dim fromName As String
    Dim toName As String
    On Error Resume Next
    fromName = lstFrom.List(lstFrom.listIndex, 0)
    If Len(txtOther.text) > 0 Then
        toName = txtOther.text
    Else
        toName = lstTo.List(lstTo.listIndex)
    End If
    
    If fromName = "" Then
        MsgBox "You must select the author name for which you want to change revisions."
        Exit Sub
    ElseIf toName = "" Then
        MsgBox "You must select the author name you want to change revisions by " & fromName & " to."
        Exit Sub
    ElseIf fromName = toName Then
        MsgBox "You cannot change an author name to the same name."
        Exit Sub
    Else
        m_fromName = fromName
        m_toName = toName
        m_Result = True
        Me.Hide
    End If
End Sub

Private Sub UserForm_Initialize()
    lstTo.addItem "Author"
    lstTo.addItem "Editor"
    lstTo.addItem "Editor 2"
    'lstTo.AddItem "Senior Editor"
    'lstTo.AddItem "Senior Editor 2"
    lstTo.addItem "Quality Control Editor"
    lstTo.addItem "Quality Control Editor 2"
    lstTo.addItem "Team Manager"
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then
        m_Result = False
        Me.Hide
    End If
End Sub



Attribute VB_Name = "Change_View_Macros"
Option Explicit
Dim clearOriginal As Boolean
Private savedMarkup As String
Sub ShowOriginal()
    If Selection.StoryType = wdMainTextStory Then
        With ActiveWindow.view
            .ShowRevisionsAndComments = False
            .RevisionsView = wdRevisionsViewOriginal
        End With
        ActiveWindow.ScrollIntoView Selection.Range, True
        clearOriginal = True
    End If
End Sub
Sub ShowFinal()
    If clearOriginal Then
        With ActiveWindow.view.RevisionsFilter
            .markup = wdRevisionsMarkupSimple
            .view = wdRevisionsViewFinal
        End With
    End If
    With ActiveWindow.view
        .ShowRevisionsAndComments = True
        .RevisionsView = wdRevisionsViewFinal
    End With
    ActiveWindow.ScrollIntoView Selection.Range, True
End Sub

Sub ShowNone()
    If clearOriginal Then
        With ActiveWindow.view.RevisionsFilter
            .markup = wdRevisionsMarkupSimple
            .view = wdRevisionsViewFinal
        End With
    End If
    With ActiveWindow.view
        .ShowRevisionsAndComments = False
        .RevisionsView = wdRevisionsViewFinal
    End With
    ActiveWindow.ScrollIntoView Selection.Range, True
End Sub
Sub ShowSimple()
    clearOriginal = False ' changing to simple markup removes the "Original" flag
    With ActiveWindow.view.RevisionsFilter
        .markup = wdRevisionsMarkupSimple
        .view = wdRevisionsViewFinal
    End With
    ActiveWindow.ScrollIntoView Selection.Range, True

End Sub

Sub ShowAllEdits()
    On Error Resume Next
    If clearOriginal Then
        With ActiveWindow.view.RevisionsFilter
            .markup = wdRevisionsMarkupSimple
            .view = wdRevisionsViewFinal
        End With
    End If
    With ActiveWindow.view
        .ShowRevisionsAndComments = False
        .RevisionsFilter.markup = wdRevisionsMarkupAll
    End With
    ActiveWindow.ScrollIntoView Selection.Range, True
End Sub
Sub EditViewToggle()
    Select Case ActiveWindow.view.MarkupMode
    Case wdBalloonRevisions
        ActiveWindow.view.MarkupMode = wdInLineRevisions
        StatusBar = "Show all revisions inline"
    Case wdInLineRevisions
        ActiveWindow.view.MarkupMode = wdMixedRevisions
        StatusBar = "Show only comments and formatting in balloons"
    Case wdMixedRevisions
        ActiveWindow.view.MarkupMode = wdBalloonRevisions
        StatusBar = "Show revisions in balloons"
    End Select
End Sub

Sub AuthorViewToggle()
    ActiveWindow.view.RevisionsFilter.Reviewers("Author").Visible = Not ActiveWindow.view.RevisionsFilter.Reviewers("Author").Visible
End Sub

Function saveView() As Scripting.Dictionary
    Dim d As New Scripting.Dictionary
    With ActiveWindow.view
        d.Add "ShowRevisionsAndComments", .ShowRevisionsAndComments
        d.Add "RevisionsView", .RevisionsView
    End With
    With ActiveWindow.view.RevisionsFilter
        d.Add "Markup", .markup
        d.Add "View", .view
    End With
    Set saveView = d
End Function
Function restoreView(d As Scripting.Dictionary)
    With ActiveWindow.view
        .ShowRevisionsAndComments = d("ShowRevisionsAndComments")
        .RevisionsView = d("RevisionsView")
    End With
    With ActiveWindow.view.RevisionsFilter
        .markup = d("Markup")
        .view = d("View")
    End With
End Function
Function getCurrentView() As String
    With ActiveWindow.view
        If .ShowRevisionsAndComments = False And _
            .RevisionsView = wdRevisionsViewOriginal Then
            getCurrentView = "Original"
        ElseIf .ShowRevisionsAndComments = True And _
            .RevisionsView = wdRevisionsViewFinal Then
            getCurrentView = "Final"
        ElseIf .ShowRevisionsAndComments = False And _
            .RevisionsView = wdRevisionsViewFinal Then
            getCurrentView = "None"
        End If
        With .RevisionsFilter
            If .markup = wdRevisionsMarkupSimple And _
                .view = wdRevisionsViewFinal Then
                getCurrentView = "Simple"
            ElseIf .markup = wdRevisionsMarkupAll Then
                getCurrentView = "All Markup"
            End If
        End With
    End With
End Function
Sub pushMarkup()
    savedMarkup = savedMarkup & CStr(ActiveWindow.view.RevisionsFilter.markup)
End Sub
Function popMarkup() As WdRevisionsMarkup
    If Len(savedMarkup) > 0 Then
        popMarkup = CInt(Right$(savedMarkup, 1))
        savedMarkup = left$(savedMarkup, Len(savedMarkup) - 1)
    Else
        popMarkup = -1
    End If
End Function
' NOTE: setMarkupFilter and restoreMarkupFilter are intended to be used as a pair; the set operation saves the current
'       filter and sets the filter to the markup argument. The restore operation restore the saved filter.
Sub setMarkupFilter(markup As WdRevisionsMarkup)
    Call pushMarkup
    ActiveWindow.view.RevisionsFilter.markup = markup
End Sub
Sub restoreMarkupFilter()
    Dim markup As WdRevisionsMarkup
    markup = popMarkup
    If markup >= 0 Then
        ActiveWindow.view.RevisionsFilter.markup = markup
    End If
…