Consulting

Results 1 to 3 of 3

Thread: Counting the number of revisions by a specific author

  1. #1
    VBAX Regular
    Joined
    Oct 2016
    Posts
    45
    Location

    Counting the number of revisions by a specific author

    Is it possible to count the number of revisions made by a specific author? That is not my ultimate end goal, but would be extremely useful for something I'm working.

    I know that you can count revisions in a document, but wonder if you can be more selective. Basically, I'm clumsily putting something together that will let you go through insertion or deletion and change the apparent author name (I know you can't do it directly, so it's basically a case of the code rejecting the change but then reapplying them so that the current username becomes the apparent author).

    I've got something that works, but it goes through every insertion and deletion, regardless of author. I want to make it skip revisions made by authors who are not of interest. However, in order to stop the code going into an endless loop, I need to get it to exit if the document does not contain any more insertions or deletions made by a specified author.

    The key area of the code that needs this ability to break out of the loop is at the SelRN2 region, where there is an IF test to skip a revision if the author is not the one specified previously.


    Public Sub Track_Rev_Nm_Chng()
        Dim nCount As Long
        Dim sNext, sUsername, sUserInit, sOrigname, sOriInit, selAuth, AuthChng As String
        Dim ReturnValue As Integer
        
        sOrigname = Application.UserName
        sOriInit = Application.UserInitials
        nCount = ActiveDocument.Revisions.Count
        
        If nCount = 0 Then
            MsgBox "There are no tracked changes.", vbOKOnly, Title
            GoTo Ending
        Else
            If MsgBox("Change user name first?", vbYesNo) = vbYes Then
                sUsername = InputBox("New user name", _
                            "Insert full name")
                            If sUsername = "" Then End
        
                sUserInit = InputBox("New user initials", _
                            "Insert initials")
    
    
                Application.UserName = sUsername
                Application.UserInitials = sUserInit
                GoTo Revs
            Else
                sUsername = sOrigname
            End If
    
    
            selAuth = MsgBox("Only select revisions from specific person?", vbYesNo)
            If selAuth = vbNo Then
    Revs:
                If MsgBox("Next track change?", vbYesNo) = vbYes Then
                    Selection.NextRevision (True)
                        sNext = MsgBox("Change name?", vbYesNo)
                        If sNext = vbYes Then
                            With Selection
                            If .Range.Revisions(1).Type = wdRevisionInsert Then
                                Selection.Copy
                                Selection.Range.Revisions.RejectAll
                                Selection.PasteAndFormat (wdFormatOriginalFormatting)
                                GoTo Revs
                            Else
                                If .Range.Revisions(1).Type = wdRevisionDelete Then
                                    Selection.Range.Revisions.RejectAll
                                    Selection.Cut
                                    GoTo Revs
                                End If
                            End If
                            End With
                        Else
                            If sNext = vbNo Then
                                GoTo Revs
                            End If
                        End If
                Else
                    GoTo Revert
                End If
            Else
                If selAuth = vbYes Then
    SelR:
                    AuthChng = InputBox("Reviewer name to replace")
                        If AuthChng = "" Then GoTo Ending
    
    
    SelRN1:
                    If MsgBox("Next track change?", vbYesNo) = vbYes Then
    SelRN2:
                        Selection.NextRevision (True)
                            If Selection.Range.Revisions(1).Author = AuthChng Then
                                sNext = MsgBox("Change name?", vbYesNo)
                                If sNext = vbYes Then
                                    With Selection
                                    If .Range.Revisions(1).Type = wdRevisionInsert Then
                                        Selection.Copy
                                        Selection.Range.Revisions.RejectAll
                                        Selection.PasteAndFormat (wdFormatOriginalFormatting)
                                        GoTo SelRN1
                                    Else
                                        If .Range.Revisions(1).Type = wdRevisionDelete Then
                                            Selection.Range.Revisions.RejectAll
                                            Selection.Cut
                                            GoTo SelRN1
                                        End If
                                    End If
                                    End With
                                Else
                                    If sNext = vbNo Then
                                        GoTo SelRN1
                                    End If
                                End If
                            Else
                                GoTo SelRN2
                            End If
                    Else
                        GoTo Revert
                    End If
                End If
            End If
    Revert:
            If sUsername = sOrigname Then
                GoTo Ending
            Else
                If MsgBox("Revert user name?", vbYesNo) = vbYes Then
                    Application.UserName = sOrigname
                    Application.UserInitials = sOriInit
                    GoTo Ending
                Else
                    GoTo Ending
                End If
            End If
        End If
        
    Ending:
        ReturnValue = MsgBox("Process ended", vbOKOnly, "Revision author alterations")
        End Sub
    Last edited by h2whoa; 03-08-2018 at 07:08 AM.

  2. #2
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    A different approach:

    Public Sub RevisionAuthorChange()
    Dim lngRevCount As Long
    Dim strAppAuthorInitials As String, strAppAuthorName As String
    Dim strRevAuthorName As String, strRevAuthorInitials As String
    Dim strRevAuthorToReview As String
    Dim bAll As Boolean
    Dim colRevs
    Dim oRev As Revision
    Dim lngCount As Long
    Dim lngView As Long
      lngView = ActiveDocument.ActiveWindow.View
      bAll = True
      Set colRevs = fcnRevs
      lngRevCount = colRevs.Count
      If lngRevCount = 0 Then
        MsgBox "There are no tracked insertions or deletions.", vbOKOnly, "Title"
        Exit Sub
      End If
      strAppAuthorName = Application.UserName
      strAppAuthorInitials = Application.UserInitials
      If MsgBox("Current author is " & strAppAuthorName & ". Do you want to change the revision author?", vbYesNo) = vbYes Then
        strRevAuthorName = InputBox("New author name", "Insert full name")
        strRevAuthorInitials = InputBox("New auhtor initials", "Insert initials")
        Application.UserName = strRevAuthorName
        Application.UserInitials = strRevAuthorInitials
      Else
        strRevAuthorName = strAppAuthorName
      End If
      If MsgBox("Do you want to review revisions by all authors?", vbYesNo, "REVIEW ALL") = vbNo Then
        strRevAuthorInitials = InputBox("Reveiw revisions by:", "Define Author")
        bAll = False
      End If
      For Each oRev In colRevs
        lngCount = lngCount + 1
        If oRev.Type = wdRevisionDelete Or oRev.Type = wdRevisionInsert Then
          If oRev.Author = strRevAuthorInitials Or bAll Then
            oRev.Range.Select
            If MsgBox("Do you want to change the author of this revision to " & Application.UserName & "?", vbYesNo, "CHANGE REVISION AUTHOR") = vbYes Then
              Select Case oRev.Type
                Case wdRevisionInsert
                   Selection.Copy
                   Selection.Range.Revisions.RejectAll
                   Selection.PasteAndFormat (wdFormatOriginalFormatting)
                Case wdRevisionDelete
                   Selection.Range.Revisions.RejectAll
                   Selection.Cut
              End Select
            End If
          End If
        End If
        If lngCount = lngRevCount Then Exit For
      Next oRev
      If Not strRevAuthorName = strAppAuthorName Then
        If MsgBox("Restore original Application User Name?", vbYesNo) = vbYes Then
          Application.UserName = strAppAuthorName
          Application.UserInitials = strAppAuthorInitials
        End If
      End If
    lbl_Exit:
      ActiveDocument.ActiveWindow.View = lngView
      MsgBox "Process ended", vbOKOnly, "Revision author alterations"
    End Sub
    Function fcnRevs() As Collection
    Dim rngStory As Word.Range
    Dim lngIndex As Long
    Dim oShp As Shape
    Dim oRev As Revision
    lngIndex = ActiveDocument.Sections(1).Headers(1).Range.StoryType
    For Each rngStory In ActiveDocument.StoryRanges
    Dim oColl As New Collection
      'Iterate through all linked stories
      Do
        On Error Resume Next
        For Each oRev In rngStory.Revisions
          If oRev.Type = wdRevisionDelete Or oRev.Type = wdRevisionInsert Then
            lngIndex = lngIndex + 1
            oColl.Add oRev, CStr(lngIndex)
          End If
        Next oRev
        Select Case rngStory.StoryType
          Case 6, 7, 8, 9, 10, 11
            If rngStory.ShapeRange.Count > 0 Then
              For Each oShp In rngStory.ShapeRange
                If oShp.TextFrame.HasText Then
                  If oRev.Type = wdRevisionDelete Or oRev.Type = wdRevisionInsert Then
                    oColl.Add oRev, CStr(lngIndex + 1)
                  End If
                End If
              Next
            End If
          Case Else
            'Do Nothing
        End Select
        On Error GoTo 0
        'Get next linked story (if any)
        Set rngStory = rngStory.NextStoryRange
      Loop Until rngStory Is Nothing
    Next
      Set fcnRevs = oColl
    End Function
    Greg

    Visit my website: http://gregmaxey.com

  3. #3
    VBAX Regular
    Joined
    Oct 2016
    Posts
    45
    Location
    Greg, this is brilliant. Thank you so much! Really appreciate your help.

    Sidenote: I love this community. Blown away by how clever and generous with advice people are here.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •