VBA - Word 2007

Computer: Software & Programmierung Visual Basic
1

Lieber Experten,
ich habe drei Makros mit Word 2007 aufgezeichnet und möchte gerne, dass diese Makros bestimmte Textteile in einem Dokument doppelt durchstreichen. Es handelt sich um
1.
2. [Text in eckigen Klammern] und um
3. //Text zwischen doppelten Schrägstrichen und der nächsten Absatzmarke.
Die Makros funktionieren, jedoch nur einmal. Ich würde die Makros gerne jeweils das Dokument von Anfang bis Ende abarbeiten lassen, doch schaffe ich es nicht, eine Schleife zu basteln.

Wer könnte eine Schleife um die Makros (s.u.) herum schreiben? Oder gibt es noch eine andere Lösung, als die Dokumente von Anfang bis Ende abzuarbeiten?
Danke im Voraus.
Januario

  1. Sub SpitzKlammRaus()
    ’
    ’ SpitzKlammRaus Makro
    ’
    ’
    Selection.Find.ClearFormatting
    With Selection.Find
    .Text = „“
    With Selection.Font
    .Name = „Courier New“
    .Size = 10.5
    .Bold = False
    .Italic = False
    .Underline = wdUnderlineNone
    .UnderlineColor = wdColorAutomatic
    .StrikeThrough = False
    .DoubleStrikeThrough = True
    .Outline = False
    .Emboss = False
    .Shadow = False
    .Hidden = False
    .SmallCaps = False
    .AllCaps = False
    .Color = wdColorAutomatic
    .Engrave = False
    .Superscript = False
    .Subscript = False
    .Spacing = 0
    .Scaling = 100
    .Position = 0
    .Kerning = 0
    .Animation = wdAnimationNone
    End With
    End Sub
  1. Sub DSlashZeilenDurchstreich()
    ’
    ’ DSlashZeilenDurchstreich Makro
    ’
    ’
    Selection.Find.ClearFormatting
    With Selection.Find
    .Text = „//“
    .Replacement.Text = „“
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
    With Selection.Font
    .Name = „Courier New“
    .Size = 10.5
    .Bold = False
    .Italic = False
    .Underline = wdUnderlineNone
    .UnderlineColor = wdColorAutomatic
    .StrikeThrough = False
    .DoubleStrikeThrough = True
    .Outline = False
    .Emboss = False
    .Shadow = False
    .Hidden = False
    .SmallCaps = False
    .AllCaps = False
    .Color = wdColorAutomatic
    .Engrave = False
    .Superscript = False
    .Subscript = False
    .Spacing = 0
    .Scaling = 100
    .Position = 0
    .Kerning = 0
    .Animation = wdAnimationNone
    End With
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    End Sub

Sub SpitzKlammDurchstreich()
’
’ SpitzKlammDurchstreich Makro
’
’
Selection.Find.ClearFormatting
With Selection.Find.all
.Text = „“
With Selection.Font
.Name = „Courier New“
.Size = 10.5
.Bold = False
.Italic = False
.Underline = wdUnderlineNone
.UnderlineColor = wdColorAutomatic
.StrikeThrough = False
.DoubleStrikeThrough = True
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.Color = wdColorAutomatic
.Engrave = False
.Superscript = False
.Subscript = False
.Spacing = 0
.Scaling = 100
.Position = 0
.Kerning = 0
.Animation = wdAnimationNone
End With
Selection.MoveRight Unit:=wdCharacter, Count:=1
End Sub

2

Hallo Januario,

  2. [Text in eckigen Klammern] und um
  3. //Text zwischen doppelten Schrägstrichen und der nächsten
    Absatzmarke.

Die Makros funktionieren, jedoch nur einmal.

mag sein, aber mit eckigen Klammern geschieht nix in den Codes.

Ich würde die
Makros gerne jeweils das Dokument von Anfang bis Ende
abarbeiten lassen, doch schaffe ich es nicht, eine Schleife zu
basteln.

Option Explicit

Sub Test()
Call SpitzKlammRaus
Call SlashZeilenDurchstreich
Call EckigeKlammerRaus
End Sub

Sub EckigeKlammerRaus()
Dim Anz1() As String, N As Long
Anz1 = Split(ActiveDocument.Range.Text, "[")
If UBound(Anz1) UBound(Split(ActiveDocument.Range.Text, "]")) Then
 MsgBox "Anzahl von [und] unterschiedlich"
 Exit Sub
End If
Selection.HomeKey Unit:=wdStory
For N = 1 To UBound(Anz1)
 Selection.Extend Character:="["
 Selection.MoveRight Unit:=wdCharacter, Count:=1 ', Extend:=wdExtend
 Selection.Extend Character:="]"
 Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
 Selection.Font.DoubleStrikeThrough = True
 Selection.Font.Name = "Courier New"
Next N
Selection.HomeKey Unit:=wdStory
End Sub

Sub SlashZeilenDurchstreich()
Dim Anz1() As String, N As Long
Anz1 = Split(ActiveDocument.Range.Text, "//")
Selection.HomeKey Unit:=wdStory
For N = 1 To UBound(Anz1)
 Selection.Extend Character:="/"
 Selection.MoveRight Unit:=wdCharacter, Count:=2
 Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
 Selection.Font.DoubleStrikeThrough = True
 Selection.Font.Name = "Courier New"
Next N
Selection.HomeKey Unit:=wdStory
End Sub

Sub SpitzKlammRaus()
Dim Anz1() As String, N As Long
Anz1 = Split(ActiveDocument.Range.Text, " UBound(Split(ActiveDocument.Range.Text, "\>")) Then
 MsgBox "Anzahl von unterschiedlich"
 Exit Sub
End If
Selection.HomeKey Unit:=wdStory
For N = 1 To UBound(Anz1)
 Selection.Extend Character:=""
 Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
 Selection.Font.DoubleStrikeThrough = True
 Selection.Font.Name = "Courier New"
Next N
Selection.HomeKey Unit:=wdStory
End Sub

Gruß
Reinhard

3

Hola Januario,

aufgrund deiner Mail neue Varianten.

Gruß
Reinhard

Option Explicit

Sub Test()
Call SpitzKlammRaus
Call DoubleSlash
Call EckigeKlammerRaus
End Sub

Sub DoubleSlash()
Selection.HomeKey Unit:=wdStory
Do While Selection.Find.Execute(FindText:="//", Forward:=True, Format:=True) = True
 Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
 Selection.Font.DoubleStrikeThrough = True
 Selection.Font.Name = "Courier New"
 Selection.MoveRight Unit:=wdCharacter, Count:=1
Loop
Selection.HomeKey Unit:=wdStory
End Sub

Sub EckigeKlammerRaus()
Dim Anz1() As String
Anz1 = Split(ActiveDocument.Range.Text, "[")
If UBound(Anz1) UBound(Split(ActiveDocument.Range.Text, "]")) Then
 MsgBox "Anzahl von [und] unterschiedlich"
 Exit Sub
End If
Selection.HomeKey Unit:=wdStory
Do While Selection.Find.Execute(FindText:="[", Forward:=True, Format:=True) = True
 Selection.Extend Character:="]"
 Selection.Font.DoubleStrikeThrough = True
 Selection.Font.Name = "Courier New"
 Selection.MoveRight Unit:=wdCharacter, Count:=1
Loop
Selection.HomeKey Unit:=wdStory
End Sub

Sub SpitzKlammRaus()
Dim Anz1() As String
Anz1 = Split(ActiveDocument.Range.Text, " UBound(Split(ActiveDocument.Range.Text, "\>")) Then
 MsgBox "Anzahl von unterschiedlich"
 Exit Sub
End If
Selection.HomeKey Unit:=wdStory
Do While Selection.Find.Execute(FindText:=""
 Selection.Font.DoubleStrikeThrough = True
 Selection.Font.Name = "Courier New"
 Selection.MoveRight Unit:=wdCharacter, Count:=1
Loop
Selection.HomeKey Unit:=wdStory
End Sub