Community Pick: Many members of our community have endorsed this article.
Editor's Choice: This article has been selected by our editors as an exceptional contribution.

The end of a pilgrimage to find a more robust WordWrap function

ltlbearand3
CERTIFIED EXPERT
Published:
Updated:
What Started It All
I had an instance recently where I needed to take text from a textbox on a VBA form and split the text into separate lines to send to a zebra printer.  The catch was that I needed the text to break at the same line points as the VBA textbox.  The textbox was configured with multiline and wordwrap enabled.  Searching all over the internet for a function or idea to accomplish this task, I found plenty of examples of wrapping text based on already included carriage returns or just of a space and character count, but not what I needed.  A VBA textbox may or may not have carriage returns and it splits text on more than just spaces.  

This led me on a quest to build a word wrap function mimicking the wrapping of a textbox.  Working through coding and testing, I ended up creating a few different versions.  The earlier versions were better than what I had found, but not good enough for my needs.  They are posted here in case they are good enough for you.  The original function returned data in a string array, but it was easy to adjust it to return as single string with carriage returns to break apart each line.  That code is also included.

Breakdown of the basic code:
A textbox has a variety of rules on how it separates text.  The first step is to take the text and split it into an array based on already defined line feeds.  Use the line feed (vbLf) as this will catch user entered returns from both Enter Key (If EnterKeyBehavior = True) and Cntrl-Enter (if EnterKey Behavior=False).
strLineData = Split(TextToWrap, vbLf)
                      

Open in new window

Then use regular expressions to break each line into separate words.  (Regular expressions allow a quick way to break the text into words).  I defined a pattern to follow the rules of a textbox.  (If you find a mistake in the logic, please post your fix to make it better).  The RegEx pattern definition:
' This is the RegEx List for Characters that should be grouped with the text that follows them
                      ' ${(<[\ - Have to use escape character "\" for ] and \
                      strStartGroup = "${(<\[\\"
                      ' This is the RegEx List for Characters that should be grouped with the text the preceeds them
                      ' !)}%>?-] - Have to use escape character "\" for - and ]
                      strEndGroup = "!)}%>?\-\]"
                      ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                      strRegPattern = "[" & strStartGroup & "]?"
                      ' Now grab all characters that are not part of special list and no spaces \s
                      ' [] = Group.  Find Anything listed in this group.  + = Find 1 to many instances.
                      ' Equates to finding whole words including some special characters (those not in list since negative comparison)
                      strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"
                      ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                      strRegPattern = strRegPattern & "[" & strEndGroup & "]?"
                      objRegExp.Pattern = strRegPattern
                      

Open in new window

Using this defined pattern, Loop Through each line and break it into "words".
Set objWordList = objRegExp.Execute(strLine)
                      

Open in new window

Then came my calculations on what would fit considering the parameters of Characters or Point Width.  I have tried to comment the code examples below well enough to explain the logic being used.  

The first function I created calculated the width of each line by the number of characters per line.  These can work well for you if you are using a fixed width font.  They are simplier and will run slightly faster.  

I have included a VBScript version using late binding.  

WordWrapByCharacterToArray Function:
Here is the first function.  To use this function, send it the text that you want word wrapped and the maximum number of characters per line.  It will return a string array with each line as a separate element in the array.

Example Usage:
Dim strLines() As String
                      strLines = WordWrapByCharacterToArray(TextToWrap:=TextBox1.Text, LengthOfLine:=20)
                      For i = 0 To UBound(strLines)
                              Debug.Print strLines(i)
                      Next
                      

Open in new window

Function
'---------------------------------------------------------------------------------------
                      ' Function  : WordWrapByCharacterToArray
                      ' Date      : 03/21/2012
                      ' Purpose   : Will Return a String array of line data wrapped at proper break points
                      '               for a given line length as determined by the number of characters.
                      '               It uses the same rules as a VBA text box
                      '
                      ' Usage     : Set a string array = to WordWrapByCharacterToArray sending WordWrapByCharacterToArray
                      '               your text and maximum length for each line
                      '               Example:
                      '               Dim strLines() as string
                      '               strLines = WordWrapByCharacterToArray("This is my text I want to wrap around something", 15)
                      '               This will break the string into multiple lines with a maximum length of 15 characters per line
                      '---------------------------------------------------------------------------------------
                      '
                      Public Function WordWrapByCharacterToArray(ByVal TextToWrap As String, _
                          ByVal LengthOfLine As Long) As String()
                      
                      
                          On Error GoTo WordWrapByCharacterToArray_Error:
                          Dim objRegExp As VBScript_RegExp_55.RegExp
                          Dim objWordList As VBScript_RegExp_55.MatchCollection
                          Dim objWord As VBScript_RegExp_55.Match
                          Dim strStartGroup As String
                          Dim strEndGroup As String
                          Dim strRegPattern As String
                          Dim intLineNum As Integer: intLineNum = 0
                          Dim intLinePos As Integer
                          Dim strReturn() As String
                          Dim strLineData() As String
                          Dim strLine As Variant
                          Dim intNumCharUsed As Integer
                          
                          ' Instantiate RegEx
                          Set objRegExp = New VBScript_RegExp_55.RegExp
                          
                          ' ------------------------------------
                          ' Set Set Font Settings
                          ' ------------------------------------
                          ' Make sure we were sent a good line width
                          If LengthOfLine < 1 Then
                              ' Return an Error
                              Err.Raise Number:=vbObjectError + 605, Description:="Requested Length of Line must be greater than 0"
                          End If
                          
                          ' ------------------------------------
                          ' Set RegEx Settings
                          ' ------------------------------------
                          objRegExp.MultiLine = False
                          objRegExp.Global = True
                          
                          ' ------------------------------------
                          ' Set the Search Pattern
                          ' ------------------------------------
                          ' This is the RegEx List for Characters that should be grouped with the text that follows them
                          ' ${(<[\ - Have to use escape character "\" for ] and \
                          strStartGroup = "${(<\[\\"
                          ' This is the RegEx List for Characters that should be grouped with the text the preceeds them
                          ' !)}%>?-] - Have to use escape character "\" for - and ]
                          strEndGroup = "!)}%>?\-\]"
                          ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                          strRegPattern = "[" & strStartGroup & "]?"
                          ' Now grab all characters that are not part of special list and no spaces \s
                          ' [] = Group.  Find Anything listed in this group.  + = Find 1 to many instances.
                          ' Equates to finding whole words including some special characters (those not in list since negative comparison)
                          strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"
                          ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                          strRegPattern = strRegPattern & "[" & strEndGroup & "]?"
                          objRegExp.Pattern = strRegPattern
                          
                          ' ------------------------------------
                          ' Break up Original String into already defined lines
                          ' ------------------------------------
                          strLineData = Split(TextToWrap, vbLf)
                          
                          ' ------------------------------------
                          ' Set Original Size of Return Array to just one line.  Can Expand Later
                          ' ------------------------------------
                          ReDim Preserve strReturn(0)
                          
                          ' ------------------------------------
                          ' Loop through each line to wrap text if needed
                          ' ------------------------------------
                          For Each strLine In strLineData
                              ' Reset the Line Position for this set of text
                              intLinePos = 0
                          
                              ' Make sure the line is long enough to need to be wrapped
                              If Len(strLine) > LengthOfLine Then
                                  
                                  ' ------------------------------------
                                  ' Get the list of words defined by the Pattern
                                  ' ------------------------------------
                                  Set objWordList = objRegExp.Execute(strLine)
                                  
                                  ' ------------------------------------
                                  ' Build the Return Array
                                  ' ------------------------------------
                                  For Each objWord In objWordList
                                      ' See if this word is too big to Fit
                                      If objWord.Length > LengthOfLine Then
                                          ' Word is too big for the line, have to break it appart
                                          ' Reset the Number of Characters used in this word to 1
                                          intNumCharUsed = 1
                                          
                                          ' First see if we have any remaining words that should be added to the previous line
                                          If objWord.FirstIndex - intLinePos > 0 Then
                                              ' See if we need to expand the array
                                              If UBound(strReturn) < intLineNum Then
                                                  ' ReDim the Array
                                                  ReDim Preserve strReturn(intLineNum)
                                              End If
                                              
                                              ' Save Previous Line
                                              strReturn(intLineNum) = Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos)
                                              
                                              ' Reset the Line Position
                                              intLinePos = objWord.FirstIndex
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          End If
                                          
                                          Do While intNumCharUsed < objWord.Length
                                              ' See if we need to expand the array
                                              If UBound(strReturn) < intLineNum Then
                                                  ' ReDim the Array
                                                  ReDim Preserve strReturn(intLineNum)
                                              End If
                                              
                                              ' Get as many characters as will fit on the line
                                              strReturn(intLineNum) = Mid(objWord.Value, intNumCharUsed, LengthOfLine)
                                              
                                              ' Increase the Number used counter
                                              intNumCharUsed = intNumCharUsed + Len(strReturn(intLineNum))
                                              
                                              ' Reset the Line Position
                                              intLinePos = intLinePos + Len(strReturn(intLineNum))
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          Loop
                                      Else
                                          If objWord.FirstIndex - intLinePos + objWord.Length > LengthOfLine Then
                                              ' See if we need to expand the array
                                              If UBound(strReturn) < intLineNum Then
                                                  ' ReDim the Array
                                                  ReDim Preserve strReturn(intLineNum)
                                              End If
                                              
                                              ' This word will not fit on current Line.  Save Current Line
                                              strReturn(intLineNum) = Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos)
                                              
                                              ' Reset the Line Position
                                              intLinePos = objWord.FirstIndex
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          End If
                                      End If 'objWord.Length > LengthOfLine
                                  Next
                                  
                                  ' ------------------------------------
                                  ' See if there is any text yet to add
                                  ' ------------------------------------
                                  If (Len(strLine) - intLinePos) > 0 Then
                                      ' See if we need to expand the array
                                      If UBound(strReturn) < intLineNum Then
                                          ' ReDim the Array
                                          ReDim Preserve strReturn(intLineNum)
                                      End If
                                  
                                      ' Save of the Last bits of Data
                                      strReturn(intLineNum) = Right(strLine, Len(strLine) - intLinePos)
                                          
                                      ' Increment our line Counter
                                      intLineNum = intLineNum + 1
                                  End If
                              Else
                                  ' ------------------------------------
                                  ' The entire line fits.  Add it now
                                  ' ------------------------------------
                                  
                                  ' See if we need to expand the array
                                  If UBound(strReturn) < intLineNum Then
                                      ' ReDim the Array
                                      ReDim Preserve strReturn(intLineNum)
                                  End If
                                  
                                  strReturn(intLineNum) = strLine
                                          
                                  ' Increment our line Counter
                                  intLineNum = intLineNum + 1
                              End If
                          Next
                          
                          ' Return our Array
                          WordWrapByCharacterToArray = strReturn
                          
                      Release:
                          On Error Resume Next
                          Erase strReturn
                          Set objWordList = Nothing
                          Set objWord = Nothing
                          Set objRegExp = Nothing
                          Exit Function
                          
                      WordWrapByCharacterToArray_Error:
                          MsgBox "Procedure = WordWrapByCharacterToArray" & vbCrLf & _
                              "Error Number = " & Err.Number & vbCrLf & _
                              "Error Message = " & Err.Description & vbCrLf, _
                              vbCritical Or vbSystemModal, "Word Wrap Error"
                          
                          Resume Release:
                      End Function
                      

