Fitting text in a Listbox

[AlexanderBB]

This is a nightmare... How are you supposed to fit text of a unknown length into a listbox control and see it all ?
There's no autowidth, or multiline etc. Or am I wrong?

I see a suggestion to use a listview control and will try that.
Or perhaps a 3rd party control you pay for? But does that cause issues giving the workbook to someone else?
Thanks.

 

[AlexanderBB]

Can't quite figure .linecount. My textbox has 3 lines and len(136). .Linecount is 103.

But I need to know where the LFs are, to copy each line as is to the Listbox row/item. Guess that's a bridge too far ?

 

[Kenneth Hobson]

LineCount returns the expected number of lines delimited by soft returns. I don't know how to get each line of text delimited by vbLf.

If I had time, I would explore this concept more. It is to use MSWord to determine what you want. If the textbox length is 72, then the body should be one inch. Manually change the margins to get that one inch. Paste the text and it should appear nearly the same. The content did not Split() by vbLf, vbCR, vbNewline, nor vbCrLf. I had thought that I could convert the soft returns to hard returns, vbCrLf, but no joy so far. If you want to explore that, here is what I tinkered with in MSWord's VBA:

Sub Main()
  Dim s() As String, ss As String
  ReplaceMLBwithPM Selection
  ss = ActiveDocument.Content.Text
  'ss = ActiveDocument.Range.Text
  s() = Split(ss, vbCrLf)
  MsgBox s(0)
End Sub

'https://www.extendoffice.com/documents/word/658-replace-soft-returns-with-hard-returns.html#a2
Sub ReplaceMLBwithPM(s As Object)
  s.Find.ClearFormatting
  s.Find.Replacement.ClearFormatting
  With s.Find
    .Text = "^l"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .MatchFuzzy = False
  End With
  s.Find.Execute Replace:=wdReplaceAll
End Sub

Obviously, s(0) should display the first "line" but display all the text. I am better at Excel so I may have missed something obvious with my sleepy eyes...

 

[AlexanderBB]

It's a mystery about linecount. There really were 103 soft returns in my Excel Textbox? Anyway I'm not sure how to setup a test for Sub ReplaceMLBwithPM. There seems no "^l" characters in copy/pasted text. ss woudl split with chr$(13) but could it be used in Excel ?
I looked into the properties of a List view control propwerties , maybe it would emulate some text box characteristics, but I see no wordwrap and even autosize is not clear Autosize - This API supports the product infrastructure and is not intended to be used directly from your code. This property is not relevant for this class.(Inherited from Control.)

 

[Kenneth Hobson]

The Word File method that I proposed was close. I just had to skip the replacement routine as soft return codes do not exist. As for the concept of replace codes, you have probably not done it in Word nor read the link that I commented that explained how to do it manually and by macro.

Let's call this the 2/3'rds solution. It does use Word. To get the separate "lines" of text, I had to use a kludge since Word has no neat way builtin for that.

The final 1/3'rd will be to automate this from Excel. Excel VBA would create a Word file, do its thing, and then close it. If you pre-create the file with margins and page orientation and fonts set, that would reduce the code a bit. Of course we have to setup the relationship between Word's body width to the Listbox width as I explained earlier.

https://www.dropbox.com/s/l6lp68uo7v3ysaq/LinesToArray.docm?dl=0

Sub Main()
  Dim a, s() As String, i As Long
  
  'Indent to 1 inch body and add sample text.
  FakeItUntilYouMakeIt
  
  a = LinesToArr()
  MsgBox Join(a, vbCrLf)
End Sub

Sub FakeItUntilYouMakeIt()
  With ActiveDocument
    .Content = "Fourscore and seven years ago our " & _
      "fathers brought forth on this continent a new nation"
      With Selection.ParagraphFormat
        .LeftIndent = InchesToPoints(0)
        .RightIndent = InchesToPoints(5.19)
        .RightIndent = InchesToPoints(5)
      End With
  End With
End Sub

