Vistarized Combo dropdown height

[HughLerwill]

1. Vista Utimate SP1
2. Vb6 SP6
3. A pretty common routine to increase/ specify the dropped down height of a Combo box;

Public Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Sub ComboHeightSet(oComboBox As ComboBox, ByVal Nrows%, Optional onframe As Boolean = False)

Dim OldScaleMode%, Rowheight%
Dim lNewHeight&

Const CB_GETITEMHEIGHT = &H154

With oComboBox
' Change the ScaleMode on the parent to Pixels.
OldScaleMode = .Parent.ScaleMode
.Parent.ScaleMode = vbPixels

Rowheight = SendMessage(.hWnd, CB_GETITEMHEIGHT, 0, 0)
lNewHeight = Nrows * Rowheight + .Height + 2

' Resize the combo box window.
If Not onframe Then
MoveWindow .hWnd, .Left, .Top, .Width, lNewHeight, True
Else
'frame is always dimensioned in Twips so..
MoveWindow .hWnd, .Left / Screen.TwipsPerPixelX, .Top / Screen.TwipsPerPixelY, .Width / Screen.TwipsPerPixelX, lNewHeight, True
End If

' Replace the old ScaleMode
.Parent.ScaleMode = OldScaleMode
End With

End Sub

The above works in on previous versions of Windows and in the IDE on Vista however when running a compiled app on Vista the Combo dropdown always seems to end up with 30 rows (if it has =>30 entries) regardless of the Nrows parameter.

Can anyone else reproduce this qwirk/ suggest a fix?

 

[HughLerwill]

Ok the problem seems to be caused by use of Xp/Vista themes and not Vista specifically.

Prelim research seems to indicate that the combo box within "Microsoft.Windows.Common-Controls" version="6.0.0.0" specified in a manifest has a default dropdown height of 30 rows rather than the 8 rows in the standard vbcombobox (v5 common controls I guess).

The v6 combo does not appear to respond to the traditional MoveWindow API however the dropdown height in a v6 combo can apparently be changed by using;

SendMessage MyCombo.hWnd, CB_SETMINVISIBLE, Nrows, 0

So our old friend turns into something like;

Public Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function IsThemeActive Lib "uxtheme" () As Long

Private Function GetThemeStatus() As Long

' thanks to Hypetia in thread222-1395408

'returns
' 0 "Themes are disabled."
' 1 "Themes are enabled."
' -1 "Themes not supported." 'perhaps an older OS, like Win2k

GetThemeStatus = -1
On Error Resume Next 'uxtheme.dll may not exist on pre XP
GetThemeStatus = IsThemeActive
On Error GoTo 0

End Function

Public Sub ComboHeightSet(oComboBox As ComboBox, ByVal Nrows%, Optional onframe As Boolean = False)

Dim OldScaleMode%, Rowheight%
Dim lNewHeight&

Const CB_GETITEMHEIGHT = &H154
Const CBM_FIRST = &H1700 'Combobox control messages
Const CB_SETMINVISIBLE = (CBM_FIRST + 1)

With oComboBox
' Change the ScaleMode on the parent to Pixels.
OldScaleMode = .Parent.ScaleMode
.Parent.ScaleMode = vbPixels

Rowheight = SendMessage(.hWnd, CB_GETITEMHEIGHT, 0, 0)
lNewHeight = Nrows * Rowheight + .Height + 2