Open in new window

VBScript Version:
'---------------------------------------------------------------------------------------
                      ' Function  : WordWrapByCharacterToArray
                      ' Date      : 03/21/2012
                      ' Purpose   : Will Return a String array of line data wrapped at proper break points
                      '               for a given line length as determined by the number of characters.
                      '               It uses the same rules as a VBA text box
                      '
                      ' Usage     : Set a string array = to WordWrapByCharacterToArray sending WordWrapByCharacterToArray
                      '               your text and maximum length for each line
                      '               Example:
                      '               Dim strLines
                      '               strLines = WordWrapByCharacterToArray("This is my text I want to wrap around something", 15)
                      '               This will break the string into multiple lines with a maximum length of 15 characters per line
                      '---------------------------------------------------------------------------------------
                      '
                      Public Function WordWrapByCharacterToArray(TextToWrap, LengthOfLine)
                          Dim objRegExp, objWordList, objWord
                          Dim strStartGroup, strEndGroup, strRegPattern
                          Dim intLineNum, intLinePos, intNumCharUsed
                          Dim strReturn(), strLineData, strLine
                          
                          ' Instantiate RegEx
                          Set objRegExp = CreateObject("VBScript.RegExp")
                          intLineNum = 0
                      	
                          ' ------------------------------------
                          ' Set Set Font Settings
                          ' ------------------------------------
                          ' Make sure we were sent a good line width
                          If LengthOfLine < 1 Then
                              ' Return an Error
                              Err.Raise vbObjectError + 605, "Requested Length of Line must be greater than 0"
                          End If
                          
                          ' ------------------------------------
                          ' Set RegEx Settings
                          ' ------------------------------------
                          objRegExp.MultiLine = False
                          objRegExp.Global = True
                          
                          ' ------------------------------------
                          ' Set the Search Pattern
                          ' ------------------------------------
                          ' This is the RegEx List for Characters that should be grouped with the text that follows them
                          ' ${(<[\ - Have to use escape character "\" for ] and \
                          strStartGroup = "${(<\[\\"
                          ' This is the RegEx List for Characters that should be grouped with the text the preceeds them
                          ' !)}%>?-] - Have to use escape character "\" for - and ]
                          strEndGroup = "!)}%>?\-\]"
                          ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                          strRegPattern = "[" & strStartGroup & "]?"
                          ' Now grab all characters that are not part of special list and no spaces \s
                          ' [] = Group.  Find Anything listed in this group.  + = Find 1 to many instances.
                          ' Equates to finding whole words including some special characters (those not in list since negative comparison)
                          strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"
                          ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                          strRegPattern = strRegPattern & "[" & strEndGroup & "]?"
                          objRegExp.Pattern = strRegPattern
                          
                          ' ------------------------------------
                          ' Break up Original String into already defined lines
                          ' ------------------------------------
                          strLineData = Split(TextToWrap, vbLf)
                          
                          ' ------------------------------------
                          ' Set Original Size of Return Array to just one line.  Can Expand Later
                          ' ------------------------------------
                          ReDim strReturn(0)
                          
                          ' ------------------------------------
                          ' Loop through each line to wrap text if needed
                          ' ------------------------------------
                          For Each strLine In strLineData
                              ' Reset the Line Position for this set of text
                              intLinePos = 0
                          
                              ' Make sure the line is long enough to need to be wrapped
                              If Len(strLine) > LengthOfLine Then
                                  
                                  ' ------------------------------------
                                  ' Get the list of words defined by the Pattern
                                  ' ------------------------------------
                                  Set objWordList = objRegExp.Execute(strLine)
                                  
                                  ' ------------------------------------
                                  ' Build the Return Array
                                  ' ------------------------------------
                                  For Each objWord In objWordList
                                      ' See if this word is too big to Fit
                                      If objWord.Length > LengthOfLine Then
                                          ' Word is too big for the line, have to break it appart
                                          ' Reset the Number of Characters used in this word to 1
                                          intNumCharUsed = 1
                                          
                                          ' First see if we have any remaining words that should be added to the previous line
                                          If objWord.FirstIndex - intLinePos > 0 Then
                                              ' See if we need to expand the array
                                              If UBound(strReturn) < intLineNum Then
                                                  ' ReDim the Array
                                                  ReDim Preserve strReturn(intLineNum)
                                              End If
                                              
                                              ' Save Previous Line
                                              strReturn(intLineNum) = Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos)
                                              
                                              ' Reset the Line Position
                                              intLinePos = objWord.FirstIndex
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          End If
                                          
                                          Do While intNumCharUsed < objWord.Length
                                              ' See if we need to expand the array
                                              If UBound(strReturn) < intLineNum Then
                                                  ' ReDim the Array
                                                  ReDim Preserve strReturn(intLineNum)
                                              End If
                                              
                                              ' Get as many characters as will fit on the line
                                              strReturn(intLineNum) = Mid(objWord.Value, intNumCharUsed, LengthOfLine)
                                              
                                              ' Increase the Number used counter
                                              intNumCharUsed = intNumCharUsed + Len(strReturn(intLineNum))
                                              
                                              ' Reset the Line Position
                                              intLinePos = intLinePos + Len(strReturn(intLineNum))
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          Loop
                                      Else
                                          If objWord.FirstIndex - intLinePos + objWord.Length > LengthOfLine Then
                                              ' See if we need to expand the array
                                              If UBound(strReturn) < intLineNum Then
                                                  ' ReDim the Array
                                                  ReDim Preserve strReturn(intLineNum)
                                              End If
                                              
                                              ' This word will not fit on current Line.  Save Current Line
                                              strReturn(intLineNum) = Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos)
                                              
                                              ' Reset the Line Position
                                              intLinePos = objWord.FirstIndex
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          End If
                                      End If 'objWord.Length > LengthOfLine
                                  Next
                                  
                                  ' ------------------------------------
                                  ' See if there is any text yet to add
                                  ' ------------------------------------
                                  If (Len(strLine) - intLinePos) > 0 Then
                                      ' See if we need to expand the array
                                      If UBound(strReturn) < intLineNum Then
                                          ' ReDim the Array
                                          ReDim Preserve strReturn(intLineNum)
                                      End If
                                  
                                      ' Save of the Last bits of Data
                                      strReturn(intLineNum) = Right(strLine, Len(strLine) - intLinePos)
                                          
                                      ' Increment our line Counter
                                      intLineNum = intLineNum + 1
                                  End If
                              Else
                                  ' ------------------------------------
                                  ' The entire line fits.  Add it now
                                  ' ------------------------------------
                                  
                                  ' See if we need to expand the array
                                  If UBound(strReturn) < intLineNum Then
                                      ' ReDim the Array
                                      ReDim Preserve strReturn(intLineNum)
                                  End If
                                  
                                  strReturn(intLineNum) = strLine
                                          
                                  ' Increment our line Counter
                                  intLineNum = intLineNum + 1
                              End If
                          Next
                          
                          ' Return our Array
                          WordWrapByCharacterToArray = strReturn
                          
                      	' Release the Objects
                          On Error Resume Next
                          Set objWordList = Nothing
                          Set objWord = Nothing
                          Set objRegExp = Nothing
                      End Function
                      

Open in new window

WordWrapByCharacterToSstring Function:
Here is the Next function.  To use this function, send it the text that you want word wrapped and the maximum number of characters per line.  It will return a single string with each line in the string separated by a carriage return.

Example Usage:
Dim strWrappedLines As String
                      strWrappedLines = WordWrapByPointToString(TextToWrap:=TextBox1.Text, LengthOfLine:=20)
                      Debug.Print strWrappedLines
                      

Open in new window

Function
'---------------------------------------------------------------------------------------
                      ' Procedure : WordWrapByCharacterToString
                      ' Date      : 03/23/2012
                      ' Purpose   : Will Return a String array of line data wrapped at proper break points
                      '               for a given line length as determined by the number of characters.
                      '               It uses the same rules as a VBA text box
                      '               *** MUST have a REFERENCE set for MICROSOFT VBSCRIPT REGULAR EXPRESSION 5.5
                      '
                      ' Usage     : Set a string array = to WordWrapByCharacterToString sending WordWrapByCharacterToString
                      '               your text and maximum length for each line
                      '               Example:
                      '               Dim strWrappedLines as string
                      '               strWrappedLines = WordWrapByCharacterToString("This is my text I want to wrap around something", 15)
                      '               This will break the string into multiple lines with a maximum length of 15 characters per line
                      '---------------------------------------------------------------------------------------
                      '
                      Public Function WordWrapByCharacterToString(ByVal TextToWrap As String, _
                          ByVal LengthOfLine As Long) As String
                      
                      
                          On Error GoTo WordWrapByCharacterToString_Error:
                          Dim objRegExp As VBScript_RegExp_55.RegExp
                          Dim objWordList As VBScript_RegExp_55.MatchCollection
                          Dim objWord As VBScript_RegExp_55.Match
                          Dim strStartGroup As String
                          Dim strEndGroup As String
                          Dim strRegPattern As String
                          Dim intLineNum As Integer: intLineNum = 0
                          Dim intLinePos As Integer
                          Dim strReturn As String
                          Dim strLineData() As String
                          Dim strLine As Variant
                          Dim intNumCharUsed As Integer
                          
                          ' Instantiate RegEx
                          Set objRegExp = New VBScript_RegExp_55.RegExp
                          
                          ' ------------------------------------
                          ' Set Set Font Settings
                          ' ------------------------------------
                          ' Make sure we were sent a good line width
                          If LengthOfLine < 1 Then
                              ' Return an Error
                              Err.Raise Number:=vbObjectError + 605, Description:="Requested Length of Line must be greater than 0"
                          End If
                          
                          ' ------------------------------------
                          ' Set RegEx Settings
                          ' ------------------------------------
                          objRegExp.MultiLine = False
                          objRegExp.Global = True
                          
                          ' ------------------------------------
                          ' Set the Search Pattern
                          ' ------------------------------------
                          ' This is the RegEx List for Characters that should be grouped with the text that follows them
                          ' ${(<[\ - Have to use escape character "\" for ] and \
                          strStartGroup = "${(<\[\\"
                          ' This is the RegEx List for Characters that should be grouped with the text the preceeds them
                          ' !)}%>?-] - Have to use escape character "\" for - and ]
                          strEndGroup = "!)}%>?\-\]"
                          ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                          strRegPattern = "[" & strStartGroup & "]?"
                          ' Now grab all characters that are not part of special list and no spaces \s
                          ' [] = Group.  Find Anything listed in this group.  + = Find 1 to many instances.
                          ' Equates to finding whole words including some special characters (those not in list since negative comparison)
                          strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"
                          ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                          strRegPattern = strRegPattern & "[" & strEndGroup & "]?"
                          objRegExp.Pattern = strRegPattern
                          
                          ' ------------------------------------
                          ' Break up Original String into already defined lines
                          ' ------------------------------------
                          strLineData = Split(TextToWrap, vbLf)
                          
                          ' ------------------------------------
                          ' Loop through each line to wrap text if needed
                          ' ------------------------------------
                          For Each strLine In strLineData
                              ' Reset the Line Position for this set of text
                              intLinePos = 0
                          
                              ' Make sure the line is long enough to need to be wrapped
                              If Len(strLine) > LengthOfLine Then
                                  
                                  ' ------------------------------------
                                  ' Get the list of words defined by the Pattern
                                  ' ------------------------------------
                                  Set objWordList = objRegExp.Execute(strLine)
                                  
                                  ' ------------------------------------
                                  ' Build the Return Array
                                  ' ------------------------------------
                                  For Each objWord In objWordList
                                      ' See if this word is too big to Fit
                                      If objWord.Length > LengthOfLine Then
                                          ' Word is too big for the line, have to break it appart
                                          ' Reset the Number of Characters used in this word to 1
                                          intNumCharUsed = 1
                                          
                                          ' First see if we have any remaining words that should be added to the previous line
                                          If objWord.FirstIndex - intLinePos > 0 Then
                                              ' Save Previous Line
                                              strReturn = strReturn & (Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos) & vbNewLine)
                                              
                                              ' Reset the Line Position
                                              intLinePos = objWord.FirstIndex
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          End If
                                          
                                          Do While intNumCharUsed < objWord.Length
                                              ' Get as many characters as will fit on the line
                                              strReturn = strReturn & (Mid(objWord.Value, intNumCharUsed, LengthOfLine) & vbNewLine)
                                              
                                              ' Reset the Line Position
                                              intLinePos = intLinePos + Len(Mid(objWord.Value, intNumCharUsed, LengthOfLine))
                                              
                                              ' Increase the Number used counter
                                              intNumCharUsed = intNumCharUsed + Len(Mid(objWord.Value, intNumCharUsed, LengthOfLine))
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          Loop
                                      Else
                                          If objWord.FirstIndex - intLinePos + objWord.Length > LengthOfLine Then
                                              ' This word will not fit on current Line.  Save Current Line
                                              strReturn = strReturn & (Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos) & vbNewLine)
                                              
                                              ' Reset the Line Position
                                              intLinePos = objWord.FirstIndex
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          End If
                                      End If 'objWord.Length > LengthOfLine
                                  Next
                                  
                                  ' ------------------------------------
                                  ' See if there is any text yet to add
                                  ' ------------------------------------
                                  If (Len(strLine) - intLinePos) > 0 Then
                                      ' Save of the Last bits of Data
                                      strReturn = strReturn & (Right(strLine, Len(strLine) - intLinePos) & vbNewLine)
                                          
                                      ' Increment our line Counter
                                      intLineNum = intLineNum + 1
                                  End If
                              Else
                                  ' ------------------------------------
                                  ' The entire line fits.  Add it now
                                  ' ------------------------------------
                                  strReturn = strReturn & (strLine & vbNewLine)
                                          
                                  ' Increment our line Counter
                                  intLineNum = intLineNum + 1
                              End If
                          Next
                          
                          ' Return our Array
                          WordWrapByCharacterToString = strReturn
                          
                      Release:
                          On Error Resume Next
                          Set objWordList = Nothing
                          Set objWord = Nothing
                          Set objRegExp = Nothing
                          Exit Function
                          
                      WordWrapByCharacterToString_Error:
                          MsgBox "Procedure = WordWrapByCharacterToString" & vbCrLf & _
                              "Error Number = " & Err.Number & vbCrLf & _
                              "Error Message = " & Err.Description & vbCrLf, _
                              vbCritical Or vbSystemModal, "Word Wrap Error"
                          
                          Resume Release:
                      End Function
                      

Open in new window

VBScript Version:
'---------------------------------------------------------------------------------------
                      ' Procedure : WordWrapByCharacterToString
                      ' Date      : 03/23/2012
                      ' Purpose   : Will Return a String array of line data wrapped at proper break points
                      '               for a given line length as determined by the number of characters.
                      '               It uses the same rules as a VBA text box
                      '
                      ' Usage     : Set a string array = to WordWrapByCharacterToString sending WordWrapByCharacterToString
                      '               your text and maximum length for each line
                      '               Example:
                      '               Dim strWrappedLines
                      '               strWrappedLines = WordWrapByCharacterToString("This is my text I want to wrap around something", 15)
                      '               This will break the string into multiple lines with a maximum length of 15 characters per line
                      '---------------------------------------------------------------------------------------
                      '
                      Public Function WordWrapByCharacterToString(TextToWrap, LengthOfLine)
                      
                          Dim objRegExp, objWordList, objWord
                          Dim strStartGroup, strEndGroup, strRegPattern
                          Dim intLineNum, intLinePos, intNumCharUsed
                          Dim strReturn, strLineData, strLine
                          
                          ' Instantiate RegEx
                          Set objRegExp = CreateObject("VBScript.RegExp")
                          intLineNum = 0
                          
                          ' ------------------------------------
                          ' Set Set Font Settings
                          ' ------------------------------------
                          ' Make sure we were sent a good line width
                          If LengthOfLine < 1 Then
                              ' Return an Error
                              Err.Raise vbObjectError + 605, "Requested Length of Line must be greater than 0"
                          End If
                          
                          ' ------------------------------------
                          ' Set RegEx Settings
                          ' ------------------------------------
                          objRegExp.MultiLine = False
                          objRegExp.Global = True
                          
                          ' ------------------------------------
                          ' Set the Search Pattern
                          ' ------------------------------------
                          ' This is the RegEx List for Characters that should be grouped with the text that follows them
                          ' ${(<[\ - Have to use escape character "\" for ] and \
                          strStartGroup = "${(<\[\\"
                          ' This is the RegEx List for Characters that should be grouped with the text the preceeds them
                          ' !)}%>?-] - Have to use escape character "\" for - and ]
                          strEndGroup = "!)}%>?\-\]"
                          ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                          strRegPattern = "[" & strStartGroup & "]?"
                          ' Now grab all characters that are not part of special list and no spaces \s
                          ' [] = Group.  Find Anything listed in this group.  + = Find 1 to many instances.
                          ' Equates to finding whole words including some special characters (those not in list since negative comparison)
                          strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"
                          ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                          strRegPattern = strRegPattern & "[" & strEndGroup & "]?"
                          objRegExp.Pattern = strRegPattern
                          
                          ' ------------------------------------
                          ' Break up Original String into already defined lines
                          ' ------------------------------------
                          strLineData = Split(TextToWrap, vbLf)
                          
                          ' ------------------------------------
                          ' Loop through each line to wrap text if needed
                          ' ------------------------------------
                          For Each strLine In strLineData
                              ' Reset the Line Position for this set of text
                              intLinePos = 0
                          
                              ' Make sure the line is long enough to need to be wrapped
                              If Len(strLine) > LengthOfLine Then
                                  
                                  ' ------------------------------------
                                  ' Get the list of words defined by the Pattern
                                  ' ------------------------------------
                                  Set objWordList = objRegExp.Execute(strLine)
                                  
                                  ' ------------------------------------
                                  ' Build the Return Array
                                  ' ------------------------------------
                                  For Each objWord In objWordList
                                      ' See if this word is too big to Fit
                                      If objWord.Length > LengthOfLine Then
                                          ' Word is too big for the line, have to break it appart
                                          ' Reset the Number of Characters used in this word to 1
                                          intNumCharUsed = 1
                                          
                                          ' First see if we have any remaining words that should be added to the previous line
                                          If objWord.FirstIndex - intLinePos > 0 Then
                                              ' Save Previous Line
                                              strReturn = strReturn & (Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos) & vbNewLine)
                                              
                                              ' Reset the Line Position
                                              intLinePos = objWord.FirstIndex
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          End If
                                          
                                          Do While intNumCharUsed < objWord.Length
                                              ' Get as many characters as will fit on the line
                                              strReturn = strReturn & (Mid(objWord.Value, intNumCharUsed, LengthOfLine) & vbNewLine)
                                              
                                              ' Reset the Line Position
                                              intLinePos = intLinePos + Len(Mid(objWord.Value, intNumCharUsed, LengthOfLine))
                                              
                                              ' Increase the Number used counter
                                              intNumCharUsed = intNumCharUsed + Len(Mid(objWord.Value, intNumCharUsed, LengthOfLine))
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          Loop
                                      Else
                                          If objWord.FirstIndex - intLinePos + objWord.Length > LengthOfLine Then
                                              ' This word will not fit on current Line.  Save Current Line
                                              strReturn = strReturn & (Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos) & vbNewLine)
                                              
                                              ' Reset the Line Position
                                              intLinePos = objWord.FirstIndex
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          End If
                                      End If 'objWord.Length > LengthOfLine
                                  Next
                                  
                                  ' ------------------------------------
                                  ' See if there is any text yet to add
                                  ' ------------------------------------
                                  If (Len(strLine) - intLinePos) > 0 Then
                                      ' Save of the Last bits of Data
                                      strReturn = strReturn & (Right(strLine, Len(strLine) - intLinePos) & vbNewLine)
                                          
                                      ' Increment our line Counter
                                      intLineNum = intLineNum + 1
                                  End If
                              Else
                                  ' ------------------------------------
                                  ' The entire line fits.  Add it now
                                  ' ------------------------------------
                                  strReturn = strReturn & (strLine & vbNewLine)
                                          
                                  ' Increment our line Counter
                                  intLineNum = intLineNum + 1
                              End If
                          Next
                          
                          ' Return our Array
                          WordWrapByCharacterToString = strReturn
                      
                      	' Release the Objects
                          On Error Resume Next
                          Set objWordList = Nothing
                          Set objWord = Nothing
                          Set objRegExp = Nothing
                      End Function
                      

Open in new window

Stage Two:
As I mentioned, the problem with both of the above functions is that they still break based on a character count.  With propotionalized fonts, though, a line of "iiiiiiiiii" will break differently than a line of "WWWWWWWWWW" in a textbox.  Since the width of a text box is based on points, the code needed to determine the size of the text in points before it could split the lines.  There are examples on the internet of using Windows APIs to determine the pixel size of a section of text.  If you know the DPI of a monitor, which can be had via the APIs, you can determine the point size.  Adapting those ideas, a class to determine text size was created.

This class is used to measure the point size of each word, to compare that with the targeted line width in points, and to see if the word fits that line.  Pleaset note that the defined width of a text box is not exactly the size needed for your total line width.  The textbox has margins built into the display.  I could not find this documented anywhere, but it appears that the margin is 3 points per side (Selection Margin is another 3 if set to true and a displayed scroll bar appears to take up 14).  Therefore when wrapping text, you need to take the width of the text box and subtract the correct amount (like 6 for just a basic box) to find the width in points that can display text.  

Since this code requires access to Windows API, VBA must be used.  Therefore, they have been coded using early binding for regular expressions.  Please make sure to add a reference in your project to MICROSOFT VBSCRIPT REGULAR EXPRESSION 5.5 to use these functions.

WordWrapByPointToArray Function:
Here is the third attempt at a function.  To use this function, send it the text that you want word wrapped, the font used, and how wide the line should be in points.  It will return a string array with each line as a separate element in the array.
Example:
Dim strLines() As String
                      strLines = WordWrapByPointToArray(TextToWrap:=TextBox1.Text, TextFont:=TextBox1.Font, LineWidthInPoints:=TextBox1.Width - 6)
                      For i = 0 To UBound(strLines)
                              Debug.Print strLines(i)
                      Next
                      

Open in new window

Function
'---------------------------------------------------------------------------------------
                      ' Function  : WordWrapByPointToArray
                      ' Date      : 03/20/2012
                      ' Purpose   : Will Return a String array of line data that has been sepearated into lines
                      '               based on Width in Points and split according to textbox word wrap rules.
                      '               *** MUST have a REFERENCE set for Microsoft VBScript Regular Expression 5.5
                      '               *** Must also have the DetermineTextSize Class added to the project***
                      '
                      ' Usage     : Set a string array = to WordWrapByPointToArray sending WordWrapByPointToArray
                      '               your text, Font and Line Width (Point Size) for each line
                      '               Example:
                      '               Dim strLines() as string
                      '               strLines = WordWrapByPointToArray(TextToWrap:=TextBox1.Text, TextFont:=TextBox1.Font, LineWidthInPoints:=TextBox1.Width - 6)
                      '               This will break the string into multiple lines at the same point as the text box
                      '
                      '               Please note in the example I take 6 away form TextBox1.Width as this appears to be
                      '                the margin size of a text box.  I found this through trial and error and have not
                      '                been able to verify that value.
                      '---------------------------------------------------------------------------------------
                      '
                      Public Function WordWrapByPointToArray(ByVal TextToWrap As String, _
                          ByVal TextFont As StdFont, ByVal LineWidthInPoints As Single) As String()
                      
                          On Error GoTo WordWrapByPointToArray_Error:
                          Dim objRegExp As VBScript_RegExp_55.RegExp
                          Dim objWordList As VBScript_RegExp_55.MatchCollection
                          Dim objWord As VBScript_RegExp_55.Match
                          Dim udtTextSize As DetermineTextSize
                          Dim strStartGroup As String
                          Dim strEndGroup As String
                          Dim strRegPattern As String
                          Dim intLineNum As Integer: intLineNum = 0
                          Dim intLinePos As Integer
                          Dim intEndPosition As Integer
                          Dim strReturn() As String
                          Dim strLineData() As String
                          Dim strLine As Variant
                          Dim lngPointSize As Long
                          Dim lngWordSize As Long
                          Dim intNumCharUsed As Integer
                          
                          ' Instantiate RegEx
                          Set objRegExp = New VBScript_RegExp_55.RegExp
                          Set udtTextSize = New DetermineTextSize
                          
                          ' ------------------------------------
                          ' Set Set Font Settings
                          ' ------------------------------------
                          ' Make sure we were sent a good line width
                          If LineWidthInPoints < 1 Then
                              ' Return an Error
                              Err.Raise Number:=vbObjectError + 605, Description:="Requested Line Width in Points must be greater than 0"
                          End If
                          
                          ' ------------------------------------
                          ' Set Set Font Settings
                          ' ------------------------------------
                          udtTextSize.Font = TextFont
                          
                          ' ------------------------------------
                          ' Set RegEx Settings
                          ' ------------------------------------
                          objRegExp.MultiLine = False
                          objRegExp.Global = True
                          
                          ' ------------------------------------
                          ' Set the Search Pattern
                          ' ------------------------------------
                          ' This is the RegEx List for Characters that should be grouped with the text that follows them
                          ' ${(<[\ - Have to use escape character "\" for ] and \
                          strStartGroup = "${(<\[\\"
                          ' This is the RegEx List for Characters that should be grouped with the text the preceeds them
                          ' !)}%>?-] - Have to use escape character "\" for - and ]
                          strEndGroup = "!)}%>?\-\]"
                          ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                          strRegPattern = "[" & strStartGroup & "]?"
                          ' Now grab all characters that are not part of special list and no spaces \s
                          ' [] = Group.  Find Anything listed in this group.  + = Find 1 to many instances.
                          ' Equates to finding whole words including some special characters (those not in list since negative comparison)
                          strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"
                          ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                          strRegPattern = strRegPattern & "[" & strEndGroup & "]?"
                          objRegExp.Pattern = strRegPattern
                          
                          ' ------------------------------------
                          ' Break up Original String into already defined lines
                          ' ------------------------------------
                          strLineData = Split(TextToWrap, vbLf)
                          
                          ' ------------------------------------
                          ' Set Original Size of Return Array to just one line.  Can Expand Later
                          ' ------------------------------------
                          ReDim Preserve strReturn(0)
                          
                          ' ------------------------------------
                          ' Loop through each line to wrap text if needed
                          ' ------------------------------------
                          For Each strLine In strLineData
                              ' Reset the Line Position for this set of text
                              intLinePos = 0
                          
                              ' Make sure the line is long enough to need to be wrapped
                              If udtTextSize.TextWidthinPoints(strLine) > LineWidthInPoints Then
                                  
                                  ' ------------------------------------
                                  ' Get the list of words defined by the Pattern
                                  ' ------------------------------------
                                  Set objWordList = objRegExp.Execute(strLine)
                                  
                                  ' ------------------------------------
                                  ' Build the Return Array
                                  ' ------------------------------------
                                  For Each objWord In objWordList
                                      lngWordSize = udtTextSize.TextWidthinPoints(objWord.Value)
                                  
                                      ' See if this word is too big to Fit
                                      If lngWordSize > LineWidthInPoints Then
                                          ' Word is too big for the line, have to break it appart
                                          ' Reset the Number of Characters used in this word to 0
                                          intNumCharUsed = 0
                                          
                                          ' First see if we have any remaining words that should be added to the previous line
                                          If objWord.FirstIndex - intLinePos > 0 Then
                                              ' See if we need to expand the array
                                              If UBound(strReturn) < intLineNum Then
                                                  ' ReDim the Array
                                                  ReDim Preserve strReturn(intLineNum)
                                              End If
                                              
                                              ' Save Previous Line
                                              strReturn(intLineNum) = Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos)
                                              
                                              ' Reset the Line Position
                                              intLinePos = objWord.FirstIndex
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          End If
                                          
                                          lngPointSize = lngWordSize
                                          
                                          ' Keep Looping until remaining text will fit on a line by itself
                                          Do While lngPointSize > LineWidthInPoints
                                              ' Calculate the new end Length (Try to get close to needed end so it does not loop too long)
                                              If (objWord.Length - intNumCharUsed) > 10 Then
                                                  ' Set our attempted end position.  Figure out how much of the word we have left
                                                  ' and then take the percentage of that.  The precantage being how far over
                                                  ' the line width we are
                                                  intEndPosition = intLinePos + ((objWord.Length - intNumCharUsed) / CInt(lngPointSize / LineWidthInPoints))
                                              Else
                                                  ' We don't have too many characters Left so just go at them one at a time
                                                  intEndPosition = intLinePos + (objWord.Length - intNumCharUsed)
                                              End If
                                              
                                              ' Recalculate the length
                                              lngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, intEndPosition - intLinePos))
                                              
                                              If lngPointSize <= LineWidthInPoints Then
                                                  ' Keep Looping until we are one past it fitting on the line
                                                  Do While lngPointSize <= LineWidthInPoints
                                                      ' This character would still fit, add one more character
                                                      intEndPosition = intEndPosition + 1
                                                      
                                                      ' Recalculate the length
                                                      lngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, intEndPosition - intLinePos))
                                                  Loop
                                                  
                                                  ' Take away the one extra character to go back to the last one that fit
                                                  intEndPosition = intEndPosition - 1
                                              Else
                                                  ' Still too big
                                                  ' Keep removing one character until it fits
                                                  Do While lngPointSize > LineWidthInPoints
                                                      ' Did not fit, go back one character
                                                      intEndPosition = intEndPosition - 1
                                                      
                                                      ' Recalculate the length
                                                      lngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, intEndPosition - intLinePos))
                                                  Loop
                                              End If
                                              
                                              ' Calculate how many characters were added
                                              intNumCharUsed = intNumCharUsed + (intEndPosition - intLinePos)
                                              
                                              ' See if we need to expand the array
                                              If UBound(strReturn) < intLineNum Then
                                                  ' ReDim the Array
                                                  ReDim Preserve strReturn(intLineNum)
                                              End If
                                              
                                              ' Since we made it this far, we know this text fits.  Add it now
                                              strReturn(intLineNum) = Mid(strLine, intLinePos + 1, intEndPosition - intLinePos)
                                              
                                              ' Reset the Line Position
                                              intLinePos = intEndPosition
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          
                                              ' Now Calculate how big the next line is when we add the remaining text and try again
                                              lngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos + objWord.Length))
                                          Loop
                                      Else
                                          ' This word is smaller than the line width.  Check the width if we add it
                                          lngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos + objWord.Length))
                                          
                                          If lngPointSize > LineWidthInPoints Then
                                              ' It did not fit.  Add previous text to array
                                              
                                              ' See if we need to expand the array
                                              If UBound(strReturn) < intLineNum Then
                                                  ' ReDim the Array
                                                  ReDim Preserve strReturn(intLineNum)
                                              End If
                                              
                                              ' This word will not fit on current Line.  Save Current Line
                                              strReturn(intLineNum) = Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos)
                                              
                                              ' Reset the Line Position
                                              intLinePos = objWord.FirstIndex
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          End If
                                      End If
                                  Next
                                  
                                  ' ------------------------------------
                                  ' See if there is any text yet to add
                                  ' ------------------------------------
                                  If (Len(strLine) - intLinePos) > 0 Then
                                      ' See if we need to expand the array
                                      If UBound(strReturn) < intLineNum Then
                                          ' ReDim the Array
                                          ReDim Preserve strReturn(intLineNum)
                                      End If
                                  
                                      ' Save of the Last bits of Data
                                      strReturn(intLineNum) = Right(strLine, Len(strLine) - intLinePos)
                                          
                                      ' Increment our line Counter
                                      intLineNum = intLineNum + 1
                                  End If
                              Else
                                  ' ------------------------------------
                                  ' The entire line fits.  Add it now
                                  ' ------------------------------------
                                  
                                  ' See if we need to expand the array
                                  If UBound(strReturn) < intLineNum Then
                                      ' ReDim the Array
                                      ReDim Preserve strReturn(intLineNum)
                                  End If
                                  
                                  strReturn(intLineNum) = strLine
                                          
                                  ' Increment our line Counter
                                  intLineNum = intLineNum + 1
                              End If
                          Next
                          
                          ' Return our Array
                          WordWrapByPointToArray = strReturn
                          
                      Release:
                          On Error Resume Next
                          Erase strReturn
                          Set udtTextSize = Nothing
                          Set objWordList = Nothing
                          Set objWord = Nothing
                          Set objRegExp = Nothing
                          Exit Function
                          
                      WordWrapByPointToArray_Error:
                          MsgBox "Procedure = WordWrapByPointToArray" & vbCrLf & _
                              "Error Number = " & Err.Number & vbCrLf & _
                              "Error Message = " & Err.Description & vbCrLf, _
                              vbCritical Or vbSystemModal, "Word Wrap Error"
                          
                          Resume Release:
                      End Function
                      

