Mittels wordwrap() können längere Texte umgebrochen werden, ohne dass die Wörter zerstückelt werden

Download udf_wordwrap.bas (V-1.0.0)

    Dim text As String
    text = "Seit heute wird der Fahrplan im Bahnhof Zürich auf einem 19 Meter breiten LED-Bildschirm angezeigt. Je 15 Quadratmeter aber sind für Werbung reserviert."
    Debug.Print wordwrap(text, 25)

Seit heute wird der
Fahrplan im Bahnhof
Zürich auf einem 19 Meter
breiten LED-Bildschirm
angezeigt. Je 15
Quadratmeter aber sind
für Werbung reserviert.

udf_wordwrap.bas

Attribute VB_Name = "udf_wordwrap"
'-------------------------------------------------------------------------------
'File         : udf_wordwrap.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/wordwrap
'Environment  : VBA 2007 +
'Version      : 1.0.0
'Name         : wordwrap
'Author       : Stefan Erb (ERS)
'History      : 20.10.2015 - ERS - Creation
'-------------------------------------------------------------------------------
Option Explicit
 
'/**
' * Paramters zur Funktion wordwrap()
' */
Public Enum eWrapParams
    ewwDefault = 0
    ewwReturnArray = 2 ^ 0  'Gibt ein Array anstelle eiens Strings zurück. Der Parameter iBreak wird ignoriert
    ewwCutLongWords = 2 ^ 1 'Zerschneidet überlange Wörter
    ewwRemoveBreaks = 2 ^ 2 'Bestehende Zeilnumbrüche im Originaltext werden entfernt
End Enum
 
'/**
' * Zerschneidet einen Text. Dabei wird versucht die Wörter zusammenzuhalten
' * @param  String          Der Text
' * @param  Long            Maxiale Zeilenlänge
' * @param  eWrapParams     Settings zur Funktion. Siehe Enum eWrapParams. Die Parameter sind komulierbar
' * @param  String          Trennzeichen. Normalerweise ein Zeilenumbruch (vbCrLf)
' * @return Variant         String oder Array, je nach Paramter
' */
Public Function wordwrap(ByVal iText As String, ByVal iMaxLen As Long, Optional ByVal iParams As eWrapParams = ewwDefault, Optional ByVal iBreak As String = vbCrLf) As Variant
    'Die Regulären Ausdrücke erstellen. iMaxLen ist bestandteil des Pattern
    'Standartlänge
    Dim rxDefault As Object:    Set rxDefault = cRx("/^(\s*)(.{1," & iMaxLen - 1 & "}\S(?=(?:\s|$)))/i")
    'Wenn ein Wort grösser als iMaxLen ist
    Dim rxLongWord As Object:   Set rxLongWord = cRx("/^(\s*)(\S{" & iMaxLen & ",}(?=(?:\s|$)))/i")
 
    Dim outRowIdx As Long
    Dim outRows() As String
    Dim m As Object         'Match
 
    Dim text As String: text = IIf((iParams And ewwRemoveBreaks) = ewwRemoveBreaks, Replace(iText, iBreak, " "), iText)
 
    'Alle Inputzeilen durchiterieren
    Dim rest As Variant: For Each rest In Split(text, iBreak)
        'Abschnitt für Abschnitt herausnehmen.
        Do While rxDefault.test(rest) Or rxLongWord.test(rest)
            'Normale Zeile
            If rxDefault.test(rest) Then
                Set m = rxDefault.execute(rest)(0)
                addItem outRows, outRowIdx, m.subMatches(1)
                rest = Mid(rest, m.length + 1)
            'Ein Wort ist länger als iMaxLen
            ElseIf rxLongWord.test(rest) Then
                Set m = rxLongWord.execute(rest)(0)
                'Das Wort zerstückeln. Also die ersten iMaxLen Zeichen auswählen
                If (iParams And ewwCutLongWords) = ewwCutLongWords Then
                    addItem outRows, outRowIdx, Left(m.subMatches(1), iMaxLen)
                    rest = Mid(rest, Len(m.subMatches(0)) + iMaxLen + 1)    'Länge der alle vorgehender Leerzeichen + iMaxLen abschneiden
                'Das Wort mit Überlänge ausgeben
                Else
                    addItem outRows, outRowIdx, m.subMatches(1)
                    rest = Mid(rest, m.length + 1)
                End If
            End If
        Loop
    Next
    'Je nach Parameter den return anderst handhaben
    If (iParams And ewwReturnArray) = ewwReturnArray Then
        wordwrap = outRows
    Else
        wordwrap = Join(outRows, iBreak)
    End If
End Function
 
'/**
' * Setzt ein Wert in einem Array auf einen Index und zählt den Index um eins hoch
' * @param  Array
' * @param  Long
' * @param  Value
' */
Private Sub addItem(ByRef ioArray As Variant, ByRef ioNextIndex As Long, ByVal iValue As Variant)
    ReDim Preserve ioArray(ioNextIndex)
    ioArray(ioNextIndex) = iValue
    ioNextIndex = ioNextIndex + 1
End Sub
 
'/**
' * Dies ist die Minimalversion von cRegExp
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version
' * mögliche Delemiter: @&!/~#=\|
' * mögliche Modifiers: g (Global), i (IgnoreCode, m (Mulitline)
' *
' * @example    myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase
' * @version    2.1.0 (01.12.2014)
' * @param      String      Pattern mit Delimiter und Modifier analog zu PHP
' * @return     Object      RegExp-Object
' */
Private Function cRx(ByVal iPattern As String) As Object
    Static rxP As Object:       Set cRx = CreateObject("VBScript.RegExp")
    If rxP Is Nothing Then:     Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    Dim sm As Object:           Set sm = rxP.execute(iPattern)(0).subMatches
    cRx.pattern = sm(1):        cRx.IgnoreCase = Not isEmpty(sm(2)):       cRx.Global = Not isEmpty(sm(3)):     cRx.Multiline = Not isEmpty(sm(4))
End Function
 
 
'/**
' * Splittet ein String in Teile nach einer vordefinierten Grösse auf
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/strsplit
' *
' *     array = strSplit(string [,teillänge])
' *
' * @param  String      zu zerlegender String
' * @param  Integer     Grösse der Teile
' * @return Array<String>
' */
Private Function strSplit(ByVal iString As String, Optional ByVal iSplitLen As Integer = 1) As String()
    If Len(iString) = 0 Then Exit Function
    Dim size As Integer:    size = (Len(iString) \ iSplitLen + IIf(Len(iString) Mod iSplitLen > 0, 1, 0))
    Dim retArr() As String: ReDim retArr(size - 1)
 
    Dim i As Integer: For i = 0 To size - 1
        retArr(i) = Mid(iString, (i * iSplitLen) + 1, iSplitLen)
    Next i
    strSplit = retArr
End Function