Function LinesToArr()
  Dim a(), strLine As String, i As Long, L As Long
  
  L = ActiveDocument.BuiltInDocumentProperties("Number of Lines")
  With Selection
    Selection.HomeKey Unit:=wdStory
    Do
      Selection.EndKey Unit:=wdLine, Extend:=wdExtend
      ReDim Preserve a(0 To i)
      a(i) = Selection.Text
      Selection.MoveDown Unit:=wdLine, Count:=1
      Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
      Selection.MoveLeft Unit:=wdCharacter, Count:=1
      i = i + 1
    Loop Until i = L
  End With
  
  LinesToArr = a
End Function

 

[AlexanderBB]

If I use the same font/size as Excels listbox (ms sans serif, 8) then to mimic the appearance
it's .RightIndent = InchesToPoints(3)

 

[Kenneth Hobson]

If you found a solution, can you please post it?

Here is what I did: https://www.dropbox.com/s/nz0or9vwfzdqesk/LinesToArray.zip?dl=0

The Word file was landscape with 0.2" margins.

Userform code:

Private Sub UserForm_Initialize()
  Dim s As String, a
  s = "Fourscore and seven years ago our " & _
      "fathers brought forth on this continent a new nation"
  a = LinesToArr(s, ListBox1.Width)
  ListBox1.List = a
End Sub

In a Module.

Sub Main()
  ufWord.Show
End Sub

Function LinesToArr(s As String, dPoints As Double, _
  Optional wFile As String = "")
  Dim a(), strLine As String, i As Long, L As Long
  'Tools > References > Microsoft Word xx.0 Object Library
  Dim wdApp As Word.Application, myDoc As Word.Document
  Dim wClose As Boolean
  
  If wFile = "" Then wFile = ThisWorkbook.Path & "\LinesToArray.docm"
  
  'Tell user what file is missing and exit.
  If Dir(wFile) = "" Then
    MsgBox "File does not exist." & vbLf & wFile, _
      vbCritical, "Exit - Missing LinesToArray File"
  End If
  
  On Error Resume Next
  Set wdApp = GetObject(, "Word.Application")
  If Err.Number <> 0 Then
      Set wdApp = CreateObject("Word.Application")
      wClose = True
  End If
  On Error GoTo 0
  'On Error GoTo errorHandler
  
  With wdApp
    .Application.DisplayAlerts = wdAlertsNone
    
    'Open form file and associate data file
    Set myDoc = wdApp.Documents.Open(wFile, Visible:=True)
    With myDoc
      .Content = s
      With wdApp.Selection.ParagraphFormat
        .LeftIndent = InchesToPoints(0)
        '9.6 = 1" in LinesToArray.docm
        .RightIndent = InchesToPoints(10.6 - dPoints / 72)
      End With
      L = .BuiltinDocumentProperties("Number of Lines")
    End With
    
    With wdApp.Selection
      .HomeKey Unit:=wdStory
      Do
        .EndKey Unit:=wdLine, Extend:=wdExtend
        ReDim Preserve a(0 To i)
        a(i) = .Text
        .MoveDown Unit:=wdLine, Count:=1
        .HomeKey Unit:=wdLine, Extend:=wdExtend
        .MoveLeft Unit:=wdCharacter, Count:=1
        i = i + 1
      Loop Until i = L
    End With
    
    .Application.DisplayAlerts = wdAlertsAll
    myDoc.Close False
    Set myDoc = Nothing
    If wClose Then Set wdApp = Nothing
  End With
  
    GoTo EndNow
errorHandler:
    MsgBox "Unexpected error: " & Err.Number & vbLf & Err.Description
    
EndNow:
  'Trim trailing chars in last element if it exists.
  s = a(UBound(a))
  'If Right(s, 2) = vbNewLine Then a(UBound(a)) = Left(s, Len(s) - 2)
  If Right(s, 1) = vbCr Then a(UBound(a)) = Left(s, Len(s) - 1)
  LinesToArr = a
End Function