strLineData = Split(TextToWrap, vbLf)
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
Using this defined pattern, Loop Through each line and break it into "words".
Set objWordList = objRegExp.Execute(strLine)
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.
Dim strLines() As String
strLines = WordWrapByCharacterToArray(TextToWrap:=TextBox1.Text, LengthOfLine:=20)
For i = 0 To UBound(strLines)
Debug.Print strLines(i)
Next
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
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
WordWrapByCharacterToSstriDim strWrappedLines As String
strWrappedLines = WordWrapByPointToString(TextToWrap:=TextBox1.Text, LengthOfLine:=20)
Debug.Print strWrappedLines
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
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
Stage Two:
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
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
WordWrapByPointToString Function
Dim strWrappedLines As String
strWrappedLines = WordWrapByPointToString(TextToWrap:=TextBox1.Text, TextFont:=TextBox1.Font, LineWidthInPoints:=TextBox1.Width - 6)
Debug.Print strWrappedLines
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
DetermineTextSize Class
'---------------------------------------------------------------------------------------
' 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
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.
Comments (1)
Commented: