Horizontal Scroll in Listbox - nearly there ! 2

[cbsm]

Hello !

Sorry this is going to be a very long post - but wanted to put as many info as possible.
I found on the net a way to add an horizontal scroll bar to a VB Listbox (works also for comboboxes).
This is were I found it :

http://msdn.microsoft.com/msdnmag/issues/1200/combo/

It uses API calls which I am not familiar with at all.
I have several listboxes in my form - I updated the code (or tried to !) to work with all of them.
Basically, I've put all the functions and declaration (made public) in a module.
In my form I have only the :
mAddScrollBar List1
mListBoxAdjustHScroll List1

The problem is, the scroll bar appears only in one Listbox - not on the others ?
I looked - all the declarations are constants (no variables), the control object seems to pass through alright ... So really I do not know what's wrong ...


If this help here is an example :

On the Form

Form_Load
mAddScrollBar lst1
mAddScrollBar lst2
mAddScrollBar lst3
mAddScrollBar lst4
End

On_some_event
Populate Lst1
Populate Lst2
Populate Lst3
Populate Lst4

mListBoxAdjustHScroll Lst1
mListBoxAdjustHScroll Lst2
mListBoxAdjustHScroll Lst3
mListBoxAdjustHScroll Lst4
End

In the Module (declaration at the end)

Public Sub mListBoxAdjustHScroll(ctlControl As Control)
'Purpose: Adjust the horizontal scroll extent of a ListBox to fit the largest item in the
'list

Dim lItemLen As Integer
Dim lItemMaxLen As Integer
Dim sItemText As String

Dim lResult As Long

Dim lLength As Long

Dim i As Integer

Select Case TypeName(ctlControl)
Case "ListBox", "ComboBox"
Case Else
MsgBox "mListBoxAdjustHScroll: Invalid argument value for ctlControl."
GoTo Exit_
End Select

'Find the longest item in the ListBox (by number of characters)
'Note: To be 100% accurate, we should compare the GetTextExtentPoint32 values of each
'string rather than the Length. Would this be much slower? For now, take the simple
'way out.
lItemMaxLen = 0
sItemText = ""
For i = 0 To ctlControl.ListCount - 1
Select Case TypeName(ctlControl)
Case "ListBox"
lResult = SendMessage(ctlControl.hwnd, LB_GETTEXTLEN, i, ByVal 0)
End Select

If (lResult = CB_ERR) Then
gErrHandlerAPI "mListBoxAdjustHScroll"
GoTo NextItem
End If

'If the current item is longer than the longest found so far...
If (lResult > lItemMaxLen) Then
'remember the size and string value of the current item
lItemMaxLen = lResult
sItemText = ctlControl.List(i)
End If
NextItem:
Next

'Determine the width of the longest string found, in the context of the Combo font
lLength = mlStringLenInControl(ctlControl, sItemText)

If (lLength = 0) Then GoTo Exit_

'Fudge factor
lLength = lLength + 4

'Set the horizontal scrollbar extent
Select Case TypeName(ctlControl)
Case "ListBox"
lResult = SendMessage(ctlControl.hwnd, LB_SETHORIZONTALEXTENT, lLength, ByVal 0)
End Select

Exit_:
Exit Sub

err:
gErrHandlerAPI "mListBoxAdjustHScroll"

End Sub

Public Function mlStringLenInControl(ctlControl As Control, ByVal vsString As String) As Long
'Purpose: Determine the length in pixels of a string in the device context of ctlControl

Dim hDC As Long
Dim lFont As Long
Dim lFontOld As Long
Dim uSize As SIZE

Dim lHeight As Long
Dim lResult As Long

mlStringLenInControl = 0

With ctlControl
'Get a handle to the device context for the control
hDC = GetDC(.hwnd)
If (hDC = API_NULL) Then GoTo ErrAPI
lFont = SendMessage(.hwnd, WM_GETFONT, 0, ByVal 0)
If (lFont = API_NULL) Then GoTo ErrAPI
End With

'Select the font in to the device context, and retain prior font
lFontOld = SelectObject(hDC, lFont)
If (lFontOld = 0) Or (lFontOld = GDI_ERROR) Then GoTo ErrAPI