Open in new window

WordWrapByPointToString Function
Here is the fourth attempt at a function.  To use this function, send it the text that you want word wrapped, the font used, and how wide the line should be in points.  It will return a single string with each line in the string separated by a carriage return.
Example:
Dim strWrappedLines As String
                      strWrappedLines = WordWrapByPointToString(TextToWrap:=TextBox1.Text, TextFont:=TextBox1.Font, LineWidthInPoints:=TextBox1.Width - 6)
                      Debug.Print strWrappedLines
                      

Open in new window

Function:
'---------------------------------------------------------------------------------------
                      ' Function  : WordWrapByPointToString
                      ' Date      : 03/20/2012
                      ' By        : Barry Versaw
                      ' Purpose   : Will Return a String of data that has been sepearated into lines
                      '               based on Width in Points and split according to textbox word wrap rules.
                      '               Each line is separated by a carriage return & line feed
                      '               *** MUST have a REFERENCE set for Microsoft VBScript Regular Expression 5.5
                      '               *** Must also have the DetermineTextSize Class added to the project***
                      '
                      ' Usage     : Set a string array = to WordWrapByPointToString sending WordWrapByPointToString
                      '               your text, Font and Line Width (Point Size) for each line
                      '               Example:
                      '               Dim strWrappedLines as string
                      '               strWrappedLines = WordWrapByPointToString(TextToWrap:=TextBox1.Text, TextFont:=TextBox1.Font, LineWidthInPoints:=TextBox1.Width - 6)
                      '               This will break the string into multiple lines at the same point as the text box
                      '
                      '               Please note in the example I take 6 away form TextBox1.Width as this appears to be
                      '                the margin size of a text box.  I found this through trial and error and have not
                      '                been able to verify that value.
                      '---------------------------------------------------------------------------------------
                      '
                      Public Function WordWrapByPointToString(ByVal TextToWrap As String, _
                          ByVal TextFont As StdFont, ByVal LineWidthInPoints As Single) As String
                      
                          On Error GoTo WordWrapByPointToString_Error:
                          Dim objRegExp As VBScript_RegExp_55.RegExp
                          Dim objWordList As VBScript_RegExp_55.MatchCollection
                          Dim objWord As VBScript_RegExp_55.Match
                          Dim udtTextSize As DetermineTextSize
                          Dim strStartGroup As String
                          Dim strEndGroup As String
                          Dim strRegPattern As String
                          Dim intLineNum As Integer: intLineNum = 0
                          Dim intLinePos As Integer
                          Dim intEndPosition As Integer
                          Dim strReturn As String
                          Dim strLineData() As String
                          Dim strLine As Variant
                          Dim lngPointSize As Long
                          Dim lngWordSize As Long
                          Dim intNumCharUsed As Integer
                          
                          ' Instantiate RegEx
                          Set objRegExp = New VBScript_RegExp_55.RegExp
                          Set udtTextSize = New DetermineTextSize
                          
                          ' ------------------------------------
                          ' Set Set Font Settings
                          ' ------------------------------------
                          ' Make sure we were sent a good line width
                          If LineWidthInPoints < 1 Then
                              ' Return an Error
                              Err.Raise Number:=vbObjectError + 605, Description:="Requested Line Width in Points must be greater than 0"
                          End If
                          
                          ' ------------------------------------
                          ' Set Set Font Settings
                          ' ------------------------------------
                          udtTextSize.Font = TextFont
                          
                          ' ------------------------------------
                          ' Set RegEx Settings
                          ' ------------------------------------
                          objRegExp.MultiLine = False
                          objRegExp.Global = True
                          
                          ' ------------------------------------
                          ' Set the Search Pattern
                          ' ------------------------------------
                          ' This is the RegEx List for Characters that should be grouped with the text that follows them
                          ' ${(<[\ - Have to use escape character "\" for ] and \
                          strStartGroup = "${(<\[\\"
                          ' This is the RegEx List for Characters that should be grouped with the text the preceeds them
                          ' !)}%>?-] - Have to use escape character "\" for - and ]
                          strEndGroup = "!)}%>?\-\]"
                          ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                          strRegPattern = "[" & strStartGroup & "]?"
                          ' Now grab all characters that are not part of special list and no spaces \s
                          ' [] = Group.  Find Anything listed in this group.  + = Find 1 to many instances.
                          ' Equates to finding whole words including some special characters (those not in list since negative comparison)
                          strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"
                          ' [] = Group.  Find Anything listed in this group.  ? = Find 0 to 1 instances
                          strRegPattern = strRegPattern & "[" & strEndGroup & "]?"
                          objRegExp.Pattern = strRegPattern
                          
                          ' ------------------------------------
                          ' Break up Original String into already defined lines
                          ' ------------------------------------
                          strLineData = Split(TextToWrap, vbLf)
                          
                          ' ------------------------------------
                          ' Loop through each line to wrap text if needed
                          ' ------------------------------------
                          For Each strLine In strLineData
                              ' Reset the Line Position for this set of text
                              intLinePos = 0
                          
                              ' Make sure the line is long enough to need to be wrapped
                              If udtTextSize.TextWidthinPoints(strLine) > LineWidthInPoints Then
                                  
                                  ' ------------------------------------
                                  ' Get the list of words defined by the Pattern
                                  ' ------------------------------------
                                  Set objWordList = objRegExp.Execute(strLine)
                                  
                                  ' ------------------------------------
                                  ' Build the Return Array
                                  ' ------------------------------------
                                  For Each objWord In objWordList
                                      lngWordSize = udtTextSize.TextWidthinPoints(objWord.Value)
                                  
                                      ' See if this word is too big to Fit
                                      If lngWordSize > LineWidthInPoints Then
                                          ' Word is too big for the line, have to break it appart
                                          ' Reset the Number of Characters used in this word to 0
                                          intNumCharUsed = 0
                                          
                                          ' First see if we have any remaining words that should be added to the previous line
                                          If objWord.FirstIndex - intLinePos > 0 Then
                                              ' Save Previous Line
                                              strReturn = strReturn & (Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos) & vbNewLine)
                                              
                                              ' Reset the Line Position
                                              intLinePos = objWord.FirstIndex
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          End If
                                          
                                          lngPointSize = lngWordSize
                                          
                                          ' Keep Looping until remaining text will fit on a line by itself
                                          Do While lngPointSize > LineWidthInPoints
                                              ' Calculate the new end Length (Try to get close to needed end so it does not loop too long)
                                              If (objWord.Length - intNumCharUsed) > 10 Then
                                                  ' Set our attempted end position.  Figure out how much of the word we have left
                                                  ' and then take the percentage of that.  The precantage being how far over
                                                  ' the line width we are
                                                  intEndPosition = intLinePos + ((objWord.Length - intNumCharUsed) / CInt(lngPointSize / LineWidthInPoints))
                                              Else
                                                  ' We don't have too many characters Left so just go at them one at a time
                                                  intEndPosition = intLinePos + (objWord.Length - intNumCharUsed)
                                              End If
                                              
                                              ' Recalculate the length
                                              lngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, intEndPosition - intLinePos))
                                              
                                              If lngPointSize <= LineWidthInPoints Then
                                                  ' Keep Looping until we are one past it fitting on the line
                                                  Do While lngPointSize <= LineWidthInPoints
                                                      ' This character would still fit, add one more character
                                                      intEndPosition = intEndPosition + 1
                                                      
                                                      ' Recalculate the length
                                                      lngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, intEndPosition - intLinePos))
                                                  Loop
                                                  
                                                  ' Take away the one extra character to go back to the last one that fit
                                                  intEndPosition = intEndPosition - 1
                                              Else
                                                  ' Still too big
                                                  ' Keep removing one character until it fits
                                                  Do While lngPointSize > LineWidthInPoints
                                                      ' Did not fit, go back one character
                                                      intEndPosition = intEndPosition - 1
                                                      
                                                      ' Recalculate the length
                                                      lngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, intEndPosition - intLinePos))
                                                  Loop
                                              End If
                                              
                                              ' Calculate how many characters were added
                                              intNumCharUsed = intNumCharUsed + (intEndPosition - intLinePos)
                                              
                                              ' Since we made it this far, we know this text fits.  Add it now
                                              strReturn = strReturn & (Mid(strLine, intLinePos + 1, intEndPosition - intLinePos) & vbNewLine)
                                              
                                              ' Reset the Line Position
                                              intLinePos = intEndPosition
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          
                                              ' Now Calculate how big the next line is when we add the remaining text and try again
                                              lngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos + objWord.Length))
                                          Loop
                                      Else
                                          ' This word is smaller than the line width.  Check the width if we add it
                                          lngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos + objWord.Length))
                                          
                                          If lngPointSize > LineWidthInPoints Then
                                              ' It did not fit.  Add previous text to array
                                              
                                              ' This word will not fit on current Line.  Save Current Line
                                              strReturn = strReturn & (Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos) & vbNewLine)
                                              
                                              ' Reset the Line Position
                                              intLinePos = objWord.FirstIndex
                                              
                                              ' Increment our line Counter
                                              intLineNum = intLineNum + 1
                                          End If
                                      End If
                                  Next
                                  
                                  ' ------------------------------------
                                  ' See if there is any text yet to add
                                  ' ------------------------------------
                                  If (Len(strLine) - intLinePos) > 0 Then
                                      ' Save of the Last bits of Data
                                      strReturn = strReturn & (Right(strLine, Len(strLine) - intLinePos) & vbNewLine)
                                          
                                      ' Increment our line Counter
                                      intLineNum = intLineNum + 1
                                  End If
                              Else
                                  ' ------------------------------------
                                  ' The entire line fits.  Add it now
                                  ' ------------------------------------
                                  strReturn = strReturn & (strLine & vbNewLine)
                                          
                                  ' Increment our line Counter
                                  intLineNum = intLineNum + 1
                              End If
                          Next
                          
                          ' Return our String
                          WordWrapByPointToString = strReturn
                          
                      Release:
                          On Error Resume Next
                          Set udtTextSize = Nothing
                          Set objWordList = Nothing
                          Set objWord = Nothing
                          Set objRegExp = Nothing
                          Exit Function
                          
                      WordWrapByPointToString_Error:
                          MsgBox "Procedure = WordWrapByPointToString" & vbCrLf & _
                              "Error Number = " & Err.Number & vbCrLf & _
                              "Error Message = " & Err.Description & vbCrLf, _
                              vbCritical Or vbSystemModal, "Word Wrap Error"
                          
                          Resume Release:
                      End Function
                      

