How to count the visible number of lines of text in a text box on an MS Access form - forms

Question

OK, here's what I am trying to achieve. I have an MS Access 2016 DB with a form on it - one of the fields is a text field (max 255 chars), that users can enter "notes", by date.
The form is a continuous form, and there are a LOT of notes. And as most notes are only a single sentence, not the full 255 chars, to save screen space, the text box is sized to only allow show two lines of text (users can double click on the note to see the full text in the rare instances that the text is up to 255 chars).
The problem with this approach is that it is not always clear if a note goes beyond the two lines.
So I am trying to find a way to tell how many lines of text the note uses in the text box, and then I'll highlight the text box if this is the case.
Note what I am talking about here is text wrapping within a text box, not (necessarily) text with line breaks (although there may be line breaks also). Given the wrapping changes dependent upon the text (eg long words will "wrap early" to a new line), so using a simple char count doesn't work, even with a monospace font.
I have searched a lot online and found nothing, except a ref to a possible solution here:
http://www.lebans.com/textwidth-height.htm
But the download is an old Access file type I can no longer open.
Does anyone have any ideas (except for a form redesign - which is my last option hopefully!)

Answer 1

To count the number of lines in a string, or text box, you can use this expression:
UBound(Split(str, vbCrLf))
So
UBound(Split([textBoxName], vbCrLf))

Answer 2

OK, I have come up with a "solution" to this - it's neither neat nor fast, but it appears to work in my situation. I have posted the VBA code for anyone for whom it might interest.
This function is then used on a continuous form's textbox conditional highlighting, so I can highlight those instances where the text has wrapped beyond "n" lines (in my case, two lines)
FYI it's only partially tested, with no error handling!
' Returns TRUE if the text in a textbox wraps/breaks beyond the number of visible lines in the text box (before scrolling)
' THIS ONLY WORKS FOR MONOSPACE FONTS IN A TEXTBOX WHERE WE KNOW THE WidthInMonospaceCharacters
' WidthInMonospaceCharacters = number of MONOSPACE characters to EXACTLY fill one line in your text box (needs to be counted manually
' VisibleLinesInTextBox = number of lines your text box shows on screen (without scrolling)
Function UnseenLinesInTextBox(YourText As String, WidthInMonospaceCharacters As Long, VisibleLinesInTextBox As Long) As Boolean
Dim LineBreakTexts() As String
Dim CleanText As String
Dim LineCount As Long
Dim LineBreaks As Long
Dim i As Long
' Doesn't matter if we can't see invisible end spaces/line breaks, so lose them
' NB advise cleaning text whenver data updated then no need to run this line
CleanText = ClearEndSpacesAndLineBreaks(YourText)
' Check for any line breaks
LineBreakTexts = Split(CleanText, vbCrLf)
' Too many line breaks means we can't be all in the textbox, so report and GTFOOD
LineBreaks = UBound(LineBreakTexts)
If LineBreaks >= VisibleLinesInTextBox Then
UnseenLinesInTextBox = True
GoTo CleanExit
End If
' No line breaks, and text too short to wrap, so exit
If LineBreaks = 0 And Len(CleanText) <= WidthInMonospaceCharacters Then GoTo CleanExit
' Loop thorough the line break text, and check word wrapping for each
For i = 0 To LineBreaks
LineCount = LineCount + CountWrappedLines(LineBreakTexts(i), WidthInMonospaceCharacters, VisibleLinesInTextBox)
If LineCount > VisibleLinesInTextBox Then
UnseenLinesInTextBox = True
GoTo CleanExit
End If
Next i
CleanExit:
Erase LineBreakTexts
End Function
' Add BugOutLineCount if we are using this simply to see if we are exceeding X number of lines in a textbox
' Put this number of lines here (eg if we have a two line text box, enter 2)
Function CountWrappedLines(YourText As String, WidthInMonospaceCharacters As Long, Optional BugOutLineCount As Long) As Long
Dim SpaceBreakTexts() As String
Dim LineCount As Long, RollingCount As Long, SpaceBreaks As Long, i As Long
Dim WidthAdjust As Long
Dim CheckBugOut As Boolean
Dim tmpLng1 As Long, tmpLng2 As Long
If BugOutLineCount > 0 Then CheckBugOut = True
' Check for space breaks
SpaceBreakTexts = Split(YourText, " ")
SpaceBreaks = UBound(SpaceBreakTexts)
If SpaceBreaks = 0 Then
' No spaces, so text will wrap simply based on the number of characters per line
CountWrappedLines = NoSpacesWrap(YourText, WidthInMonospaceCharacters)
GoTo CleanExit
End If
' Need to count the wrapped line breaks manually
' We must start with at least one line!
LineCount = 1
For i = 0 To SpaceBreaks
tmpLng1 = Len(SpaceBreakTexts(i))
If i = 0 Then
' Do not count spaces in the first word...
RollingCount = RollingCount + tmpLng1
Else
' ... but add spaces to the count for the next texts
RollingCount = 1 + RollingCount + tmpLng1
End If
' Need this adjustment as wrapping works slightly differently between mid and
' end of text
If i = SpaceBreaks Then
WidthAdjust = WidthInMonospaceCharacters
Else
WidthAdjust = WidthInMonospaceCharacters - 1
End If
' Check when we get a wrapped line
If RollingCount > WidthAdjust Then
' Check the the length of the word itself doesn't warp over more than one line
If tmpLng1 > WidthInMonospaceCharacters Then
tmpLng2 = NoSpacesWrap(SpaceBreakTexts(i), WidthInMonospaceCharacters)
If i <> 0 Then
LineCount = LineCount + tmpLng2
Else
LineCount = tmpLng2
End If
' As we have wrapped, then we already have a word on the next line to count in the rolling count
RollingCount = tmpLng1 - ((tmpLng2 - 1) * WidthInMonospaceCharacters)
Else
' New line reached
LineCount = LineCount + 1
' As we have wrapped, then we already have a word on the next line to count in the rolling count
RollingCount = Len(SpaceBreakTexts(i))
End If
End If
If CheckBugOut Then If LineCount > BugOutLineCount Then Exit For
Next i
CountWrappedLines = LineCount
CleanExit:
Erase SpaceBreakTexts
End Function
' Work out how many lines text will wrap if it has NO spaces
Function NoSpacesWrap(YourText As String, WidthInMonospaceCharacters) As Long
Dim WordLines As Double
Dim MyInt As Integer
WordLines = (Len(YourText) / WidthInMonospaceCharacters)
MyInt = Int(WordLines)
' Line(s) are exact width we are looking at
If WordLines - MyInt = 0 Then
NoSpacesWrap = MyInt
Else
NoSpacesWrap = MyInt + 1
End If
End Function
Function ClearEndSpacesAndLineBreaks(YourText As String) As String
Dim str As String
Dim CurrentLength As Long
str = YourText
' Need to loop this in case we have a string of line breaks and spaces invisibly at end of text
Do
CurrentLength = Len(str)
' Clear end spaces
str = RTrim(str)
' Clear end line break(s) whihc are TWO characters long
Do
If Right(str, 2) <> vbCrLf Then Exit Do
str = Left(str, Len(str) - 2)
Loop
If Len(str) = CurrentLength Then Exit Do
Loop
ClearEndSpacesAndLineBreaks = str
End Function
Do please provide any feedback and comments!