|
-
Nov 27th, 2001, 11:20 AM
#1
Thread Starter
Junior Member
here is the code for a combobox with a horizontal scrollbar!!!
After numerous posts on several different boards a final solution for the combobox has been found. Here is the code to add the functional scrollbar ENJOY!!!!
'========Bas module code=========
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 SetScrollInfo Lib "user32" (ByVal hWnd As Long, ByVal n As Long, lpcScrollInfo
As SCROLLINFO, ByVal bool As Boolean) As Long
Private Declare Function GetScrollInfo Lib "user32" (ByVal hWnd As Long, ByVal n As Long, lpScrollInfo
As SCROLLINFO) As Long
Private Declare Function GetComboBoxInfo Lib "user32.dll" (ByVal hwndCombo As Long, CBInfo As COMBOBOXINFO)
As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As
Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As
Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const CB_GETLBTEXT = &H148
Private Const CB_GETLBTEXTLEN = &H149
Private Const CB_SETHORIZONTALEXTENT = &H15E
Private Const CB_GETDROPPEDWIDTH = &H15F
Private Const SB_HORZ = 0
Private Const SB_LINEDOWN = 1
Private Const SB_LINEUP = 0
Private Const SB_PAGEDOWN = 3
Private Const SB_PAGEUP = 2
Private Const SB_THUMBTRACK = 5
Private Const SB_ENDSCROLL = 8
Private Const WM_DESTROY = &H2
Private Const WM_HSCROLL = &H114
' SCROLLINFO fMask constants:
Private Const SIF_RANGE = &H1
Private Const SIF_PAGE = &H2
Private Const SIF_POS = &H4
Private Const SIF_DISABLENOSCROLL = &H8
Private Const SIF_TRACKPOS = &H10
Private Const SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS)
Private Type SCROLLINFO
cbSize As Long ' Size of structure
fMask As Long ' Which value(s) you are changing
nMin As Long ' Minimum value of the scroll bar
nMax As Long ' Maximum value of the scroll bar
nPage As Long ' Large-change amount
nPos As Long ' Current value
nTrackPos As Long ' Current scroll position
End Type
Private Const GWL_WNDPROC = (-4)
Private Const WS_VSCROLL = &H200000
Private Const WS_HSCROLL = &H100000
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal
nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal
nIndex As Long, ByVal dwNewLong As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type COMBOBOXINFO
cbSize As Long
rcItem As RECT
rcButton As RECT
stateButton As Long
hwndCombo As Long
hwndEdit As Long
hwndList As Long
End Type
Private Type SIZE
cx As Long
cy As Long
End Type
Dim oldproc As Long
Public Sub SetHorzScrollBar(cb As ComboBox)
Dim lResult As Long
Dim lmax As Long
Dim sMax As String
Dim lCount As Long
Dim uComboInfo As COMBOBOXINFO
Dim uScrollInfo As SCROLLINFO
For lCount = 0 To cb.ListCount - 1
lResult = SendMessage(cb.hWnd, CB_GETLBTEXTLEN, lCount, ByVal 0)
If (lResult > lmax) Then
lmax = lResult
sMax = Space(lmax)
lResult = SendMessage(cb.hWnd, CB_GETLBTEXT, lCount, ByVal sMax)
sMax = Left(sMax, lResult)
End If
Next
lResult = SendMessage(cb.hWnd, CB_GETDROPPEDWIDTH, 0, ByVal 0)
lmax = GetActualWidth(cb, sMax)
If (lmax > lResult) Then
uComboInfo = GetComboInfo(cb)
SendMessage cb.hWnd, CB_SETHORIZONTALEXTENT, lmax, ByVal 0
uScrollInfo = GetScrollBarInfo(uComboInfo.hwndList)
uScrollInfo.nMax = lmax
'***ajust max scroll value as you need***
uScrollInfo.nPage = cb.Width \ Screen.TwipsPerPixelX
SetScrollInfo uComboInfo.hwndList, SB_HORZ, uScrollInfo, True
oldproc = SetWindowLong(uComboInfo.hwndList, GWL_WNDPROC, AddressOf WndProc)
End If
End Sub
Private Function GetComboInfo(cboCombo As ComboBox) As COMBOBOXINFO
Dim CBI As COMBOBOXINFO
CBI.cbSize = Len(CBI)
GetComboBoxInfo cboCombo.hWnd, CBI
GetComboInfo = CBI
End Function
Private Function GetScrollBarInfo(hWnd As Long) As SCROLLINFO
Dim SBI As SCROLLINFO
SBI.cbSize = Len(SBI)
SBI.fMask = SIF_ALL
GetScrollInfo hWnd, SB_HORZ, SBI
GetScrollBarInfo = SBI
End Function
Private Function GetActualWidth(cboCombo As ComboBox, sString As String) As Long
Dim hDC As Long
Dim uSize As SIZE
Dim sSavedFont As String
Dim iSavedSize As Integer
Dim bSavedBold As Boolean
Dim bSavedItalic As Boolean
Dim bSavedUnderline As Boolean
Dim bIsFontSaved As Boolean
Dim lResult As Long
On Error GoTo GetActualWidthError
With cboCombo.Parent
sSavedFont = .FontName
iSavedSize = .FontSize
bSavedBold = .FontBold
bSavedItalic = .FontItalic
bSavedUnderline = .FontUnderline
.FontName = cboCombo.FontName
.FontSize = cboCombo.FontSize
.FontBold = cboCombo.FontBold
.FontItalic = cboCombo.FontItalic
.FontUnderline = cboCombo.FontUnderline
End With
bIsFontSaved = True
hDC = GetDC(cboCombo.hWnd)
lResult = GetTextExtentPoint32(hDC, sString, Len(sString), uSize)
ReleaseDC cboCombo.hWnd, hDC
GetActualWidth = uSize.cx - 50
GetActualWidthError:
On Error Resume Next
If bIsFontSaved Then
With cboCombo.Parent
.FontName = sSavedFont
.FontSize = iSavedSize
.FontUnderline = bSavedUnderline
.FontBold = bSavedBold
.FontItalic = bSavedItalic
End With
End If
End Function
Public Function WndProc(ByVal hOwner As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam
As Long) As Long
Dim nOldPos As Long, n As Long
Dim s As SCROLLINFO
Select Case wMsg
Case WM_HSCROLL
s.cbSize = Len(s)
s = GetScrollBarInfo(hOwner)
nOldPos = s.nPos
Select Case GetLoWord(wParam)
Case SB_LINEDOWN
'***ajust min scroll value as you need***
s.nPos = s.nPos + s.nPage \ 25
Case SB_LINEUP
s.nPos = s.nPos - s.nPage \ 25
Case SB_PAGEDOWN
s.nPos = s.nPos + s.nPage
Case SB_PAGEUP
s.nPos = s.nPos - s.nPage
Case SB_THUMBTRACK
s.nPos = GetHiWord(wParam)
Case SB_ENDSCROLL
End Select
SetScrollInfo hOwner, SB_HORZ, s, True
Case WM_DESTROY
Call SetWindowLong(hOwner, GWL_WNDPROC, oldproc)
Case Else
End Select
WndProc = CallWindowProc(oldproc, hOwner, wMsg, wParam, lParam)
End Function
Private Function GetHiWord(dw As Long) As Long
If dw And &H80000000 Then
GetHiWord = (dw \ 65535) - 1
Else
GetHiWord = dw \ 65535
End If
End Function
Private Function GetLoWord(dw As Long) As Long
If dw And &H8000& Then
GetLoWord = &H8000 Or (dw And &H7FFF&)
Else
GetLoWord = dw And &HFFFF&
End If
End Function
'==========Form code========
Private Sub Form_Load()
Combo1.AddItem "Ottawa, Ontario"
Combo1.AddItem "St. John's, Newfoundland and Labrador"
Combo1.AddItem "Halifax, Nova Scotia"
Combo1.AddItem "Charlottetown, Prince Edward Island"
Combo1.AddItem "Fredericton, New Brunswick"
Combo1.AddItem "Qu?bec, Qu?bec"
Combo1.AddItem "Toronto, Ontario"
Combo1.AddItem "Winnipeg, Manitoba"
Combo1.AddItem "Regina, Saskatchewan"
Combo1.AddItem "Edmonton, Alberta"
Combo1.AddItem "Victoria, British Colombia"
Combo1.AddItem "Whitehorse, Yukon"
Combo1.AddItem "Yellowknife, Northwest Territories"
Combo1.AddItem "Iqaluit, Nunavut"
SetHorzScrollBar Combo1
End Sub
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|