Scrollen in Kombinationsfeld

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Timo!
Beispielcode.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

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

Public 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

' **********************************************************************
' Modul: UserForm1 Typ: Userform
' **********************************************************************

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

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

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread