Ejemplos usando el Api de windows para Visual basic

180 - Agregar un ScrollBar horizontal en un ComboBox

Ejemplo enviado por Claudio Irizar que muestra como colocar una barra de Scroll horizontal a un control ComboBox

El ejemplo utiliza subclasificación por lo tanto controlar bien los errores para que no se cierre el vb

vista del combo con el scrollbar horizontal

Agregar un ComboBox

Código fuente en el formulario

Option Explicit Private Sub Form_Load() Dim i As Integer Combo1.Width = 2000 For i = 1 To 7 Combo1.AddItem String(50, Chr(65 + i)) Next Call Ap_ScroollBar(Combo1) End Sub

Código en un módulo bas

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 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 fMask As Long nMin As Long nMax As Long nPage As Long nPos As Long nTrackPos As Long End Type 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 Private Function GetHiWord(v As Long) As Long If v And &H80000000 Then GetHiWord = (v \ 65535) - 1 Else GetHiWord = v \ 65535 End If End Function Private Function GetLoWord(v As Long) As Long If v And &H8000& Then GetLoWord = &H8000 Or (v And &H7FFF&) Else GetLoWord = v And &HFFFF& End If End Function Public Sub Ap_ScroollBar(Combo As ComboBox) Dim ret As Long Dim lmax As Long Dim sMax As String Dim i As Long Dim t_Combo_Info As COMBOBOXINFO Dim t_Scroll_Info As SCROLLINFO For i = 0 To Combo.ListCount - 1 ret = SendMessage(Combo.hWnd, CB_GETLBTEXTLEN, i, ByVal 0) If (ret > lmax) Then lmax = ret sMax = Space(lmax) ret = SendMessage(Combo.hWnd, CB_GETLBTEXT, i, ByVal sMax) sMax = Left(sMax, ret) End If Next ret = SendMessage(Combo.hWnd, CB_GETDROPPEDWIDTH, 0, ByVal 0) lmax = GetActualWidth(Combo, sMax) If (lmax > ret) Then t_Combo_Info = Get_COMBOBOXINFO(Combo) SendMessage Combo.hWnd, CB_SETHORIZONTALEXTENT, lmax, ByVal 0 t_Scroll_Info = GetScrollBarInfo(t_Combo_Info.hwndList) t_Scroll_Info.nMax = lmax t_Scroll_Info.nPage = Combo.Width \ Screen.TwipsPerPixelX SetScrollInfo t_Combo_Info.hwndList, SB_HORZ, t_Scroll_Info, True oldproc = SetWindowLong(t_Combo_Info.hwndList, -4, AddressOf WndProc) End If End Sub Private Function Get_COMBOBOXINFO(Combo As ComboBox) As COMBOBOXINFO Dim CBI As COMBOBOXINFO CBI.cbSize = Len(CBI) GetComboBoxInfo Combo.hWnd, CBI Get_COMBOBOXINFO = 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(Combo 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 ret As Long On Error GoTo GetActualWidthError With Combo.Parent sSavedFont = .FontName iSavedSize = .FontSize bSavedBold = .FontBold bSavedItalic = .FontItalic bSavedUnderline = .FontUnderline .FontName = Combo.FontName .FontSize = Combo.FontSize .FontBold = Combo.FontBold .FontItalic = Combo.FontItalic .FontUnderline = Combo.FontUnderline End With bIsFontSaved = True hDC = GetDC(Combo.hWnd) ret = GetTextExtentPoint32(hDC, sString, Len(sString), uSize) ReleaseDC Combo.hWnd, hDC GetActualWidth = uSize.cx - 50 GetActualWidthError: On Error Resume Next If bIsFontSaved Then With Combo.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 T_Sinfo As SCROLLINFO Select Case wMsg Case WM_HSCROLL T_Sinfo.cbSize = Len(T_Sinfo) T_Sinfo = GetScrollBarInfo(hOwner) nOldPos = T_Sinfo.nPos Select Case GetLoWord(wParam) Case SB_LINEDOWN T_Sinfo.nPos = T_Sinfo.nPos + T_Sinfo.nPage Case SB_LINEUP T_Sinfo.nPos = T_Sinfo.nPos - T_Sinfo.nPage Case SB_PAGEDOWN T_Sinfo.nPos = T_Sinfo.nPos + T_Sinfo.nPage Case SB_PAGEUP T_Sinfo.nPos = T_Sinfo.nPos - T_Sinfo.nPage Case SB_THUMBTRACK T_Sinfo.nPos = GetHiWord(wParam) Case SB_ENDSCROLL End Select SetScrollInfo hOwner, SB_HORZ, T_Sinfo, True Case WM_DESTROY: SetWindowLong hOwner, -4, oldproc End Select WndProc = CallWindowProc(oldproc, hOwner, wMsg, wParam, lParam) End Function

Enlaces relacionados

Aplicar Scrollbar horizontal a un Listbox

Buscar en Recursos vb