Sub kommentare_auslesen()
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 = "Kommentare in ein neues Dokument exportieren"
Set oDoc = ActiveDocument
nCount = ActiveDocument.Comments.Count
If nCount = 0 Then
MsgBox "The active document contains no comments.", vbOKOnly, Title
GoTo ExitHere
Else
If MsgBox("Alle Kommentare in ein neues Dokument exportieren?", _
vbYesNo + vbQuestion, Title) <> vbYes Then
GoTo ExitHere
End If
End If
Application.ScreenUpdating = False
Set oNewDoc = Documents.Add
oNewDoc.PageSetup.Orientation = wdOrientLandscape
With oNewDoc
.Content = ""
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
NumRows:=nCount + 1, _
NumColumns:=7)
End With
With oTable
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 5
.Columns(2).PreferredWidth = 23
.Columns(3).PreferredWidth = 26
.Columns(4).PreferredWidth = 10
.Columns(5).PreferredWidth = 12
.Columns(6).PreferredWidth = 12
.Columns(7).PreferredWidth = 12
.Rows(1).HeadingFormat = True
End With
With oTable.Rows(1)
.Range.Font.Bold = True
.Cells(1).Range.Text = "Seite"
.Cells(2).Range.Text = "Kommentierter Text"
.Cells(3).Range.Text = "Kommentar"
.Cells(4).Range.Text = "Author"
.Cells(5).Range.Text = "Datum"
.Cells(6).Range.Text = "Kapitel"
.Cells(7).Range.Text = "Überschrift"
End With
For n = 1 To nCount
With oTable.Rows(n + 1)
.Cells(1).Range.Text = _
oDoc.Comments(n).Scope.Information(wdActiveEndPageNumber)
.Cells(2).Range.Text = oDoc.Comments(n).Scope
.Cells(3).Range.Text = oDoc.Comments(n).Range.Text
.Cells(4).Range.Text = oDoc.Comments(n).author
.Cells(5).Range.Text = Format(oDoc.Comments(n).Date, "dd.MM.yyyy")
End With
Next n
Application.ScreenUpdating = True
Application.ScreenRefresh
oNewDoc.Activate
MsgBox nCount & " Kommentare gefunden. Neues Kommentar Export Dokument wurde erstellt.", vbOKOnly, Title
ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
End Sub