PDA

View Full Version : test vba



rtwwpad
05-30-2012, 04:24 PM
Public Sub ExtractCommentsToNewDoc()

'Macro created 2007 by Lene Fredborg, DocTools - www.thedoctools.com (http://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

zhenghan1019
11-06-2012, 01:47 AM
:thumb