one for the guru's

Discussion in 'Microsoft Excel Programming' started by alex.simms, Mar 13, 2005.

  1. alex.simms

    alex.simms Guest

    I've been re-searching the mouse, and no where can I find a pointer or
    solution to scrolling with a mouse in a listbox on a form.
    there are lots of pointer to "API" but not sure if this is suitable for an
    excel form.
    the question is,
    is it possible to scroll within a listbox using
    excel vba.
    --
    regards
    ALEX
     
    alex.simms, Mar 13, 2005
    #1
    1. Advertisements

  2. Alex,

    Yes, but I use an activex control from Mabry to do it. The solution is here:

    http://www.enhanceddatasystems.com/ED/Pages/ExcelListScrolls.htm

    Robin Hammond
    www.enhanceddatasystems.com

    "alex.simms" <> wrote in message
    news:eESP8q$...
    > I've been re-searching the mouse, and no where can I find a pointer or
    > solution to scrolling with a mouse in a listbox on a form.
    > there are lots of pointer to "API" but not sure if this is suitable for an
    > excel form.
    > the question is,
    > is it possible to scroll within a listbox using
    > excel vba.
    > --
    > regards
    > ALEX
    >
    >
     
    Robin Hammond, Mar 14, 2005
    #2
    1. Advertisements

  3. alex.simms

    alex.simms Guest

    this was the reply I got from maybury

    We no longer sell the MouseWheel control.

    Sam Xavier
    Mabry Software Technical Support


    --
    regards
    ALEX

    "Robin Hammond" <> wrote in message
    news:...
    > Alex,
    >
    > Yes, but I use an activex control from Mabry to do it. The solution is
    > here:
    >
    > http://www.enhanceddatasystems.com/ED/Pages/ExcelListScrolls.htm
    >
    > Robin Hammond
    > www.enhanceddatasystems.com
    >
    > "alex.simms" <> wrote in message
    > news:eESP8q$...
    >> I've been re-searching the mouse, and no where can I find a pointer or
    >> solution to scrolling with a mouse in a listbox on a form.
    >> there are lots of pointer to "API" but not sure if this is suitable for
    >> an excel form.
    >> the question is,
    >> is it possible to scroll within a listbox using
    >> excel vba.
    >> --
    >> regards
    >> ALEX
    >>
    >>

    >
    >
     
    alex.simms, Mar 14, 2005
    #3
  4. Alex,

    Here's a cut at it using Windows call backs which is MUCH more complex than
    the Mabry ocx, but if they want to be difficult... I've updated my site to
    say that Mabry have discontinued the control as well. Thanks for the heads
    up on that.

    Anyway, it's fairly simple (NOT).

    There's an open invitation to anyone who wants to try and improve on this! I
    certainly haven't perfected it yet.

    PLEASE save your work and any data first before trying this. It is not fully
    tested and if the callback routine is left outstanding due to abnormal
    termination Excel can hang or weird things might happen. Debugging is also a
    touch difficult, since Windows wants to react to events but they are being
    trapped by the call back. I have only tried this in Excel XP and Win XP at
    present.

    And, this will only work in versions of Excel that can handle the AddressOf
    function. I can't remember when it was introduced offhand.

    HTH,

    Robin Hammond
    www.enhanceddatasystems.com

    'CODE
    'Create a userform, add 3 listboxes and a commandbutton. Name them to work
    with the code below. In your form code:

    Option Explicit

    Private Sub cmdOK_Click()
    Unload Me
    End Sub

    Private Sub UserForm_Initialize()
    Dim lCounter As Long
    For lCounter = 1 To 1000
    lst1.AddItem lCounter
    lst2.AddItem lCounter
    lst3.AddItem lCounter
    Next lCounter
    HookWheel Me, Me.Width, Me.Height, 3
    End Sub

    Private Sub UserForm_Terminate()
    'THIS MUST BE CALLED OR WE HAVE A PROBLEM WITH THE CALLBACK
    UnHookWheel
    End Sub

    'Create a Module mWheelHandler as follows:

    Option Explicit
    Option Private Module

    '************************************************************
    'APIs
    '************************************************************

    Private Declare Function CallWindowProc Lib "user32.dll" 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 Declare Function SetWindowLong Lib "user32.dll" Alias _
    "SetWindowLongA" ( _
    ByVal hWnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

    Private Declare Function FindWindowA Lib "user32" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long

    Private Declare Function GetSystemMetrics Lib "user32" _
    (ByVal nIndex As Long) As Long

    Private Declare Function GetWindowRect Lib "user32" ( _
    ByVal hWnd As Long, lpRect As typeRect) As Long

    'used to store screen position for GetWindowRect call
    Private Type typeRect
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
    End Type

    'screen factor constants
    Private dXFactor As Double 'hold screen Conversion coordinates
    Private dYFactor As Double
    Private lCaptionHeight As Long

    '************************************************************
    'Constants
    '************************************************************
    Private Const GWL_WNDPROC = -4
    Private Const WM_MOUSEWHEEL = &H20A
    Private Const SM_MOUSEWHEELPRESENT = 75

    Private lLines As Long

    '************************************************************
    'Variables
    '************************************************************
    Private hForm As Long
    Public lPrevWndProc As Long
    Private lX As Long
    Private lY As Long
    Private bUp As Boolean
    Private frmContainer As msForms.UserForm

    '*************************************************************
    'WindowProc
    '*************************************************************
    Private Function WindowProc( _
    ByVal lWnd As Long, _
    ByVal lMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long

    'converted from code by Kevin Wilson on thevbzone

    'Test if the message is WM_MOUSEWHEEL
    If lMsg = WM_MOUSEWHEEL Then

    lX = lParam And 65535
    lY = lParam \ 65535
    bUp = (wParam > 0)
    WheelHandler bUp

    End If

    'Sends message to previous procedure if not MOUSEWHEEL
    'This is VERY IMPORTANT!!!
    If lMsg <> WM_MOUSEWHEEL Then

    WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg, wParam,
    lParam)

    End If

    End Function

    Public Sub HookWheel(ByVal frmName As msForms.UserForm, dWidth As Double, _
    dHeight As Double, ByVal lLinesToScroll As Long)

    If WheelPresent Then

    Set frmContainer = frmName
    hForm = GetFormHandle(frmName)
    GetScreenFactors hForm, dWidth, dHeight
    lLines = lLinesToScroll
    'create the call back procedure
    'addressof doesn't work in earlier versions but not sure which ones
    lPrevWndProc = SetWindowLong(hForm, GWL_WNDPROC, AddressOf WindowProc)

    End If

    End Sub

    Public Sub UnHookWheel()
    'very important that this is called when the form is unloaded to remove the
    call back
    Call SetWindowLong(hForm, GWL_WNDPROC, lPrevWndProc)
    End Sub

    Private Function GetFormHandle(ByVal frmName As msForms.UserForm, _
    Optional bByClass As Boolean = True) As Long
    'returns a handle to the userform
    Dim strClassName As String
    Dim strCaption As String

    strClassName = IIf(Val(Application.Version) > 8, "ThunderDFrame", _
    "ThunderXFrame") & vbNullChar
    strCaption = vbNullString
    GetFormHandle = FindWindowA(strClassName, strCaption)

    End Function

    Public Sub GetScreenFactors(lHwnd As Long, _
    dWidth As Double, _
    dHeight As Double)
    'returns screen factors for conversion to Excel units rather than win coords
    Dim uRect As typeRect
    GetWindowRect lHwnd, uRect
    dXFactor = dWidth / (uRect.Right - uRect.Left)
    dYFactor = dHeight / (uRect.Bottom - uRect.Top)
    lCaptionHeight = dHeight - frmContainer.InsideHeight
    End Sub

    Private Function WheelPresent() As Boolean
    'function by Kevin Wilson from www.thevbzone.com

    ' Check for wheel mouse on Win98, WinNT 4.0, & Win2000
    If GetSystemMetrics(SM_MOUSEWHEELPRESENT) Then

    WheelPresent = True

    ' Check for wheel mouse on Win32's, Win95, & WinNT 3.5x
    ElseIf FindWindowA("MouseZ", "Magellan MSWHEEL") <> 0 Then

    WheelPresent = True

    End If

    End Function

    Sub WheelHandler(bUp As Boolean)

    Dim ctlFocus As msForms.Control
    Dim ctlName As msForms.Control
    Dim lTopIndex As Long
    Dim bMultiPage As Boolean
    Dim lPage As Long
    Dim lMove As Long

    If Not IsOverForm Then Exit Sub
    Set ctlFocus = frmContainer.ActiveControl

    'if we are in a multipage then need to set the control
    'to whatever the subcontrol is on the active page

    If TypeOf ctlFocus Is msForms.MultiPage Then

    'set the multipage flag
    bMultiPage = True

    'store the page number for the MP
    lPage = ctlFocus.Value

    'set the focus control to the control on the current page
    Set ctlFocus = ctlFocus.SelectedItem.ActiveControl

    End If

    'convert screen coords
    lX = lX * dXFactor
    lY = lY * dYFactor
    lY = lY - lCaptionHeight

    'for anything but a commandbutton and textbox lx is relative to the left
    'and top of the control, so adjust
    If Not (TypeOf ctlFocus Is msForms.CommandButton Or _
    TypeOf ctlFocus Is msForms.TextBox) Then

    'lX = lX + ctlFocus.Left
    'lY = lY + ctlFocus.Top

    End If

    'loop controls, looking for list boxes
    For Each ctlName In frmContainer.Controls

    With ctlName

    If TypeOf ctlName Is msForms.ListBox Then

    'if we are in a multipage
    If bMultiPage = True Then

    'if we are not on the correct page then skip this control
    If lPage <> .Parent.Index Then GoTo SkipControl

    End If

    'check right of left bound
    If lX > .Left Then

    'check within width
    If lX < .Left + .Width Then

    'check below top bound
    If lY > .Top Then

    'check within height
    If lY < .Top + .Height Then

    'WE FOUND THE RIGHT CONTROL SO HANDLE THE SCROLL

    'if the list is empty there is nothing to scroll
    If .ListCount = 0 Then Exit Sub

    'check scroll direction
    lMove = IIf(bUp, -lLines, lLines)

    'get the new top index
    lTopIndex = .TopIndex + lMove

    'check it is within valid limits
    If lTopIndex < 0 Then

    lTopIndex = 0

    ElseIf lTopIndex > .ListCount - (.Height / 10) +
    2 Then

    lTopIndex = .TopIndex

    End If

    'set the new top index
    .TopIndex = lTopIndex

    'scroll has been handled so stop looping
    Exit Sub

    End If

    End If

    End If

    End If

    End If

    End With

    SkipControl:
    Next ctlName

    End Sub

    Public Function IsOverForm() As Boolean
    'we can't get the form's coordinates directly when referenced as a form
    'rather than ME within the form's code
    'so call GetWindowRect again in case the form has been moved
    Dim uRect As typeRect
    GetWindowRect hForm, uRect
    With uRect
    If lX >= .Left Then
    If lX <= .Right Then
    If lY >= .Top Then
    If lY <= .Bottom Then
    IsOverForm = True
    lX = lX - .Left
    lY = lY - .Top
    End If
    End If
    End If
    End If
    End With
    End Function

    That's almost certainly the longest post I've ever made to this group. Any
    improvements suggested?

    Robin Hammond
    www.enhanceddatasystems.com


    "alex.simms" <> wrote in message
    news:OLQj$...
    > this was the reply I got from maybury
    >
    > We no longer sell the MouseWheel control.
    >
    > Sam Xavier
    > Mabry Software Technical Support
    >
    >
    > --
    > regards
    > ALEX
    >
    > "Robin Hammond" <> wrote in message
    > news:...
    >> Alex,
    >>
    >> Yes, but I use an activex control from Mabry to do it. The solution is
    >> here:
    >>
    >> http://www.enhanceddatasystems.com/ED/Pages/ExcelListScrolls.htm
    >>
    >> Robin Hammond
    >> www.enhanceddatasystems.com
    >>
    >> "alex.simms" <> wrote in message
    >> news:eESP8q$...
    >>> I've been re-searching the mouse, and no where can I find a pointer or
    >>> solution to scrolling with a mouse in a listbox on a form.
    >>> there are lots of pointer to "API" but not sure if this is suitable for
    >>> an excel form.
    >>> the question is,
    >>> is it possible to scroll within a listbox using
    >>> excel vba.
    >>> --
    >>> regards
    >>> ALEX
    >>>
    >>>

    >>
    >>

    >
    >
     
    Robin Hammond, Mar 15, 2005
    #4
  5. alex.simms

    alex.simms Guest

    a)due to the way in which the length of line of text was created in the
    original post the words" CALL BACK" appear on the wrong row and not as a
    comment as i asume was the intention
    >Public Sub UnHookWheel()
    >'very important that this is called when the form is unloaded to remove

    the
    >"call back"
    > Call SetWindowLong(hForm, GWL_WNDPROC, lPrevWndProc)
    > End Sub

    b)
    >Private Sub cmdOK_Click()
    >Application.Run "UnHookWheel" ' change 2nd line to Application.Run
    >"UnHookWheel" the form will still be 'seen
    >'Unload Me
    >End Sub

    c)having changed the form to a single listbox and running with a database of
    7 colums and some 3000 lines i was able to get the mouse scrolling to work
    with no apparent problems other than.
    1) some times excel froze or took a long time to load
    2) the mouse scrolling only worked if the list boxwas filled by using
    'Private Sub UserForm_Initialize()
    'Dim i As Integer
    ' fill ListBox1 with values
    ' With Me.lst1
    ' .Clear ' remove existing content
    ' .ColumnCount = 8
    ' .ColumnWidths = "20,50,130,100,100,100,100,100"
    ' For i = 1 To 25
    ' .AddItem ' add a new row
    ' .List(i - 1, 0) = "Column1 Item " & i
    ' .List(i - 1, 1) = "Column2 Item " & i
    ' .List(i - 1, 2) = "Column3 Item " & i
    ' .List(i - 1, 3) = "Column4 Item " & i
    ' .List(i - 1, 4) = "Column5 Item " & i
    ' .List(i - 1, 5) = "Column6 Item " & i
    ' .List(i - 1, 6) = "Column7 Item " & i
    ' .L'ist(i - 1, 7) = "Column8 Item " & i
    ' .List(i - 1, 8) = "Column9 Item " & i
    ' Next i
    ' End With
    ' HookWheel Me, Me.Width, Me.Height, 3

    'End Sub
    3) if i used rowsource : sheet2!A2:G3000 nothing happened
    4) can any one suggest why?

    --
    regards
    ALEX

    "Robin Hammond" <> wrote in message
    news:...
    > Alex,
    >
    > Here's a cut at it using Windows call backs which is MUCH more complex
    > than the Mabry ocx, but if they want to be difficult... I've updated my
    > site to say that Mabry have discontinued the control as well. Thanks for
    > the heads up on that.
    >
    > Anyway, it's fairly simple (NOT).
    >
    > There's an open invitation to anyone who wants to try and improve on this!
    > I certainly haven't perfected it yet.
    >
    > PLEASE save your work and any data first before trying this. It is not
    > fully tested and if the callback routine is left outstanding due to
    > abnormal termination Excel can hang or weird things might happen.
    > Debugging is also a touch difficult, since Windows wants to react to
    > events but they are being trapped by the call back. I have only tried this
    > in Excel XP and Win XP at present.
    >
    > And, this will only work in versions of Excel that can handle the
    > AddressOf function. I can't remember when it was introduced offhand.
    >
    > HTH,
    >
    > Robin Hammond
    > www.enhanceddatasystems.com
    >
    > 'CODE
    > 'Create a userform, add 3 listboxes and a commandbutton. Name them to work
    > with the code below. In your form code:
    >
    > Option Explicit
    >
    > Private Sub cmdOK_Click()
    > Unload Me
    > End Sub
    >
    > Private Sub UserForm_Initialize()
    > Dim lCounter As Long
    > For lCounter = 1 To 1000
    > lst1.AddItem lCounter
    > lst2.AddItem lCounter
    > lst3.AddItem lCounter
    > Next lCounter
    > HookWheel Me, Me.Width, Me.Height, 3
    > End Sub
    >
    > Private Sub UserForm_Terminate()
    > 'THIS MUST BE CALLED OR WE HAVE A PROBLEM WITH THE CALLBACK
    > UnHookWheel
    > End Sub
    >
    > 'Create a Module mWheelHandler as follows:
    >
    > Option Explicit
    > Option Private Module
    >
    > '************************************************************
    > 'APIs
    > '************************************************************
    >
    > Private Declare Function CallWindowProc Lib "user32.dll" 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 Declare Function SetWindowLong Lib "user32.dll" Alias _
    > "SetWindowLongA" ( _
    > ByVal hWnd As Long, _
    > ByVal nIndex As Long, _
    > ByVal dwNewLong As Long) As Long
    >
    > Private Declare Function FindWindowA Lib "user32" ( _
    > ByVal lpClassName As String, _
    > ByVal lpWindowName As String) As Long
    >
    > Private Declare Function GetSystemMetrics Lib "user32" _
    > (ByVal nIndex As Long) As Long
    >
    > Private Declare Function GetWindowRect Lib "user32" ( _
    > ByVal hWnd As Long, lpRect As typeRect) As Long
    >
    > 'used to store screen position for GetWindowRect call
    > Private Type typeRect
    > Left As Long
    > Top As Long
    > Right As Long
    > Bottom As Long
    > End Type
    >
    > 'screen factor constants
    > Private dXFactor As Double 'hold screen Conversion coordinates
    > Private dYFactor As Double
    > Private lCaptionHeight As Long
    >
    > '************************************************************
    > 'Constants
    > '************************************************************
    > Private Const GWL_WNDPROC = -4
    > Private Const WM_MOUSEWHEEL = &H20A
    > Private Const SM_MOUSEWHEELPRESENT = 75
    >
    > Private lLines As Long
    >
    > '************************************************************
    > 'Variables
    > '************************************************************
    > Private hForm As Long
    > Public lPrevWndProc As Long
    > Private lX As Long
    > Private lY As Long
    > Private bUp As Boolean
    > Private frmContainer As msForms.UserForm
    >
    > '*************************************************************
    > 'WindowProc
    > '*************************************************************
    > Private Function WindowProc( _
    > ByVal lWnd As Long, _
    > ByVal lMsg As Long, _
    > ByVal wParam As Long, _
    > ByVal lParam As Long) As Long
    >
    > 'converted from code by Kevin Wilson on thevbzone
    >
    > 'Test if the message is WM_MOUSEWHEEL
    > If lMsg = WM_MOUSEWHEEL Then
    >
    > lX = lParam And 65535
    > lY = lParam \ 65535
    > bUp = (wParam > 0)
    > WheelHandler bUp
    >
    > End If
    >
    > 'Sends message to previous procedure if not MOUSEWHEEL
    > 'This is VERY IMPORTANT!!!
    > If lMsg <> WM_MOUSEWHEEL Then
    >
    > WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg, wParam,
    > lParam)
    >
    > End If
    >
    > End Function
    >
    > Public Sub HookWheel(ByVal frmName As msForms.UserForm, dWidth As Double,
    > _
    > dHeight As Double, ByVal lLinesToScroll As Long)
    >
    > If WheelPresent Then
    >
    > Set frmContainer = frmName
    > hForm = GetFormHandle(frmName)
    > GetScreenFactors hForm, dWidth, dHeight
    > lLines = lLinesToScroll
    > 'create the call back procedure
    > 'addressof doesn't work in earlier versions but not sure which ones
    > lPrevWndProc = SetWindowLong(hForm, GWL_WNDPROC, AddressOf WindowProc)
    >
    > End If
    >
    > End Sub
    >
    > Public Sub UnHookWheel()
    > 'very important that this is called when the form is unloaded to remove
    > the call back
    > Call SetWindowLong(hForm, GWL_WNDPROC, lPrevWndProc)
    > End Sub
    >
    > Private Function GetFormHandle(ByVal frmName As msForms.UserForm, _
    > Optional bByClass As Boolean = True) As Long
    > 'returns a handle to the userform
    > Dim strClassName As String
    > Dim strCaption As String
    >
    > strClassName = IIf(Val(Application.Version) > 8, "ThunderDFrame", _
    > "ThunderXFrame") & vbNullChar
    > strCaption = vbNullString
    > GetFormHandle = FindWindowA(strClassName, strCaption)
    >
    > End Function
    >
    > Public Sub GetScreenFactors(lHwnd As Long, _
    > dWidth As Double, _
    > dHeight As Double)
    > 'returns screen factors for conversion to Excel units rather than win
    > coords
    > Dim uRect As typeRect
    > GetWindowRect lHwnd, uRect
    > dXFactor = dWidth / (uRect.Right - uRect.Left)
    > dYFactor = dHeight / (uRect.Bottom - uRect.Top)
    > lCaptionHeight = dHeight - frmContainer.InsideHeight
    > End Sub
    >
    > Private Function WheelPresent() As Boolean
    > 'function by Kevin Wilson from www.thevbzone.com
    >
    > ' Check for wheel mouse on Win98, WinNT 4.0, & Win2000
    > If GetSystemMetrics(SM_MOUSEWHEELPRESENT) Then
    >
    > WheelPresent = True
    >
    > ' Check for wheel mouse on Win32's, Win95, & WinNT 3.5x
    > ElseIf FindWindowA("MouseZ", "Magellan MSWHEEL") <> 0 Then
    >
    > WheelPresent = True
    >
    > End If
    >
    > End Function
    >
    > Sub WheelHandler(bUp As Boolean)
    >
    > Dim ctlFocus As msForms.Control
    > Dim ctlName As msForms.Control
    > Dim lTopIndex As Long
    > Dim bMultiPage As Boolean
    > Dim lPage As Long
    > Dim lMove As Long
    >
    > If Not IsOverForm Then Exit Sub
    > Set ctlFocus = frmContainer.ActiveControl
    >
    > 'if we are in a multipage then need to set the control
    > 'to whatever the subcontrol is on the active page
    >
    > If TypeOf ctlFocus Is msForms.MultiPage Then
    >
    > 'set the multipage flag
    > bMultiPage = True
    >
    > 'store the page number for the MP
    > lPage = ctlFocus.Value
    >
    > 'set the focus control to the control on the current page
    > Set ctlFocus = ctlFocus.SelectedItem.ActiveControl
    >
    > End If
    >
    > 'convert screen coords
    > lX = lX * dXFactor
    > lY = lY * dYFactor
    > lY = lY - lCaptionHeight
    >
    > 'for anything but a commandbutton and textbox lx is relative to the left
    > 'and top of the control, so adjust
    > If Not (TypeOf ctlFocus Is msForms.CommandButton Or _
    > TypeOf ctlFocus Is msForms.TextBox) Then
    >
    > 'lX = lX + ctlFocus.Left
    > 'lY = lY + ctlFocus.Top
    >
    > End If
    >
    > 'loop controls, looking for list boxes
    > For Each ctlName In frmContainer.Controls
    >
    > With ctlName
    >
    > If TypeOf ctlName Is msForms.ListBox Then
    >
    > 'if we are in a multipage
    > If bMultiPage = True Then
    >
    > 'if we are not on the correct page then skip this control
    > If lPage <> .Parent.Index Then GoTo SkipControl
    >
    > End If
    >
    > 'check right of left bound
    > If lX > .Left Then
    >
    > 'check within width
    > If lX < .Left + .Width Then
    >
    > 'check below top bound
    > If lY > .Top Then
    >
    > 'check within height
    > If lY < .Top + .Height Then
    >
    > 'WE FOUND THE RIGHT CONTROL SO HANDLE THE SCROLL
    >
    > 'if the list is empty there is nothing to
    > scroll
    > If .ListCount = 0 Then Exit Sub
    >
    > 'check scroll direction
    > lMove = IIf(bUp, -lLines, lLines)
    >
    > 'get the new top index
    > lTopIndex = .TopIndex + lMove
    >
    > 'check it is within valid limits
    > If lTopIndex < 0 Then
    >
    > lTopIndex = 0
    >
    > ElseIf lTopIndex > .ListCount - (.Height / 10)
    > + 2 Then
    >
    > lTopIndex = .TopIndex
    >
    > End If
    >
    > 'set the new top index
    > .TopIndex = lTopIndex
    >
    > 'scroll has been handled so stop looping
    > Exit Sub
    >
    > End If
    >
    > End If
    >
    > End If
    >
    > End If
    >
    > End If
    >
    > End With
    >
    > SkipControl:
    > Next ctlName
    >
    > End Sub
    >
    > Public Function IsOverForm() As Boolean
    > 'we can't get the form's coordinates directly when referenced as a form
    > 'rather than ME within the form's code
    > 'so call GetWindowRect again in case the form has been moved
    > Dim uRect As typeRect
    > GetWindowRect hForm, uRect
    > With uRect
    > If lX >= .Left Then
    > If lX <= .Right Then
    > If lY >= .Top Then
    > If lY <= .Bottom Then
    > IsOverForm = True
    > lX = lX - .Left
    > lY = lY - .Top
    > End If
    > End If
    > End If
    > End If
    > End With
    > End Function
    >
    > That's almost certainly the longest post I've ever made to this group. Any
    > improvements suggested?
    >
    > Robin Hammond
    > www.enhanceddatasystems.com
    >
    >
    > "alex.simms" <> wrote in message
    > news:OLQj$...
    >> this was the reply I got from maybury
    >>
    >> We no longer sell the MouseWheel control.
    >>
    >> Sam Xavier
    >> Mabry Software Technical Support
    >>
    >>
    >> --
    >> regards
    >> ALEX
    >>
    >> "Robin Hammond" <> wrote in message
    >> news:...
    >>> Alex,
    >>>
    >>> Yes, but I use an activex control from Mabry to do it. The solution is
    >>> here:
    >>>
    >>> http://www.enhanceddatasystems.com/ED/Pages/ExcelListScrolls.htm
    >>>
    >>> Robin Hammond
    >>> www.enhanceddatasystems.com
    >>>
    >>> "alex.simms" <> wrote in message
    >>> news:eESP8q$...
    >>>> I've been re-searching the mouse, and no where can I find a pointer or
    >>>> solution to scrolling with a mouse in a listbox on a form.
    >>>> there are lots of pointer to "API" but not sure if this is suitable for
    >>>> an excel form.
    >>>> the question is,
    >>>> is it possible to scroll within a listbox using
    >>>> excel vba.
    >>>> --
    >>>> regards
    >>>> ALEX
    >>>>
    >>>>
    >>>
    >>>

    >>
    >>

    >
    >
     
    alex.simms, Mar 20, 2005
    #5
  6. alex.simms

    alex.simms Guest

    sorry it should have read
    'Private Sub UserForm_Initialize()
    ' Dim cell As Range
    ' Dim Rng As Range
    ' With ThisWorkbook.Sheets("Sheet1")
    ' Set Rng = .Range("A2", .Range("A2").End(xlDown))
    ' End With
    ' For Each cell In Rng.Cells
    ' With Me.lst1
    ' .AddItem cell.Value
    ' .List(.ListCount - 1, 1) = cell.Offset(0, 1).Value
    ' .List(.ListCount - 1, 2) = cell.Offset(0, 2).Value
    ' .List(.ListCount - 1, 3) = cell.Offset(0, 3).Value
    ' .List(.ListCount - 1, 4) = cell.Offset(0, 4).Value
    ' .List(.ListCount - 1, 5) = cell.Offset(0, 5).Value
    ' .List(.ListCount - 1, 6) = cell.Offset(0, 6).Value
    ' .List(.ListCount - 1, 7) = cell.Offset(0, 7).Value
    '
    ' End With
    ' Next cell
    ' HookWheel Me, Me.Width, Me.Height, 3
    'End Sub
    > 3) if i used rowsource : sheet2!A2:G3000 nothing happened
    > 4) can any one suggest why?



    --
    regards
    ALEX

    "alex.simms" <> wrote in message
    news:%...
    > a)due to the way in which the length of line of text was created in the
    > original post the words" CALL BACK" appear on the wrong row and not as a
    > comment as i asume was the intention
    >>Public Sub UnHookWheel()
    > >'very important that this is called when the form is unloaded to remove

    > the
    >>"call back"
    >> Call SetWindowLong(hForm, GWL_WNDPROC, lPrevWndProc)
    >> End Sub

    > b)
    >>Private Sub cmdOK_Click()
    >>Application.Run "UnHookWheel" ' change 2nd line to Application.Run
    >>"UnHookWheel" the form will still be 'seen
    >>'Unload Me
    >>End Sub

    > c)having changed the form to a single listbox and running with a database
    > of 7 colums and some 3000 lines i was able to get the mouse scrolling to
    > work with no apparent problems other than.
    > 1) some times excel froze or took a long time to load
    > 2) the mouse scrolling only worked if the list boxwas filled by using
    > 'Private Sub UserForm_Initialize()
    > 'Dim i As Integer
    > ' fill ListBox1 with values
    > ' With Me.lst1
    > ' .Clear ' remove existing content
    > ' .ColumnCount = 8
    > ' .ColumnWidths = "20,50,130,100,100,100,100,100"
    > ' For i = 1 To 25
    > ' .AddItem ' add a new row
    > ' .List(i - 1, 0) = "Column1 Item " & i
    > ' .List(i - 1, 1) = "Column2 Item " & i
    > ' .List(i - 1, 2) = "Column3 Item " & i
    > ' .List(i - 1, 3) = "Column4 Item " & i
    > ' .List(i - 1, 4) = "Column5 Item " & i
    > ' .List(i - 1, 5) = "Column6 Item " & i
    > ' .List(i - 1, 6) = "Column7 Item " & i
    > ' .L'ist(i - 1, 7) = "Column8 Item " & i
    > ' .List(i - 1, 8) = "Column9 Item " & i
    > ' Next i
    > ' End With
    > ' HookWheel Me, Me.Width, Me.Height, 3
    >
    > 'End Sub
    > 3) if i used rowsource : sheet2!A2:G3000 nothing happened
    > 4) can any one suggest why?
    >
    > --
    > regards
    > ALEX
    >
    > "Robin Hammond" <> wrote in message
    > news:...
    >> Alex,
    >>
    >> Here's a cut at it using Windows call backs which is MUCH more complex
    >> than the Mabry ocx, but if they want to be difficult... I've updated my
    >> site to say that Mabry have discontinued the control as well. Thanks for
    >> the heads up on that.
    >>
    >> Anyway, it's fairly simple (NOT).
    >>
    >> There's an open invitation to anyone who wants to try and improve on
    >> this! I certainly haven't perfected it yet.
    >>
    >> PLEASE save your work and any data first before trying this. It is not
    >> fully tested and if the callback routine is left outstanding due to
    >> abnormal termination Excel can hang or weird things might happen.
    >> Debugging is also a touch difficult, since Windows wants to react to
    >> events but they are being trapped by the call back. I have only tried
    >> this in Excel XP and Win XP at present.
    >>
    >> And, this will only work in versions of Excel that can handle the
    >> AddressOf function. I can't remember when it was introduced offhand.
    >>
    >> HTH,
    >>
    >> Robin Hammond
    >> www.enhanceddatasystems.com
    >>
    >> 'CODE
    >> 'Create a userform, add 3 listboxes and a commandbutton. Name them to
    >> work with the code below. In your form code:
    >>
    >> Option Explicit
    >>
    >> Private Sub cmdOK_Click()
    >> Unload Me
    >> End Sub
    >>
    >> Private Sub UserForm_Initialize()
    >> Dim lCounter As Long
    >> For lCounter = 1 To 1000
    >> lst1.AddItem lCounter
    >> lst2.AddItem lCounter
    >> lst3.AddItem lCounter
    >> Next lCounter
    >> HookWheel Me, Me.Width, Me.Height, 3
    >> End Sub
    >>
    >> Private Sub UserForm_Terminate()
    >> 'THIS MUST BE CALLED OR WE HAVE A PROBLEM WITH THE CALLBACK
    >> UnHookWheel
    >> End Sub
    >>
    >> 'Create a Module mWheelHandler as follows:
    >>
    >> Option Explicit
    >> Option Private Module
    >>
    >> '************************************************************
    >> 'APIs
    >> '************************************************************
    >>
    >> Private Declare Function CallWindowProc Lib "user32.dll" 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 Declare Function SetWindowLong Lib "user32.dll" Alias _
    >> "SetWindowLongA" ( _
    >> ByVal hWnd As Long, _
    >> ByVal nIndex As Long, _
    >> ByVal dwNewLong As Long) As Long
    >>
    >> Private Declare Function FindWindowA Lib "user32" ( _
    >> ByVal lpClassName As String, _
    >> ByVal lpWindowName As String) As Long
    >>
    >> Private Declare Function GetSystemMetrics Lib "user32" _
    >> (ByVal nIndex As Long) As Long
    >>
    >> Private Declare Function GetWindowRect Lib "user32" ( _
    >> ByVal hWnd As Long, lpRect As typeRect) As Long
    >>
    >> 'used to store screen position for GetWindowRect call
    >> Private Type typeRect
    >> Left As Long
    >> Top As Long
    >> Right As Long
    >> Bottom As Long
    >> End Type
    >>
    >> 'screen factor constants
    >> Private dXFactor As Double 'hold screen Conversion coordinates
    >> Private dYFactor As Double
    >> Private lCaptionHeight As Long
    >>
    >> '************************************************************
    >> 'Constants
    >> '************************************************************
    >> Private Const GWL_WNDPROC = -4
    >> Private Const WM_MOUSEWHEEL = &H20A
    >> Private Const SM_MOUSEWHEELPRESENT = 75
    >>
    >> Private lLines As Long
    >>
    >> '************************************************************
    >> 'Variables
    >> '************************************************************
    >> Private hForm As Long
    >> Public lPrevWndProc As Long
    >> Private lX As Long
    >> Private lY As Long
    >> Private bUp As Boolean
    >> Private frmContainer As msForms.UserForm
    >>
    >> '*************************************************************
    >> 'WindowProc
    >> '*************************************************************
    >> Private Function WindowProc( _
    >> ByVal lWnd As Long, _
    >> ByVal lMsg As Long, _
    >> ByVal wParam As Long, _
    >> ByVal lParam As Long) As Long
    >>
    >> 'converted from code by Kevin Wilson on thevbzone
    >>
    >> 'Test if the message is WM_MOUSEWHEEL
    >> If lMsg = WM_MOUSEWHEEL Then
    >>
    >> lX = lParam And 65535
    >> lY = lParam \ 65535
    >> bUp = (wParam > 0)
    >> WheelHandler bUp
    >>
    >> End If
    >>
    >> 'Sends message to previous procedure if not MOUSEWHEEL
    >> 'This is VERY IMPORTANT!!!
    >> If lMsg <> WM_MOUSEWHEEL Then
    >>
    >> WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg, wParam,
    >> lParam)
    >>
    >> End If
    >>
    >> End Function
    >>
    >> Public Sub HookWheel(ByVal frmName As msForms.UserForm, dWidth As Double,
    >> _
    >> dHeight As Double, ByVal lLinesToScroll As Long)
    >>
    >> If WheelPresent Then
    >>
    >> Set frmContainer = frmName
    >> hForm = GetFormHandle(frmName)
    >> GetScreenFactors hForm, dWidth, dHeight
    >> lLines = lLinesToScroll
    >> 'create the call back procedure
    >> 'addressof doesn't work in earlier versions but not sure which ones
    >> lPrevWndProc = SetWindowLong(hForm, GWL_WNDPROC, AddressOf WindowProc)
    >>
    >> End If
    >>
    >> End Sub
    >>
    >> Public Sub UnHookWheel()
    >> 'very important that this is called when the form is unloaded to remove
    >> the call back
    >> Call SetWindowLong(hForm, GWL_WNDPROC, lPrevWndProc)
    >> End Sub
    >>
    >> Private Function GetFormHandle(ByVal frmName As msForms.UserForm, _
    >> Optional bByClass As Boolean = True) As Long
    >> 'returns a handle to the userform
    >> Dim strClassName As String
    >> Dim strCaption As String
    >>
    >> strClassName = IIf(Val(Application.Version) > 8, "ThunderDFrame", _
    >> "ThunderXFrame") & vbNullChar
    >> strCaption = vbNullString
    >> GetFormHandle = FindWindowA(strClassName, strCaption)
    >>
    >> End Function
    >>
    >> Public Sub GetScreenFactors(lHwnd As Long, _
    >> dWidth As Double, _
    >> dHeight As Double)
    >> 'returns screen factors for conversion to Excel units rather than win
    >> coords
    >> Dim uRect As typeRect
    >> GetWindowRect lHwnd, uRect
    >> dXFactor = dWidth / (uRect.Right - uRect.Left)
    >> dYFactor = dHeight / (uRect.Bottom - uRect.Top)
    >> lCaptionHeight = dHeight - frmContainer.InsideHeight
    >> End Sub
    >>
    >> Private Function WheelPresent() As Boolean
    >> 'function by Kevin Wilson from www.thevbzone.com
    >>
    >> ' Check for wheel mouse on Win98, WinNT 4.0, & Win2000
    >> If GetSystemMetrics(SM_MOUSEWHEELPRESENT) Then
    >>
    >> WheelPresent = True
    >>
    >> ' Check for wheel mouse on Win32's, Win95, & WinNT 3.5x
    >> ElseIf FindWindowA("MouseZ", "Magellan MSWHEEL") <> 0 Then
    >>
    >> WheelPresent = True
    >>
    >> End If
    >>
    >> End Function
    >>
    >> Sub WheelHandler(bUp As Boolean)
    >>
    >> Dim ctlFocus As msForms.Control
    >> Dim ctlName As msForms.Control
    >> Dim lTopIndex As Long
    >> Dim bMultiPage As Boolean
    >> Dim lPage As Long
    >> Dim lMove As Long
    >>
    >> If Not IsOverForm Then Exit Sub
    >> Set ctlFocus = frmContainer.ActiveControl
    >>
    >> 'if we are in a multipage then need to set the control
    >> 'to whatever the subcontrol is on the active page
    >>
    >> If TypeOf ctlFocus Is msForms.MultiPage Then
    >>
    >> 'set the multipage flag
    >> bMultiPage = True
    >>
    >> 'store the page number for the MP
    >> lPage = ctlFocus.Value
    >>
    >> 'set the focus control to the control on the current page
    >> Set ctlFocus = ctlFocus.SelectedItem.ActiveControl
    >>
    >> End If
    >>
    >> 'convert screen coords
    >> lX = lX * dXFactor
    >> lY = lY * dYFactor
    >> lY = lY - lCaptionHeight
    >>
    >> 'for anything but a commandbutton and textbox lx is relative to the left
    >> 'and top of the control, so adjust
    >> If Not (TypeOf ctlFocus Is msForms.CommandButton Or _
    >> TypeOf ctlFocus Is msForms.TextBox) Then
    >>
    >> 'lX = lX + ctlFocus.Left
    >> 'lY = lY + ctlFocus.Top
    >>
    >> End If
    >>
    >> 'loop controls, looking for list boxes
    >> For Each ctlName In frmContainer.Controls
    >>
    >> With ctlName
    >>
    >> If TypeOf ctlName Is msForms.ListBox Then
    >>
    >> 'if we are in a multipage
    >> If bMultiPage = True Then
    >>
    >> 'if we are not on the correct page then skip this control
    >> If lPage <> .Parent.Index Then GoTo SkipControl
    >>
    >> End If
    >>
    >> 'check right of left bound
    >> If lX > .Left Then
    >>
    >> 'check within width
    >> If lX < .Left + .Width Then
    >>
    >> 'check below top bound
    >> If lY > .Top Then
    >>
    >> 'check within height
    >> If lY < .Top + .Height Then
    >>
    >> 'WE FOUND THE RIGHT CONTROL SO HANDLE THE SCROLL
    >>
    >> 'if the list is empty there is nothing to
    >> scroll
    >> If .ListCount = 0 Then Exit Sub
    >>
    >> 'check scroll direction
    >> lMove = IIf(bUp, -lLines, lLines)
    >>
    >> 'get the new top index
    >> lTopIndex = .TopIndex + lMove
    >>
    >> 'check it is within valid limits
    >> If lTopIndex < 0 Then
    >>
    >> lTopIndex = 0
    >>
    >> ElseIf lTopIndex > .ListCount - (.Height / 10)
    >> + 2 Then
    >>
    >> lTopIndex = .TopIndex
    >>
    >> End If
    >>
    >> 'set the new top index
    >> .TopIndex = lTopIndex
    >>
    >> 'scroll has been handled so stop looping
    >> Exit Sub
    >>
    >> End If
    >>
    >> End If
    >>
    >> End If
    >>
    >> End If
    >>
    >> End If
    >>
    >> End With
    >>
    >> SkipControl:
    >> Next ctlName
    >>
    >> End Sub
    >>
    >> Public Function IsOverForm() As Boolean
    >> 'we can't get the form's coordinates directly when referenced as a form
    >> 'rather than ME within the form's code
    >> 'so call GetWindowRect again in case the form has been moved
    >> Dim uRect As typeRect
    >> GetWindowRect hForm, uRect
    >> With uRect
    >> If lX >= .Left Then
    >> If lX <= .Right Then
    >> If lY >= .Top Then
    >> If lY <= .Bottom Then
    >> IsOverForm = True
    >> lX = lX - .Left
    >> lY = lY - .Top
    >> End If
    >> End If
    >> End If
    >> End If
    >> End With
    >> End Function
    >>
    >> That's almost certainly the longest post I've ever made to this group.
    >> Any improvements suggested?
    >>
    >> Robin Hammond
    >> www.enhanceddatasystems.com
    >>
    >>
    >> "alex.simms" <> wrote in message
    >> news:OLQj$...
    >>> this was the reply I got from maybury
    >>>
    >>> We no longer sell the MouseWheel control.
    >>>
    >>> Sam Xavier
    >>> Mabry Software Technical Support
    >>>
    >>>
    >>> --
    >>> regards
    >>> ALEX
    >>>
    >>> "Robin Hammond" <> wrote in message
    >>> news:...
    >>>> Alex,
    >>>>
    >>>> Yes, but I use an activex control from Mabry to do it. The solution is
    >>>> here:
    >>>>
    >>>> http://www.enhanceddatasystems.com/ED/Pages/ExcelListScrolls.htm
    >>>>
    >>>> Robin Hammond
    >>>> www.enhanceddatasystems.com
    >>>>
    >>>> "alex.simms" <> wrote in message
    >>>> news:eESP8q$...
    >>>>> I've been re-searching the mouse, and no where can I find a pointer or
    >>>>> solution to scrolling with a mouse in a listbox on a form.
    >>>>> there are lots of pointer to "API" but not sure if this is suitable
    >>>>> for an excel form.
    >>>>> the question is,
    >>>>> is it possible to scroll within a listbox using
    >>>>> excel vba.
    >>>>> --
    >>>>> regards
    >>>>> ALEX
    >>>>>
    >>>>>
    >>>>
    >>>>
    >>>
    >>>

    >>
    >>

    >
    >
     
    alex.simms, Mar 20, 2005
    #6
    1. Advertisements

Want to reply to this thread or ask your own question?

It takes just 2 minutes to sign up (and it's free!). Just click the sign up button to choose a username and then you can ask your own questions on the forum.
Similar Threads
  1. Robert Stober

    Gurus: What's wrong with this code?

    Robert Stober, Sep 9, 2003, in forum: Microsoft Excel Programming
    Replies:
    3
    Views:
    230
    Tom Ogilvy
    Sep 10, 2003
  2. VanAlex

    Very specific invoice auto numbering for the gurus

    VanAlex, Nov 21, 2003, in forum: Microsoft Excel Programming
    Replies:
    1
    Views:
    224
    Dianne
    Nov 24, 2003
  3. harry
    Replies:
    8
    Views:
    404
    Dave Peterson
    Dec 20, 2003
  4. Joseph

    Calling lookup table gurus.

    Joseph, Feb 1, 2004, in forum: Microsoft Excel Programming
    Replies:
    2
    Views:
    225
    Joseph
    Feb 1, 2004
  5. joeshow

    Alarm Sound Function Not Working_Any DDE Gurus??

    joeshow, Mar 5, 2004, in forum: Microsoft Excel Programming
    Replies:
    13
    Views:
    321
    joeshow
    Mar 11, 2004
Loading...

Share This Page