Lange Strings aufteilen
Will man z.B. einen Artikeltext in einem Formular oder bei einer Word-Ausgabe ausgeben, weiss man oft nicht wie lang der Text ist, und man ist genötigt den String zu kürzen.
Man kann aber auch den Text in einzelne Zeilen aufsplitten, die man in ein Array schreibt. Daraus kann man z.B. Strings zusammensetzen und ein vbcrlf zwischen die einzelnen Zeilen schreiben. Oder bei der zeilenweisen Ausgabe in ein Worddokument, z.B. ein Angebot, direkt aus dem Array schreiben.
Der Algorithmus für diesen Ablauf ist im Groben:
– Prüfen ob String größer als x-Zeichen
– Schleife über alle Zeichen setzen
– Teilstringe der größe x bilden
– Teilstringe untersuchen und Trennzeichen finden (Leerzeichen, Punkt, Komma)
– Wörter die länger als x sind mit Bindestrich aufteilen
– Bearbeitung des letzten Teilstrings
– Ende Schleife
– einzelne Teilstrings säubern (Leerzeichen am Anfang, vbcrlf)
Nachfolgend die aus dem Algorithmus implementierte Funktion:
Public Function SplitText(strText As String, maxlen As Long)
Dim strZeile As String, lastSign As String
Dim i As Long, k As Long, m As Long, pos1 As Long
Dim ascID As Integer, addieren As Integer, strecke As Long
'falls ein Enter in der Zeile steckt: durch Leerzeichen ersetzen
strZeile = Replace(strZeile, vbCrLf, " ")
If Len(strText) > maxlen Then
'Schleife solange, bis alle Zeichen des Textes abgearbeitet wurden
Do Until m >= Len(strText)
If Len(strText) - m > maxlen Then
k = m + 1
m = k + maxlen
'String mit der Länge maxlen an der Position k herausschneiden
strZeile = Mid(strText, k - addieren, maxlen)
lastSign = Mid(strText, InStr(1, strText, strZeile) + Len(strZeile), 1)
If lastSign = " " Or lastSign = "." Or lastSign = "," Then
'erstes Zeichen nach String ist ein " ", "." oder ",".
'strecke ist die Anzahl Zeichen in der i-te Zeile
strecke = maxlen
Else
'auf Leerzeichen Prüfen und die strecke anpassen
strecke = InStrRev(strZeile, " ") - 1
'falls ein Wort länger als maxlen ist
If strecke <= 0 Then
strZeile = Left(strZeile, maxlen - 1) & "-"
strecke = Len(strZeile)
addieren = 1
End If
m = k + strecke - 1
End If
'jetzt wird das Array an der Stelle i besetzt.
arrZeile(i) = Mid(strZeile, 1, strecke)
Else
'der letzte Rest des Strings verarbeiten
arrZeile(i) = Right(strText, Len(strText) - m)
pos1 = InStr(2, arrZeile(i), vbCrLf)
If pos1 > 0 Then
'es gibt doch noch Zeichen am Ende
arrZeile(i) = Left(arrZeile(i), pos1 - 1)
m = m + pos1
Else
m = Len(strText)
End If
End If
' Zähler für die Array-Position inkrementieren
i = i + 1
'falls mehr Zeilen notwendig wären
If i > UBound(arrZeile) Then
Exit Do
End If
Loop
Else
'der Text passt in die erste Zeile hinein
arrZeile(0) = strText
End If
'erstes Zeichen aller Zeilen auf Leerzeichen
For k = 0 To i - 1
ascID = Asc(Left(arrZeile(k), 1))
If ascID = 32 Or ascID = 10 Or ascID = 13 Then
arrZeile(k) = Right(arrZeile(k), Len(arrZeile(k)) - 1)
End if
Next k
End Function
Anwendung:
Globale Variable in einem Module:
Public arrZeile(99) As String
Beispielaufruf der Funktion:
Private Sub Form_Open(Cancel As Integer)
Dim strText As String, Ausgabestring As String
Dim i As Long
strText = "Ein ganz langer Text blablabla...."
SplitText strText, 45
For i = 0 To UBound(arrZeile)
If Len(arrZeile(i)) = 0 Then
Exit For
End If
Ausgabestring = Ausgabestring & arrZeile(i) & vbCrLf
Next i
Ausgabestring = Left(Ausgabestring, Len(Ausgabestring) - 1)
MsgBox Ausgabestring
End Sub
AV 2008
———————————————————————————————————————————————————–
OK, 2.5 Jahre später sieht man das mit anderen Augen. Obiger Code lässt sich auch stark vereinfachen:
Public Function SplitText(strText As String, Optional maxlen As Long = 50) As Variant Dim insertStr As String Dim i As Long, k As Long, start As Long Dim arrText() As Variant ReDim arrText(Int(Abs(Len(strText) / maxlen) * -1) * Sgn(Len(strText) / maxlen) * -1) start = 1 Do While Len(Nz(strText, "")) - start > maxlen insertStr = Mid(Nz(strText, ""), start, maxlen) Do While Mid(insertStr, maxlen - k, 1) <> " " And Mid(insertStr, maxlen - k, 1) <> "." And Mid(insertStr, maxlen - k, 1) <> "," k = k + 1 Loop If k > 0 Then insertStr = Left(insertStr, Len(insertStr) - k) start = start - k End If If Asc(Right(insertStr, 1)) = 32 Then insertStr = Left(insertStr, Len(insertStr) - 1) End If arrText(i) = insertStr start = start + maxlen i = i + 1 k = 0 Loop start = start - 1 If Len(Nz(strText, "")) - start > 0 Then arrText(i) = Right(Nz(strText, ""), Len(Nz(strText, "")) - start) End If SplitText = arrText End Function
Die Funktion teilt den String bei der Stelle maxlen, prüft ob die Stelle ein Leerzeichen oder ein Komma oder ein Punkt ist, wenn nicht wird rückwärts bis zum nächsten Trennzeichen gegangen.
Der Aufruf könnte dann z.B. so aussehen:
Sub Test() Dim testString As String Dim ausgabeArr As Variant testString = "Lorem ipsum dolor sit amet, consetetur sadipscing elitr,......." ausgabeArr = SplitText(testString) End Sub
Bis dahin
Andreas Vogt © 2011