'Determine the width of the string
lResult = GetTextExtentPoint32(hDC, vsString, Len(vsString), uSize)
If (lResult = 0) Then GoTo ErrAPI

'Return the string length
mlStringLenInControl = uSize.cx

Exit_:
'Reset the device context font and delete the temporary font. Ignore any errors.
SelectObject hDC, lFontOld
'Release the device context handle. Ignore any errors.
ReleaseDC ctlControl.hwnd, hDC

Exit Function

err:
MsgBox "mlStringLenInControl: " & err.Number & " - " & err.Description
On Error Resume Next
Resume Exit_

ErrAPI:
gErrHandlerAPI "mlStringLenInControl"
GoTo Exit_

'Resume
End Function

Public Sub gErrHandlerAPI(ByVal vsRoutine As String, Optional ByVal vlMessageId As Variant)

Dim sBuffer As String
Dim lReturn As Long

If IsMissing(vlMessageId) Then
vlMessageId = GetLastError()
End If

sBuffer = Space(255)
lReturn = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, vlMessageId, 0, sBuffer, 255, 0)

If (lReturn > 0) Then
sBuffer = Left(sBuffer, lReturn - 1)
MsgBox "WinAPI (" & vsRoutine & "): " & sBuffer
Else
MsgBox "WinAPI (" & vsRoutine & "): " & vlMessageId & " - No description exists for this error number."
End If

End Sub

Public Sub mAddScrollBar(oControl As Control)

Dim lWindowStyle As Long

lWindowStyle = GetWindowLong(oControl.hwnd, GWL_STYLE)

If (lWindowStyle = 0) Then
gErrHandlerAPI "mAddScrollBar"
Exit Sub
End If

lWindowStyle = lWindowStyle Or WS_HSCROLL

SetLastError 0

lWindowStyle = SetWindowLong(oControl.hwnd, GWL_STYLE, lWindowStyle)

End Sub

Declaration in the module
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Public Const CB_SETDROPPEDWIDTH = &H160


Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Declare Function GetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hDC As Long, _
ByVal lpsz As String, _
ByVal cbString As Long, _
lpSize As SIZE) As Long

Public Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long

Public Declare Function SelectObject Lib "gdi32" _
(ByVal hDC As Long, ByVal hObject As Long) As Long

Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long

Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long _
, ByVal nIndex As Long) As Long

Public Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
Public Declare Function GetLastError Lib "kernel32" () As Long

Public Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Public Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long

Public Declare Function GetTickCount Lib "kernel32" () As Long

Public Const GWL_STYLE = (-16)
Public Const WS_HSCROLL = &H100000

Public Type SIZE
cx As Long
cy As Long
End Type

Public Const ANSI_FIXED_FONT = 11
Public Const ANSI_VAR_FONT = 12
Public Const SYSTEM_FONT = 13
Public Const DEFAULT_GUI_FONT = 17

Public Const GDI_ERROR = &HFFFF

Public Const FW_BOLD = 700
Public Const FW_NORMAL = 400
Public Const DEFAULT_CHARSET = 1
Public Const OUT_DEFAULT_PRECIS = 0
Public Const CLIP_DEFAULT_PRECIS = 0
Public Const DEFAULT_QUALITY = 0
Public Const DEFAULT_PITCH = 0
Public Const FF_DONTCARE = 0

Private Const API_NULL As Long = 0

Private Const WM_GETFONT = &H31

Private Const CB_GETLBTEXT = &H148
Private Const CB_GETLBTEXTLEN = &H149
'Private Const CB_SHOWDROPDOWN = &H14F
Private Const CB_SETHORIZONTALEXTENT = &H15E


Private Const LB_ERR = -1
Private Const LB_GETTEXT = &H189
Private Const LB_GETTEXTLEN = &H18A
Private Const LB_ITEMFROMPOINT = &H1A9
'Private Const LB_GETHORIZONTALEXTENT = &H193
Private Const LB_SETHORIZONTALEXTENT = &H194

 

[cbsm]

No idea ?
(I know - this is an horribly long post ...)

 

