Jede Zeile rückwärts

25/08/2007 - 21:07 von Helmut Weber | Report spam
Liebe Schlaumeier,

mal eine schöne Herausforderung.

In einem einfachen Word-Dokument
sollen alle Zeilen umgedreht werden,
also von hinten nach vorne:

"Schönen Abend noch" wird zu

"hcon dnebA nenöhcS"

In den Private Groups schrieb Jerry Latham:

"I have come in contact with a person who suffers from
Strephosymbolia. Picture it as a "worst case" case of dyslexia.
Everything they read, or try to write, appears to them as if in a
mirror. In point of fact, he does most of his computer work while
looking into a mirror set up to reflect his monitor's display."

Wàre schön, wenn alles so einfach wàre.

Public Function ReverseStr(sX As String) As String
Dim x As Long
Dim c As String
For x = 1 To Len(sX) / 2
c = Mid(sX, x, 1)
Mid(sX, x, 1) = Mid(sX, Len(sX) - x + 1, 1)
Mid(sX, Len(sX) - x + 1, 1) = c
Next
ReverseStr = sX
End Function

So weit bin ich gekommen:

Sub JLatham()
Dim lDoc As Long
Dim lLin As Long
Dim oPrg As Paragraph
ActiveDocument.Range(0, 0).Select
Selection.ExtendMode = False

While ActiveDocument.Paragraphs.Last.Range = Chr(13)
ActiveDocument.Paragraphs.Last.Range.Select
ActiveDocument.Paragraphs.Last.Range.Delete
Wend

ActiveDocument.Range(0, 0).Select

lDoc = ActiveDocument.ComputeStatistics(wdStatisticLines)
For lLin = 1 To lDoc
Selection.Bookmarks("\line").Range.Select
If Len(Selection) > 1 Then
If Selection.Characters.Last = Chr(13) Then
Selection.End = Selection.End - 1
End If
If Selection.Characters.Last = Chr(11) Then
Selection.End = Selection.End - 1
End If
If Selection.Characters.Last = Chr(32) Then
Selection.Characters.Last = Chr(11)
End If
Selection.Text = ReverseStr(Selection.Text)
End If
Selection.MoveDown
Selection.HomeKey unit:=wdLine
Next
End Sub

Das produziert mir aber einige ungewollte leere Absàtze.

Letztendlich will ich jede Zeile
von hinten nach vorne haben,
und beim nàchsten Aufruf des Makros
den Ausgangszustand zurück.

Viel Spass beim Knobeln.


Gruß

Helmut Weber, MVP WordVBA

"red.sys" & chr$(64) & "t-online.de"
Win XP, Office 2003 (US-Versions)
 

Lesen sie die antworten

#1 Helmut Weber
26/08/2007 - 10:30 | Warnen spam
Im Wesentlichen erledigt.

Sub JLathamA()
Dim lDoc As Long
Dim lLin As Long
Dim oPrg As Paragraph

Selection.ExtendMode = False

' remove spaces from paragraphs end
For Each oPrg In ActiveDocument.Paragraphs
While oPrg.Range.Characters.Last.Previous = " "
oPrg.Range.Characters.Last.Previous = ""
Wend
Next

' remove empty paragraphs from the doc's end
While ActiveDocument.Paragraphs.Last.Range = Chr(13)
ActiveDocument.Paragraphs.Last.Range.Delete
Wend

ActiveDocument.Range(0, 0).Select

lDoc = ActiveDocument.ComputeStatistics(wdStatisticLines)
' There are other ways to loop
' this is just the simplest way, I think
With Selection
For lLin = 1 To lDoc
.Bookmarks("\line").Range.Select
' remove multiple spaces from a line's end
While .Characters.Last = " " And _
.Characters.Last.Previous = " "
.Characters.Last.Delete
Wend
If Len(Selection) > 1 Then
If .Characters.Last = Chr(13) Then
.End = .End - 1
End If
If .Characters.Last = Chr(11) Then
.End = .End - 1
End If
If .Characters.Last = Chr(32) Then
.Characters.Last = Chr(11)
End If
.Text = ReverseStr(.Text)
End If
.MoveDown
.HomeKey unit:=wdLine
Next
End With
End Sub

Public Function ReverseStr(sX As String) As String
Dim x As Long
Dim c As String
For x = 1 To Len(sX) / 2
c = Mid(sX, x, 1)
Mid(sX, x, 1) = Mid(sX, Len(sX) - x + 1, 1)
Mid(sX, Len(sX) - x + 1, 1) = c
Next
ReverseStr = sX
End Function


Gruß

Helmut Weber, MVP WordVBA

"red.sys" & chr$(64) & "t-online.de"
Win XP, Office 2003 (US-Versions)

Ähnliche fragen