User Tools

Site Tools


vba:functions:wordwrap

[VBA] wordwrap()

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

Version 1.0.0 - 20.10.2015

Definition

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
  • iText Der Text, der zerlegt werden soll
  • iMaxLen Maxiale Zeilenlänge
  • iParams Settings zur Funktion. Siehe Enum eWrapParams. Die Parameter sind komulierbar
  • iBreak Trennzeichen. Normalerweise ein Zeilenumbruch (vbCrLf)

Return

EIn String oder ein Stringarray. Je nach eWrapParams.

Enumerator 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

Beispiele

Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r()

→ Read more...

Standartanwendung

    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.

Rückgabe als Array

    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.'
)

Wörter die Länger als die erlabute Zeilenlänge sind

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'
)

Text mit Zeilenumbruch

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.

Code

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
 

Discussion

Enter your comment. Wiki syntax is allowed:
If you can't read the letters on the image, download this .wav file to get them read to you.
 
vba/functions/wordwrap.txt · Last modified: 21.10.2015 11:26:26 by yaslaw