Open in new window

DetermineTextSize Class
Both of the above functions require the following code to be added as a class to your project.  Please name the class DetermineTextSize.  To add a class, on the menu click Insert >> Class Module.  Then in the properties change the name to DetermineTextSize.  Then in the code window paste the following code:
'---------------------------------------------------------------------------------------
                      ' Class   : DetermineTextSize
                      ' PURPOSE : This class accepts a font and the determines the size of the passed text.
                      '           It can return the Text Height or Width in Pixels or
                      '           The Text Height or Width in Points
                      '
                      '           This code is adapted from several posts on the web
                      '-----------------------
                      
                      Option Explicit
                              
                      ' Declare all Needed Windows Constants
                      Private Const LF_FACESIZE = 32
                      Private Const LOGPIXELSY = 90
                      Private Const LOGPIXELSX = 88
                      Private Const DT_CALCRECT = &H400
                      
                      ' See - http://msdn.microsoft.com/en-us/library/dd145037%28v=vs.85%29.aspx
                      Private Type udtLogFont
                         lfHeight As Long
                         lfWidth As Long
                         lfEscapement As Long
                         lfOrientation As Long
                         lfWeight As Long
                         lfItalic As Byte
                         lfUnderline As Byte
                         lfStrikeOut As Byte
                         lfCharSet As Byte
                         lfOutPrecision As Byte
                         lfClipPrecision As Byte
                         lfQuality As Byte
                         lfPitchAndFamily As Byte
                         lfFaceName(LF_FACESIZE) As Byte
                      End Type
                      
                      Private Type udtTextSize
                          Width As Long
                          Height As Long
                      End Type
                      
                      Private Declare Function GetTextExtentPoint Lib "gdi32" _
                          Alias "GetTextExtentPointA" (ByVal hDC As Long, _
                          ByVal lpszString As String, ByVal cbString As Long, _
                          lpSIZE32 As udtTextSize) As Long
                          
                      Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" _
                          (ByRef lpudtLogFont As udtLogFont) As Long
                      
                      Private Declare Function GetDC Lib "user32.dll" _
                          (ByVal hWnd As Long) As Long
                      
                      Private Declare Function ReleaseDC Lib "user32.dll" _
                          (ByVal hWnd As Long, ByVal hDC As Long) As Long
                      
                      Private Declare Function MulDiv Lib "kernel32" ( _
                          ByVal nNumber As Long, ByVal nNumerator As Long, _
                          ByVal nDenominator As Long) As Long
                      
                      Private Declare Function DeleteObject Lib "gdi32" _
                          (ByVal hObject As Long) As Long
                      
                      Private Declare Function GetDeviceCaps Lib "gdi32" _
                          (ByVal hDC As Long, ByVal nIndex As Long) As Long
                      
                      Private Declare Function SelectObject Lib "gdi32" _
                          (ByVal hDC As Long, ByVal hObject As Long) As Long
                      
                      Private m_objFont As StdFont        ' Store Font Settings to be used for calculations
                      Private m_hDeviceContext As Long    ' Store the handler for the Device Context
                      Private m_intDPIWidth As Integer    ' Store the DPI Width - just calculate once
                      Private m_intDPIHeight As Integer   ' Store the DPI Height - just calculate once
                      
                      '---------------------------------------------------------------------------------------
                      ' Procedure : Class_Initialize
                      ' Purpose   : Class has been Declared.  Set Default Values
                      '---------------------------------------------------------------------------------------
                      '
                      Private Sub Class_Initialize()
                      
                          ' Instantiate the Font Object
                          Set m_objFont = New StdFont
                          
                          ' Get Access to A Device Context for the general screen
                          m_hDeviceContext = GetDC(0)
                          
                          ' Grab the Screen DPI Settings
                          m_intDPIWidth = GetDeviceCaps(m_hDeviceContext, LOGPIXELSX)
                          m_intDPIHeight = GetDeviceCaps(m_hDeviceContext, LOGPIXELSY)
                      End Sub
                      
                      '---------------------------------------------------------------------------------------
                      ' Procedure : Class_Terminate
                      ' Purpose   : Class is being Destroyed.  Release objects
                      '---------------------------------------------------------------------------------------
                      '
                      Private Sub Class_Terminate()
                         
                          Set m_objFont = Nothing
                      
                      End Sub
                      
                      '---------------------------------------------------------------------------------------
                      ' Property  : Font
                      ' Purpose   : Gets & Lets the Font to be used in sizing the text
                      '---------------------------------------------------------------------------------------
                      '
                      Public Property Get Font() As StdFont
                          
                          Font = m_objFont
                      
                          ReleaseDC 0, m_hDeviceContext
                      
                      End Property
                      
                      Public Property Let Font(ByVal FontValue As StdFont)
                          
                          Set m_objFont = FontValue
                      
                      End Property
                      
                      '---------------------------------------------------------------------------------------
                      ' Procedure : TextHeightInPixels
                      ' Purpose   : Returns the Height of sent text in pixels
                      '---------------------------------------------------------------------------------------
                      Public Function TextHeightInPixels(ByVal TextToEvaluate As String) As Long
                          
                          Dim udtSize As udtTextSize
                          
                          ' Get the Size of the Text in Height & Width
                          udtSize = GetSizeOfText(TextToEvaluate)
                          ' .Bottom Returns how high the rectangle is in pixels
                          TextHeightInPixels = udtSize.Height
                      End Function
                      
                      '---------------------------------------------------------------------------------------
                      ' Procedure : TextHeightInPoints
                      ' Purpose   : Returns the Height of sent text in Points
                      '---------------------------------------------------------------------------------------
                      Public Function TextHeightInPoints(ByVal TextToEvaluate As String) As Long
                      
                          Dim udtSize As udtTextSize
                                 
                          ' Get the Size of the Text in Height & Width
                          udtSize = GetSizeOfText(TextToEvaluate)
                          ' .Bottom Returns how high the rectangle is in pixels
                          ' Pionts = Pixels *  72 / DPI : 72 Points Per Inch
                          ' Use MulDiv to avoid potential overflow error
                          TextHeightInPoints = MulDiv(udtSize.Height, 72, m_intDPIHeight)
                      
                      End Function
                      
                      '---------------------------------------------------------------------------------------
                      ' Procedure : TextWidthInPixels
                      ' Purpose   : Returns the width of sent text in pixels.  If the text has
                      '               multiple lines, it returns the width of the widest line.
                      '---------------------------------------------------------------------------------------
                      Public Function TextWidthInPixels(ByVal TextToEvaluate As String) As Long
                      
                          Dim udtSize As udtTextSize
                                 
                          ' Get the Size of the Text in Height & Width
                          udtSize = GetSizeOfText(TextToEvaluate)
                          ' Width is the Right Dimension of the Rectangle
                          TextWidthInPixels = udtSize.Width
                          
                      End Function
                      
                      '---------------------------------------------------------------------------------------
                      ' Procedure : TextWidthInPoints
                      ' Purpose   : Returns the width of sent text in Points.  If the text has
                      '               multiple lines, it returns the width of the widest line.
                      '---------------------------------------------------------------------------------------
                      Public Function TextWidthinPoints(ByVal TextToEvaluate As String) As Long
                      
                          Dim udtSize As udtTextSize
                          
                          ' Get the Size of the Text in Height & Width
                          udtSize = GetSizeOfText(TextToEvaluate)
                          ' Width is the Right Dimension of the Rectangle
                          ' Pionts = Pixels *  72 / DPI : 72 Points Per Inch
                          ' Use MulDiv to avoid potential overflow error
                          TextWidthinPoints = MulDiv(udtSize.Width, 72, m_intDPIWidth)
                          
                      End Function
                      
                      '---------------------------------------------------------------------------------------
                      ' Procedure : GetudtTextSize
                      ' Purpose   : Gets udtLogFont size of a string and returns it as
                      '               Width ane Length Dimension
                      '---------------------------------------------------------------------------------------
                      '
                      Private Function GetSizeOfText(ByVal TextToSize As String) As udtTextSize
                      
                          Dim udtFont As udtLogFont
                          Dim hFont As Long           ' Handle to a Logical Font
                          Dim hOldFont As Long        ' Handle to a Logcial Font
                          Dim udtReturnDims As udtTextSize
                          
                          ' Convert the stdFont to a udtLogFont for use in drawing the Rectangle
                          udtFont = OLEFontToLogFont(m_objFont)
                          
                          ' Create a temporary Font to draw the Rectangle
                          hFont = CreateFontIndirect(udtFont)
                          
                          ' Store the Current Font to put back when done
                          hOldFont = SelectObject(m_hDeviceContext, hFont)
                          
                          ' Draw the Rectangle
                          GetTextExtentPoint m_hDeviceContext, TextToSize, Len(TextToSize), udtReturnDims
                          
                          ' Put the Original Font Back in Place
                          SelectObject m_hDeviceContext, hOldFont
                          
                          ' Delete our Temporary Font
                          DeleteObject hFont
                          
                          ' Return the Dimensions
                          GetSizeOfText = udtReturnDims
                      
                      End Function
                      
                      '---------------------------------------------------------------------------------------
                      ' Procedure : OLEFontToLogFont
                      ' Purpose   : Converts an OLE stdFont to a udtLogFont
                      '---------------------------------------------------------------------------------------
                      Private Function OLEFontToLogFont(ByVal FontToConvert As StdFont) As udtLogFont
                      
                          Dim strFont As String
                          Dim intChar As Integer
                          Dim bytFont() As Byte
                          
                          With OLEFontToLogFont
                              strFont = FontToConvert.Name
                              bytFont = StrConv(strFont, vbFromUnicode)
                              
                              For intChar = 0 To Len(strFont) - 1
                                  .lfFaceName(intChar) = bytFont(intChar)
                              Next intChar
                                  
                              ' Convert Height from Points to Pixels
                              ' Use MulDiv to avoid potential overflow error
                              .lfHeight = -MulDiv(FontToConvert.Size, m_intDPIHeight, 72)
                              .lfItalic = FontToConvert.Italic
                              .lfWeight = FontToConvert.Weight
                              .lfUnderline = FontToConvert.Underline
                              .lfStrikeOut = FontToConvert.Strikethrough
                              .lfCharSet = FontToConvert.Charset
                          End With
                      
                      End Function
                      

Open in new window

3
4,104 Views
ltlbearand3
CERTIFIED EXPERT

Comments (1)

CERTIFIED EXPERT
Most Valuable Expert 2012
Top Expert 2013

Commented:
Voted 'Yes' above.

Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.