Consulting

Results 1 to 2 of 2

Thread: test vba

  1. #1
    VBAX Regular
    Joined
    May 2012
    Posts
    18
    Location

    test vba

    [vba]Public Sub ExtractCommentsToNewDoc()

    'Macro created 2007 by Lene Fredborg, DocTools - www.thedoctools.com
    'The macro creates a new document
    'and extracts all comments from the active document
    'incl. metadata

    'Minor adjustments are made to the styles used
    'You may need to change the style settings and table layout to fit your needs
    'amended for by Phil Thomas May 2012
    '=========================

    Dim oDoc As Document
    Dim oNewDoc As Document
    Dim oTable As Table
    Dim nCount As Long
    Dim n As Long
    Dim Title As String

    Title = "Extract All Comments to New Document"
    Set oDoc = ActiveDocument
    nCount = ActiveDocument.Comments.Count

    If nCount = 0 Then
    MsgBox "The active document contains no comments.", vbOKOnly, Title
    GoTo ExitHere
    Else
    'Stop if user does not click Yes
    If MsgBox("Do you want to extract all comments to a new document?", _
    vbYesNo + vbQuestion, Title) <> vbYes Then
    GoTo ExitHere
    End If
    End If

    Application.ScreenUpdating = True
    'Create a new document for the comments, base on Normal.dot
    Set oNewDoc = Documents.Add
    'Set to landscape
    oNewDoc.PageSetup.Orientation = wdOrientLandscape
    'Insert a 8-column table for the comments
    With oNewDoc
    .Content = ""
    Set oTable = .Tables.Add _
    (Range:=Selection.Range, _
    NumRows:=nCount + 1, _
    NumColumns:=8)
    End With

    'Insert info in header - change date format as you wish
    oNewDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
    "Comments extracted from: " & oDoc.FullName & vbCr & _
    "Created by: " & Application.UserName & vbCr & _
    "Creation date: " & Format(Date, "MMMM d, yyyy")

    'Adjust the Normal style and Header style
    With oNewDoc.Styles(wdStyleNormal)
    .Font.Name = "Arial"
    .Font.Size = 10
    .ParagraphFormat.LeftIndent = 0
    .ParagraphFormat.SpaceAfter = 6
    End With

    With oNewDoc.Styles(wdStyleHeader)
    .Font.Size = 8
    .ParagraphFormat.SpaceAfter = 0
    End With

    'Format the table appropriately
    With oTable
    .AllowAutoFit = False
    .Style = "Table Grid"
    .PreferredWidthType = wdPreferredWidthPercent
    .PreferredWidth = 100
    .Columns(1).PreferredWidth = 5
    .Columns(2).PreferredWidth = 5
    .Columns(3).PreferredWidth = 5
    .Columns(4).PreferredWidth = 20
    .Columns(5).PreferredWidth = 20
    .Columns(6).PreferredWidth = 10
    .Columns(7).PreferredWidth = 15
    .Columns(7).Shading.BackgroundPatternColor = -570359809
    .Columns(8).PreferredWidth = 20
    .Columns(8).Shading.BackgroundPatternColor = -570359809
    .Rows(1).HeadingFormat = True
    End With

    'Insert table headings
    With oTable.Rows(1)
    .Range.Font.Bold = True
    .Shading.BackgroundPatternColor = 5296274
    .Cells(1).Range.Text = "Comment"
    .Cells(2).Range.Text = "Page"
    .Cells(3).Range.Text = "Line on Page" ' will be replaced with sectiosn once I get them working
    .Cells(4).Range.Text = "Comment scope"
    .Cells(5).Range.Text = "Comment text"
    .Cells(6).Range.Text = "Author"
    .Cells(7).Range.Text = "Response Summary (Accept/Reject/Defer)"
    .Cells(8).Range.Text = "Response to comment"
    End With

    'Repaginate
    ActiveDocument.Repaginate

    'Toggle nonprinting characters twice
    ActiveWindow.ActivePane.View.ShowAll = Not _
    ActiveWindow.ActivePane.View.ShowAll

    ActiveWindow.ActivePane.View.ShowAll = Not _
    ActiveWindow.ActivePane.View.ShowAll



    'Get info from each comment from oDoc and insert in table
    For n = 1 To nCount
    With oTable.Rows(n + 1)
    .Cells(1).Range.Text = n
    'Page number
    .Cells(2).Range.Text = oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
    ' The line number
    '.Cells(3).Range.Text = oDoc.Comments(n).Scope.Information(wdFirstCharacterLineNumber)- keep for line numbers if I can't get Section headings
    .Cells(3).Range.Text = oDoc.Comments(n).Scope.Paragraphs(1).Range.ListFormat.ListString
    'The text marked by the comment
    .Cells(4).Range.Text = oDoc.Comments(n).Scope
    'The comment itself
    .Cells(5).Range.Text = oDoc.Comments(n).Range.Text
    'The comment author
    .Cells(6).Range.Text = oDoc.Comments(n).Author
    End With
    Next n

    Application.ScreenUpdating = True
    Application.ScreenRefresh

    oNewDoc.Activate
    MsgBox nCount & " comments found. Finished creating comments document.", vbOKOnly, Title

    ExitHere:
    Set oDoc = Nothing
    Set oNewDoc = Nothing
    Set oTable = Nothing

    End Sub


    [/vba]

  2. #2

Posting Permissions

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