Option Explicit
Dim b_Test As Boolean->True=Testbetrieb, False=realer Betrieb
'**********************************************************************
Sub MitFormatierungszeichenDrucken()
Dim doc As Document, s_Dateiname_Full As String, s_Dateiname_Full_tmp As String
Set doc = ActiveDocument
b_Test = False->True=Testbetrieb, False=realer Betrieb
If b_Test Then doc.Save
->prüfen, ob Dokument gespeichert ist
If Not doc.Saved Then
MsgBox (Bitte speichern sie das Dokument vor dem Aufruf diese Makros.)
Else
->Datei unter temporärem Namen speichern
s_Dateiname_Full = doc.FullName
s_Dateiname_Full_tmp = _
Left(s_Dateiname_Full, Len(s_Dateiname_Full) - 4) & _
_MirNdF & _
Right(s_Dateiname_Full, 4)
Application.DisplayAlerts = False
doc.SaveAs FileName:=s_Dateiname_Full_tmp
Application.DisplayAlerts = True
->nicht druckbare Formatierungszeichen als Text einfügen
Call NichtDruckbareFormatierungszeichen_AlsTextEinfuegen(doc)
If Not b_Test Then
->tmp. Dokument ausdrucken
doc.PrintOut
Else
->tmp. Dokument als Seitenansicht
doc.PrintPreview
ActiveWindow.ActivePane.View.Zoom.Percentage = 150
MsgBox (So ok ?)
End If
->tmp Dokumentschliessen und löschen
doc.Close savechanges:=False
Kill (s_Dateiname_Full_tmp)
->ursprüngliches Dokument öffnen
Documents.Open FileName:=s_Dateiname_Full
End If
Set doc = Nothing
End Sub
'**********************************************************************
Function NichtDruckbareFormatierungszeichen_AlsTextEinfuegen(doc As Document)
Dim s_Absatzmarke As String
Dim s_ManuellerZeilenwechsel As String
Dim s_GeschuetzterBindestrich As String
Dim s_GeschuetztesLeerzeichen As String
Dim s_Kommentarzeichen As String
Dim s_Leerzeichen As String
Dim s_Grafik As String
Dim r As Range
->versionsspezifische Formatbezeichnung
Call BezeichnungenFormatierungszeichenFuerVersionFestlegen( _
s_Absatzmarke, _
s_ManuellerZeilenwechsel, _
s_GeschuetzterBindestrich, _
s_GeschuetztesLeerzeichen, _
s_Kommentarzeichen, _
s_Leerzeichen, _
s_Grafik)
->Range gesamtes Dokument
Set r = doc.Content
->Absatzmarke
Call myAlleZeichenErsetzen(r, s_Absatzmarke, ¶ & s_Absatzmarke, , 0)
->manueller Zeilenumbruch
Call myAlleZeichenErsetzen(r, s_ManuellerZeilenwechsel, _
Chr(191) & s_ManuellerZeilenwechsel, Symbol, 0)
->bedingte Trennzeichen
Call myAlleZeichenErsetzen(r, ^-, Chr(216), Symbol, 0)
->geschützte Leerzeichen
Call myAlleZeichenErsetzen(r, s_GeschuetztesLeerzeichen, Chr(176), Symbol, 0)
->Leerzeichen
->!!! muß nach geschützte Leerzeichen erfolgen, sonst werden diese auch gesetzt
Call myAlleZeichenErsetzen(r, , Chr(215), Symbol, 0)
->Tabulator
Call myTabZeichenEinfuegen(doc, r)
->manueller Seitenwechsel
Call myAlleZeichenErsetzen(r, ^m, _
String(25, Chr(151)) & Seitenwechsel & String(25, Chr(151)) & ^m, , 6)
->manueller Spaltenwechsel
Call myAlleZeichenErsetzen(r, ^n, _
String(10, Chr(151)) & Spaltenwechsel & String(10, Chr(151)) & ^n, , 6)
->Abschnittswechsel
Call myAlleZeichenErsetzen(r, ^b, _
String(10, Chr(61)) & Abschnittswechsel & String(10, Chr(61)), , 6)
doc.Range(Start:=1, End:=1).Select
AUFRAEUMEN:
Set r = Nothing
End Function
'**********************************************************************
Private Function myAlleZeichenErsetzen(r As Range, _
s_text As String, s_RepText As String, _
s_RepFontName As String, s_RepFontSize As String)
With r.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = s_text
.Replacement.Text = s_RepText
.Format = False
If s_RepFontName <> Then .Replacement.Font.Name = s_RepFontName: .Format = True
If s_RepFontSize <> 0 Then .Replacement.Font.Size = Val(s_RepFontSize): .Format = True
.Forward = True
.Wrap = wdFindContinue
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
On Error Resume Next
.Execute Replace:=wdReplaceAll
If b_Test Then MsgBox (bearbeitet: & s_text)
On Error GoTo 0
End With
End Function
'**********************************************************************
Private Function BezeichnungenFormatierungszeichenFuerVersionFestlegen( _
s_Absatzmarke As String, _
s_ManuellerZeilenwechsel As String, _
s_GeschuetzterBindestrich As String, _
s_GeschuetztesLeerzeichen As String, _
s_Kommentarzeichen As String, _
s_Leerzeichen As String, _
s_Grafik As String)
If Val(Application.Version) > 8 Then
->ab Word-2000
s_Absatzmarke = ^p
s_ManuellerZeilenwechsel = ^l
s_GeschuetzterBindestrich = ^~
s_GeschuetztesLeerzeichen = ^s
s_Kommentarzeichen = ^a
s_Leerzeichen = ^w
s_Grafik = ^g
Else
->Word-97
s_Absatzmarke = ^a
s_ManuellerZeilenwechsel = ^z
s_GeschuetzterBindestrich = ^_
s_GeschuetztesLeerzeichen = ^g
s_Kommentarzeichen = ^5
s_Leerzeichen = ^l
s_Grafik = ^r
End If
End Function
'**********************************************************************
Private Function myTabZeichenEinfuegen(doc As Document, r As Range)
Const c_NORMALFONTGROESSE = 6
Const c_MINFONTGROESSE = 2
Dim l_start As Long, l_end As Long
Dim l_Distance As Long, l_Distance2 As Long, x As Long
r.Select
l_start = Selection.Start
l_end = Selection.End
Do
doc.Range(Start:=l_start, End:=l_end).Select
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ^t
.Forward = False
.Wrap = wdFindStop
If Not .Execute Then Exit Function
End With
->neues Ende für nächste Suche setzen
l_end = Selection.Start
->Distanz zum linken Seitenrand des nächsten Zeichens nach dem TAB
->OHNE eingefügtes TAB-Symbol
Selection.MoveRight Unit:=wdCharacter, Count:=1
l_Distance = Selection.Information(wdHorizontalPositionRelativeToPage)
->TAB-Symbol vor TAB einfügen
Selection.Move Unit:=wdCharacter, Count:=-1
Selection.InsertSymbol CharacterNumber:=174, Font:=Symbol, Unicode:=False
Selection.Move Unit:=wdCharacter, Count:=-1
Selection.Expand Unit:=wdCharacter
Selection.Font.Size = c_NORMALFONTGROESSE
->Distanz zum linken Seitenrand des nächsten Zeichens nach dem TAB
->MIT eingefügtem TAB-Symbol
Selection.Move Unit:=wdCharacter, Count:=2
l_Distance2 = Selection.Information(wdHorizontalPositionRelativeToPage)
If l_Distance <> l_Distance2 Then
->Wenn sich Position des nächsten Zeichens nach dem TAB verändert hat,
->Font-Größe des Symbols verkleinern, solange
->bis sich Position nicht verändert oder min.FontGröße erreicht ist
For x = c_NORMALFONTGROESSE - 1 To c_MINFONTGROESSE Step -1
->TAB-Symbol Font verkleinern
Selection.Move Unit:=wdCharacter, Count:=-2
Selection.Expand Unit:=wdCharacter
Selection.Font.Size = x
->Distanz zum linken Seitenrand des nächsten Zeichens nach dem TAB
->MIT eingefügtem TAB-Symbol
Selection.Move Unit:=wdCharacter, Count:=2
l_Distance2 = Selection.Information(wdHorizontalPositionRelativeToPage)
->Jetzt passt es
If l_Distance = l_Distance2 Then Exit For
Next
->Position des nächsten Zeichens nach dem TAB hat sich verändert
->dann TAB-Symbol wieder löschen
If l_Distance <> l_Distance2 Then
Selection.Move Unit:=wdCharacter, Count:=-2
Selection.Expand Unit:=wdCharacter
Selection.Delete
End If
End If
Loop
End Function
