Function SetListBoxRowsCount(lst As Control, Optional ByVal rCount&, Optional rAuto As Boolean)
Dim d, hAdd!, r&, lHeight!, iHeight As Boolean
Static y!
On Error Resume Next
With lst
  If rCount > 0 Then
    If y Then
      If rAuto Then If rCount > .ListCount Then rCount = .ListCount
      .IntegralHeight = False: .Height = y * (rCount + 1): .IntegralHeight = True: DoEvents
      SetListBoxRowsCount = y: Exit Function
    End If
  Else
    lHeight = .Height: iHeight = .IntegralHeight
  End If
  r = 1
  Set d = CreateObject("Scripting.Dictionary")
  .IntegralHeight = False: .Height = lst.Font.Size * 0.75: .IntegralHeight = True: DoEvents
  hAdd = .Height + 1.5: y = .Height
  Do Until r >= 10
    .IntegralHeight = False: .Height = .Height + hAdd: .IntegralHeight = True: DoEvents
    y = Round((.Height - y) / 0.75): d(y) = d(y) + 1: If d(y) * 2 - 3 > d.Count Then Exit Do
    y = .Height: r = r + 1
  Loop
  y = y * 0.75: .IntegralHeight = False:
  If lHeight > 0 Then
    .Height = lHeight + y: .IntegralHeight = True: DoEvents: .IntegralHeight = iHeight
  Else
    .Height = y * (rCount + 1): .IntegralHeight = True: DoEvents
  End If
End With
SetListBoxRowsCount = y
End Function