Consulting

Results 1 to 2 of 2

Thread: Existing macro needs modification for desired result

  1. #1
    VBAX Newbie
    Joined
    Jan 2021
    Posts
    1
    Location

    Existing macro needs modification for desired result

    We have a macro created to detect Tracked Change pages and a 2nd call macro that detects comments, PDFs are created for each of the pages. It works well with the exception that it will not detect track change pages in a text box. The code is below, anybody have any suggestions? (my very first post so apologies if I did this wrong).

    Sub PrintRevisionPagesOnly()
    ' Print only pages with recorded revisions
    ' keyboard shortcut = Alt-P
    ' NOTE: if Track Changes is not enabled there ARE
    ' no recorded revisions. If Track Changes not enabled
    ' the code offers to enable it.
    Dim oRange As Word.Range
    Dim intPageCount As Integer
    Dim var
    Dim response
    Dim sFileName
    Dim sFilePath
    Dim sFolderPath
    Dim sAppName

    Dim sArg
    sAppName = "C:\PDFMerge\PDF_Merge.exe "
    sFolderPath = "C:\DataTest"
    sFileName = ActiveDocument.Name


    sFilePath = sFolderPath
    sFileName = Left(sFileName, (InStrRev(sFileName, ".", -1, vbTextCompare) - 1))
    sArg = """" & sFolderPath & """" & " " & """" & sFileName & "_Revision.pdf" & """"
    ActiveWindow.View.RevisionsFilter.Markup = wdRevisionsMarkupAll
    If ActiveDocument.Range.Revisions.Count > 0 Then
    intPageCount = _
    ActiveDocument.BuiltInDocumentProperties("Number of Pages")
    'ActiveDocument.Range.Information (wdNumberOfPagesInDocument)
    Selection.HomeKey Unit:=wdStory
    On Error Resume Next
    ActiveDocument.PrintRevisions = True

    For var = 1 To intPageCount


    Set oRange = _
    ActiveDocument.Range _
    (Start:=ActiveDocument.Bookmarks("\page").Start, _
    End:=ActiveDocument.Bookmarks("\page").End - 1)
    If (oRange.Revisions.Count > 0) Then
    sFilePath = sFolderPath
    sFilePath = sFilePath + CStr(var) + ".pdf"
    Selection.ExportAsFixedFormat sFilePath, wdExportFormatPDF, _
    False, wdExportOptimizeForPrint, True, wdExportDocumentWithMarkup, True, True, wdExportCreateNoBookmarks, _
    True, True, False
    DoEvents
    Selection.GoToNext wdGoToPage
    Else
    Selection.GoToNext wdGoToPage
    End If
    Set oRange = Nothing
    Next
    Else
    Select Case ActiveDocument.TrackRevisions
    Case False
    response = MsgBox("There are no recorded revisions in this " & _
    "document. Track Changes is not enabled. Would " & _
    "you like to turn Track Changes on?", vbYesNo)
    If response = vbYes Then ActiveDocument.TrackRevisions = True
    Case True
    MsgBox "There are no tracked revisions in this document."
    End Select
    End If
    Call FindComment(sFolderPath)
    Call Shell(sAppName, vbNormalFocus)
    End Sub
    Sub FindComment(ByVal FolderPath As String)
    '
    ' FindComments Macro
    '
    '
    Dim oRange As Word.Range
    Dim intPageCount As Integer
    Dim var
    Dim response
    Dim sFileName
    Dim sFilePath
    If ActiveDocument.Range.Revisions.Count > 0 Then
    intPageCount = _
    ActiveDocument.BuiltInDocumentProperties("Number of Pages")
    'ActiveDocument.Range.Information (wdNumberOfPagesInDocument)
    Selection.HomeKey Unit:=wdStory
    On Error Resume Next
    ActiveDocument.PrintRevisions = True

    For var = 1 To intPageCount
    Set oRange = _
    ActiveDocument.Range _
    (Start:=ActiveDocument.Bookmarks("\page").Start, _
    End:=ActiveDocument.Bookmarks("\page").End - 1)
    If (oRange.Comments.Count > 0) Then
    sFilePath = FolderPath
    sFilePath = sFilePath + CStr(var) + ".pdf"
    Selection.ExportAsFixedFormat sFilePath, wdExportFormatPDF, _
    False, wdExportOptimizeForPrint, True, wdExportDocumentWithMarkup, True, True, wdExportCreateNoBookmarks, _
    True, True, False
    DoEvents
    Selection.GoToNext wdGoToPage
    Else
    Selection.GoToNext wdGoToPage
    End If
    Set oRange = Nothing
    Next
    End If

    End Sub

  2. #2
    Text boxes are in the graphics layer of the document so are not seen by the code when processing the document range. You would also have to loop through the shapes in your document and process those shapes that are text boxes e.g.
    Dim oShape As Shape    
         For Each oShape In ActiveDocument.Shapes
            If oShape.Type = 17 Then 'msoTextBox
                oShape.Select
                MsgBox Selection.Range.Revisions.Count
            End If
        Next
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Tags for this Thread

Posting Permissions

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