[BobRodes]

And that single list box would be called List1, right?

Bob

 

[BobRodes]

All right. I pasted your code as posted, fixed some obvious things, and it still doesn't work at all. Example:

If (lResult = CB_ERR) Then

errors out because CB_ERR isn't declared anywhere. At that point, I decided that I've spent all the time I'm going to on it. Perhaps a kinder soul than I will fix it, but I'd like to see you learn how to fix it yourself!

So. Some basic things to look at: don't declare API calls you're not going to use in the rest of your code. Don't make private declarations in a module, since you're liable to be calling them in your code. If you start with an example, eliminate code that's irrelevant to what youa re trying to accomplish. Be rigorous about that; it isn't well to use code that you don't understand.

I would read the article you reference, and attempt to figure out how all of it works. See if you can build the functionality you're looking for one piece at a time. API calls can be very simple, or very complex. There are lots of very good posts on the subject in this forum. So, do some background study, trim your "horribly long post", ask specific questions as you run into specific problems, and you'll probably get all the help you need here.

To learn more about API calls, start with the basics. First the declare statement, of which Sleep is a simple example:

Public Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)

Let's break this down.

Declare Sub Sleep: you can give any name you like here; Declare Sub Fribbleknockety is perfectly valid, although of course it wouldn't do much for making your code understandable.

Lib "kernel32" means that the Sleep routine is contaned in kernel32.dll, or the kernel32 API file.

Alias "Sleep" means that the name of the routine in the kernel32 file is "Sleep". This is why you can declare your sub as having any name you like; the name known to the dll is in the alias. (Usually, the alias name will be the name of the command with an A or W suffixed, meaning that it's using ASCII or Unicode conventions. For example, you'll see Declare Sub GetWindowsDirectory with an Alias of GetWindowsDirectoryA.)

(ByVal dwMilliseconds As Long): the arguments and their types are specified by the procedure. You have to make your declaration conform exactly to what's specified. If you don't, your entire program will almost certainly require a "three finger salute". That all gets very interesting when you're passing strings.

The API Text Viewer (See the Visual Studio 6.0 Tools menu) contains all of the correct declare statements for the Windows APIs.

This should get you started.

HTH

Bob

 

[cbsm]

Thank you Bob, for taking the time !

First - No the single listbox is NOT called list1 !!!

It is true that I do not know API calls very well - but I do understand VB !
I tried going through the code in Debbug mode - and everything seemed to go as it should ... exept the result !
That's why I posted all the code : it runs fine (no errors) but the result is not the one I expected !
I suppose you're right and I will try to go more into this - but I've done this before - and could not find an answer so far ...

Thank you again for the time spent on this !

 

[BobRodes]

Well, as I said, I pasted your code, and the line I quoted errors out because CB_ERR hasn't been declared. If your code works, then it isn't the same code you posted.

Try it for yourself, and correct me if I'm wrong!

 

[strongm]

Most of the code isn't needed and is overly complex for what you are trying to do...

e.g. the entire function mlStringLenInControl can be eliminated, and you can use VB's builtin TextWidth function. Nor do you need mAddScrollBar, since you never use it (and anyway it doesn't work correctly for ListBoxes). The elimination of those two functions means you can get rid of almost all your CONST declarations and almost all of your API declarations. Also, unless you really care about API error description messages, you can also eliminate the gErrHandlerAPI function ...

... which effectively reduces all your declarations down to:

[blue]Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Const LB_SETHORIZONTALEXTENT = &H194[/blue]

which in turn means that your mListBoxAdjustHScroll routine can be reduced to about 4 lines of code (see my bare-bones implementation in thread222-277997)

 

[BobRodes]

Thanks strongm, I had the feeling 4 lines was about right...I should have said "a kinder and more knowledgeable soul."

Bob

 

[cbsm]

Thank you !
I used your code strongm - which does exactly what I wanted.
How come I didn't found this post when I was looking for help ?...
Nontheless, even if complicated, the other code should have worked ... one day, when I have the time (hahaha !) I will try to understand what i did wrong !
Thank you again, both of you for taking the time.