Mittels wordwrap() können längere Texte umgebrochen werden, ohne dass die Wörter zerstückelt werden
string = wordwrap(string, long [,eWrapParams [,long]])
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
EIn String oder ein Stringarray. Je nach eWrapParams.
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
Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r()
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.
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."
print_r wordwrap(text, 25, ewwReturnArray)
<String()> ( [0] => <String> 'Seit heute wird der' [1] => <String> 'Fahrplan im Bahnhof' [2] => <String> 'Zürich auf einem 19 Meter' [3] => <String> 'breiten LED-Bildschirm' [4] => <String> 'angezeigt. Je 15' [5] => <String> 'Quadratmeter aber sind' [6] => <String> 'für Werbung reserviert.' )
Standart. Das zu lange Wort wird nicht zerstückelt
text = "Die Autobahnbrückenspezialbeschilderung ist falsch" Debug.Print wordwrap(text, 25)
Die Autobahnbrückenspezialbeschilderung ist falsch
Das Wort zerstückeln
text = "Die Autobahnbrückenspezialbeschilderung ist falsch" Debug.Print wordwrap(text, 25, ewwCutLongWords)
Die Autobahnbrückenspezialbes childerung ist falsch
Und das noch kombiniert mit der Array-Ausgabe
text = "Die Autobahnbrückenspezialbeschilderung ist falsch"
print_r wordwrap(text, 25, ewwCutLongWords + ewwReturnArray)
<String()> ( [0] => <String> 'Die' [1] => <String> 'Autobahnbrückenspezialbes' [2] => <String> 'childerung ist falsch' )
Nehmen wir mal ein Text, der Bereits Zeilenumbrüche hat. Diese Sollen natürlich erhalten bleiben
text = " Ausgetrocknetes Flussbett." & vbCrLf & "Die Töss führt diesen Oktober so gut wie kein Wasser." Debug.Print wordwrap(text, 20)
Ausgetrocknetes Flussbett. Die Töss führt diesen Oktober so gut wie kein Wasser.
Oder der Zeilenumbruch wird entfernt
text = " Ausgetrocknetes Flussbett." & vbCrLf & "Die Töss führt diesen Oktober so gut wie kein Wasser." Debug.Print wordwrap(text, 20, ewwRemoveBreaks)
Ausgetrocknetes Flussbett. Die Töss führt diesen Oktober so gut wie kein Wasser.
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