Split text into 80 character lines, issue with last line - vba

Question

I'm trying to take a body of text and add line breaks around 80 characters on each line. The issue I'm having is on the last line it's adding an extra line break than would be desired. For instance this string should not have a line break on the second to last line:
Alice was beginning to get very tired of sitting by her sister on the bank, and
of having nothing to do: once or twice she had peeped into the book her sister
was reading, but it had no pictures or conversations in it, and what is the use
of a book, thought Alice without pictures or
conversations?
should look like this (note "conversations" has been moved up):
Alice was beginning to get very tired of sitting by her sister on the bank, and
of having nothing to do: once or twice she had peeped into the book her sister
was reading, but it had no pictures or conversations in it, and what is the use
of a book, thought Alice without pictures or conversations?
Here's the code:
Sub StringChop()
Dim OrigString As String
Dim NewString As String
Dim counter As Long
Dim length As Long
Dim LastSpace As Long
Dim LineBreak As Long
Dim TempString As String
Dim TempNum As Long
OrigString = "Alice was beginning to get very tired of sitting by her sister on the bank, and of having nothing to do: once or twice she had peeped into the book her sister was reading, but it had no pictures or conversations in it, and what is the use of a book, thought Alice without pictures or conversations?"
length = Len(OrigString)
counter = 1
Do While counter < length
'Extract next 80 characters from last position
TempString = Mid(OrigString, counter, 80)
'Determine last space in string
LastSpace = InStrRev(TempString, " ")
'Determine first line break in string
LineBreak = InStr(TempString, vbNewLine)
'If line break exists in sentence...
'only count characters up to line break, and set counter to that amount
Select Case LastSpace 'What to do if there are spaces in sentence
Case Is > 0 'There are spaces in sentence
Select Case LineBreak 'What to do if there are line breaks in sentence
Case Is = 0
'From last counter position,
NewString = NewString & Mid(OrigString, counter, LastSpace) & vbNewLine
counter = counter + LastSpace
Case Is <> 0
NewString = NewString & Mid(OrigString, counter, LineBreak)
counter = counter + LineBreak
End Select
Case Is = 0 'There are no more spaces left in remaining sentence
NewString = NewString & Mid(OrigString, counter)
counter = length
End Select
Loop
Debug.Print NewString
End Sub

Answer 1

Word wrapping is an interesting problem. I wrote the following code once as an experiment. You might find it helpful:
Option Explicit
'Implements a dynamic programming approach to word wrap
'assumes fixed-width font
'a word is defined to be a white-space delimited string which contains no
'whitespace
'the cost of a line is the square of the number of blank spaces at the end
'of a line
Const INFINITY As Long = 1000000
Dim optimalCost As Long
Function Cost(words As Variant, i As Long, j As Long, L As Long) As Long
'words is a 0-based array of strings, assumed to have no white spaces
'i, j are indices in range 0,...,n, where n is UBOUND(words)+1
'L is the maximum length of a line
'Cost returns the cost of a line which begins with words(i) and ends with
'words(j-1). It returns INFINITY if the line is too short to hold the words
'or if j <= i
Dim k As Long
Dim sum As Long
If j <= i Or Len(words(i)) > L Then
Cost = INFINITY
Exit Function
End If
sum = Len(words(i))
k = i + 1
Do While k < j And sum <= L
sum = sum + 1 + Len(words(k)) 'for space
k = k + 1
Loop
If sum > L Then
Cost = INFINITY
Else
Cost = (L - sum) ^ 2
End If
End Function
Function WordWrap(words As Variant, L As Long) As String
'returns string consisting of words with spaces and
'line breaks inserted at the appropriate places
Dim v() As Long, d() As Long
Dim n As Long
Dim i As Long, j As Long
Dim candidate As Long
n = UBound(words) + 1
ReDim v(0 To n)
ReDim d(0 To n)
v(0) = 0
d(0) = -1
For j = 1 To n
v(j) = INFINITY 'until something better is found
i = j - 1
Do
candidate = v(i) + Cost(words, i, j, L)
If candidate < v(j) Then
v(j) = candidate
d(j) = i
End If
i = i - 1
Loop While i >= 0 And candidate < INFINITY
If v(j) = INFINITY Then
MsgBox "Some words are too long for the given length"
Exit Function
End If
Next j
optimalCost = v(n)
'at this stage, optimal path has been found
'just need to follow d() backwards, inserting line breaks
i = d(n) 'beginning of current line
WordWrap = words(n - 1)
j = n - 2
Do While i >= 0
Do While j >= i
WordWrap = words(j) & " " & WordWrap
j = j - 1
Loop
If i > 0 Then WordWrap = vbCrLf & WordWrap
i = d(i)
Loop
End Function
The above function expects an array of words. You would have to split a string before using it as input:
Sub test()
Dim OrigString As String
OrigString = "Alice was beginning to get very tired of sitting by her sister on the bank, and of having nothing to do: once or twice she had peeped into the book her sister was reading, but it had no pictures or conversations in it, and what is the use of a book, thought Alice without pictures or conversations?"
Debug.Print WordWrap(Split(OrigString), 80)
End Sub
Output:
Alice was beginning to get very tired of sitting by her sister on the bank,
and of having nothing to do: once or twice she had peeped into the book
her sister was reading, but it had no pictures or conversations in it, and
what is the use of a book, thought Alice without pictures or conversations?