Überarbeitungsfenster drucken

von **Pummel** » 10.03.2010, 09:45

Deine MS-Office-Version: 2007
Suite Deines Office Pakets: Home and Student
AddIn installiert: Nein
Dein Wissensstand: Einsteiger

Welches Virenschutz-Programm hast Du installiert? antivir
Betriebssystem Version: Win XP

Was hast Du gemacht, bevor das Problem aufgetreten ist?

Was hast Du bereits versucht um das Problem zu lösen?

Fehlerbeschreibung und Nachricht
Hallo liebe Office Experten,

ich habe ein Dokument mit vielen Änderungen.

Diese Änderungen kann man sich ja in einem Überarbeitungsfenster anzeigen lassen..

Meine Frage: Wie kann ich dieses Überarbeitungsfenster, mit Kommentaren etc gesondert abspeichern?

Wenn ich alles markiere dann kann ich den Inhalt des Fensters nicht kopieren.

Habe da schon ein Makro im WWW gefunden, dieses erstellt ein neues Dokument mit den Änderungen des Textes,lässt aber die ganzen Kommentare weg.

Hat da jemand eine Idee?

Hier der Code:

'Attribute VB_Name = "basTrackChanges_Extract"
Sub UeberarbeitungsfensterineigenesDocsichern()

Dim oDoc As Document
Dim oNewDoc As Document
Dim oTable As Table
Dim oRow As Row
Dim oCol As Column
Dim oRange As Range
Dim oRevision As Revision
Dim strText As String
Dim n As Long
Dim i As Long
Dim Title As String

Titel = "Das Überarbeitungsfenster in ein neues Dokument extrahieren"
n = 0 'use to count extracted changes

Set oDoc = ActiveDocument

If oDoc.Revisions.Count = 0 Then
MsgBox "Das geöffnete Dokument enthält keine Überarbeitung!", vbOKOnly, Title
GoTo ExitHere
Else
'Stop if user does not click Yes
If MsgBox("Wollen Sie die Überarbeitungen in einem neuen Dokument darstellen?" & vbCr & vbCr & _
"NOTE: Only insertions and deletions will be included. " & _
"All other types of changes will be skipped.", _
vbYesNo + vbQuestion, Title) <vbYes> 0
'Find each Chr(2) in strText and replace by appropriate text
i = InStr(1, strText, Chr(2))

If oRange.Footnotes.Count = 1 Then
strText = Replace(Expression:=strText, _
Find:=Chr(2), Replace:="[footnote reference]", _
Start:=1, Count:=1)
'To keep track of replace, adjust oRange to start after i
oRange.Start = oRange.Start + i

ElseIf oRange.Endnotes.Count = 1 Then
strText = Replace(Expression:=strText, _
Find:=Chr(2), Replace:="[endnote reference]", _
Start:=1, Count:=1)
'To keep track of replace, adjust oRange to start after i
oRange.Start = oRange.Start + i
End If
Loop
End With
'Add 1 to counter
n = n + 1
'Add row to table
Set oRow = oTable.Rows.Add

'Insert data in cells in oRow
With oRow
'Page number
.Cells(1).Range.Text = _
oRevision.Range.Information(wdActiveEndPageNumber)

'Line number - start of revision
.Cells(2).Range.Text = _
oRevision.Range.Information(wdFirstCharacterLineNumber)

'Type of revision
If oRevision.Type = wdRevisionInsert Then
.Cells(3).Range.Text = "Inserted"
'Apply automatic color (black on white)
oRow.Range.Font.Color = wdColorAutomatic
Else
.Cells(3).Range.Text = "Deleted"
'Apply red color
oRow.Range.Font.Color = wdColorRed
End If

'The inserted/deleted text
.Cells(4).Range.Text = strText

'The author
.Cells(5).Range.Text = oRevision.Author

'The revision date
.Cells(6).Range.Text = Format(oRevision.Date, "dd-mm-yyyy")
End With
End Select
Next oRevision

'If no insertions/deletions were found, show message and close oNewDoc
If n = 0 Then
MsgBox "Keine Eintragungen und Löschungen gefunden.", vbOKOnly, Title
oNewDoc.Close savechanges:=wdDoNotSaveChanges
GoTo ExitHere
End If

'Apply bold formatting and heading format to row 1
With oTable.Rows(1)
.Range.Font.Bold = True
.HeadingFormat = True
End With

Application.ScreenUpdating = True
Application.ScreenRefresh

oNewDoc.Activate
MsgBox n & " Veränderungen wurden extrahiert. " & _
"Erstellung des Dokuments abgeschlossen.", vbOKOnly, Title

ExitHere:
Set oDoc = Nothing
Set oNewDoc = Nothing
Set oTable = Nothing
Set oRow = Nothing
Set oRange = Nothing
End Sub

Gruß
Pummel

Unsere Foren

Überarbeitungsfenster drucken

Überarbeitungsfenster drucken

Wer ist online?