Access Blog

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