' Resize the combo box window.
If Not onframe Then
If GetThemeStatus = 1 And Len(Dir$(App.Path & "\" & App.EXEName & ".exe.manifest")) > 0 Then
'Themes are set and a manifest file exists
'manifests within exe resouces not handled, can they be?
SendMessage .hWnd, CB_SETMINVISIBLE, Nrows, 0
Else
'it's pre Xp or Themes are not in use or a manifest file does not exist
MoveWindow .hWnd, .Left, .Top, .Width, lNewHeight, True
End If
Else
'frame is always dimensioned in Twips so..
'xp/ vista styles not handled yet
MoveWindow .hWnd, .Left / Screen.TwipsPerPixelX, .Top / Screen.TwipsPerPixelY, .Width / Screen.TwipsPerPixelX, lNewHeight, True
End If

' Replace the old ScaleMode
.Parent.ScaleMode = OldScaleMode
End With

End Sub

Requires a little optimization but any comments so far?

 

[HughLerwill]

Best so far;

Option Explicit

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long

Private Type DLLVERSIONINFO
    cbSize As Long
    dwMajor As Long
    dwMinor As Long
    dwBuildNumber As Long
    dwPlatformID As Long
End Type
Private Declare Function CommonControlsVer Lib "Comctl32.dll" Alias "DllGetVersion" (pdvi As DLLVERSIONINFO) As Long

Private Function GetCommonControlsVer() As String
      
    Dim tDVI As DLLVERSIONINFO
    
    tDVI.cbSize = Len(tDVI)
    On Error Resume Next            'DllGetVersion is not implemented in early (pre v4.71) versions of comctl32.dll so an error is possible
    CommonControlsVer tDVI
    On Error GoTo 0                    'if there is an error "0.0" is returned
    GetCommonControlsVer = tDVI.dwMajor & "." & tDVI.dwMinor
    
    'ref [URL unfurl="true"]http://msdn.microsoft.com/en-us/library/bb776779(VS.85).aspx[/URL]
    '4.71 Internet Explorer 4.0
    '5.81 Comctl32.dll Windows 2000 and Windows Me. See note 3. (Win 95 tested with IE5.5 returns 5.81)
    '5.82 Comctl32.dll Windows XP and Windows Vista. See note 4
    'Note 4: ComCtl32.dll version 6 is not redistributable. If you want your application to use ComCtl32.dll version 6,
    ' you must add an application manifest that indicates that version 6 should be used if it is available.
            
End Function

Public Sub ComboHeightSet(oComboBox As ComboBox, ByVal Nrows%, Optional onframe As Boolean = False, Optional cbWidth% = 0)
    
    'not tested using a Manifest embedded in an exe resource

    Dim OldScaleMode%, Rowheight%
    Dim lNewHeight&
    Dim lret&
    
    Const CBM_FIRST = &H1700    'Combobox control messages
    Const CB_SETMINVISIBLE = (CBM_FIRST + 1)
    Const CB_GETITEMHEIGHT = &H154
    Const CB_SETDROPPEDWIDTH As Long = &H160
    
    With oComboBox
        'XP SP3 typically has Comctl32.dll v6.0, Vista SP1 has Comctl32.dll v6.16 (ref 17 July 2008)
        'CB_SETMINVISIBLE does not seem to work with Comctl32.dll v6.0 as advertised
        If Val(GetCommonControlsVer) >= 6.16 Then
            'typically Vista and there is a manifest file specifying Comctl32.dll v6.0
            ' note: if IsThemeActive() = 0 the combo looks like an old style one but it appears we still need to talk to it like this ...
            SendMessage .hWnd, CB_SETMINVISIBLE, Nrows, 0
        Else
            'typically XP and previous, or Vista with no manifest file
            ' Change the ScaleMode on the parent to Pixels.
            OldScaleMode = .Parent.ScaleMode
            .Parent.ScaleMode = vbPixels

            Rowheight = SendMessage(.hWnd, CB_GETITEMHEIGHT, 0, 0)
            lNewHeight = Nrows * Rowheight + .Height + 2
            
            ' Resize the combo box window.
            If Not onframe Then
                MoveWindow .hWnd, .Left, .Top, .Width, lNewHeight, True
            Else
                'frame is unaffected by .Parent.ScaleMode and remains dimensioned in Twips so..
                MoveWindow .hWnd, .Left / Screen.TwipsPerPixelX, .Top / Screen.TwipsPerPixelY, .Width / Screen.TwipsPerPixelX, lNewHeight, True
            End If
            
            ' Replace the old ScaleMode
            .Parent.ScaleMode = OldScaleMode
        End If
        
        If cbWidth > 0 Then
            SendMessage .hWnd, CB_SETDROPPEDWIDTH, cbWidth / Screen.TwipsPerPixelX, 0
        End If
        
    End With
    
End Sub