AW: du hast recht.... dann kann nur Nepumuk helfe
10.05.2005 21:10:30
Reinhard
Hi Christoph,
hier sind noch 6 Links,
http://groups.google.de/groups?c2coff=1&q=%22Sub+MouseWheel%22&qt_s=Suche
den ersten musste man erst neu formatieren, vielleicht gng da was schief, jetzenfalls hänge ich an Synaxfehler in zeile:
Public Sub Hook(ByVal hControl As Long)
fest.
Gruß
Reinhard
UserForm1:
Private Sub UserForm_Activate()
Dim hwnd As Long
hwnd = hwndFenetreForm(Me.Caption)
If hwnd <> 0 Then Hook hwnd
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnHook
End Sub
Public Sub Controle_ActualiseWheel(Control As MSForms.Control, ByVal sens As Integer)
If sens = -1 Then
If UserForm1.ScrollBar1 - UserForm1.ScrollBar1.SmallChange > UserForm1.ScrollBar1.Min Then UserForm1.ScrollBar1 = UserForm1.ScrollBar1 - UserForm1.ScrollBar1.SmallChange
Else
UserForm1.ScrollBar1 = UserForm1.ScrollBar1.Min
End If
Else
If UserForm1.ScrollBar1 + UserForm1.ScrollBar1.SmallChange < UserForm1.ScrollBar1.Max Then UserForm1.ScrollBar1 = UserForm1.ScrollBar1 + UserForm1.ScrollBar1.SmallChange
Else
UserForm1.ScrollBar1 = UserForm1.ScrollBar1.Max
End If
End If
End Sub
'Modul1:
'Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
'Private Declare Function CallWindowProc Lib "" ()
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
Public Const MK_CONTROL = &H8
Public Const MK_LBUTTON = &H1
Public Const MK_RBUTTON = &H2
Public Const MK_MBUTTON = &H10
Public Const MK_SHIFT = &H4
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Private hControl As Long
Private lPrevWndProc As Long
'appelée quand l'événement mousewheel est déclenché
Private Sub MouseWheel(ByVal fwKeys As Long, _
ByVal zDelta As Long, _
ByVal xPos As Long, _
ByVal yPos As Long)
Dim sens As Integer
If UserForm1.ActiveControl.Name <> "ScrollBar1" Then
Exit Sub
If zDelta < 0 Then sens = 1 Else sens = -1
UserForm1.Controle_ActualiseWheel
UserForm1.ActiveControl , sens
End Sub
Private Function WindowProc(ByVal lWnd As Long, _
ByVal lMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim fwKeys As Long
Dim zDelta As Long, xPos As Long, yPos As Long
If lMsg = WM_MOUSEWHEEL Then
fwKeys = wParam And 65535
zDelta = wParam / 65536
xPos = lParam And 65535
yPos = lParam / 65536
MouseWheel fwKeys, zDelta, xPos, yPos
End If
WindowProc = CallWindowProc(lPrevWndProc, lWnd, lMsg, wParam, lParam)
End Function
'Hook
Public Sub Hook(ByVal hControl As Long)
lPrevWndProc = SetWindowLong(hControl, GWL_WNDPROC, AddressOfWindowProc)
End Sub
'UnHook
Public Sub UnHook()
Call SetWindowLong(hControl, GWL_WNDPROC, lPrevWndProc)
End Sub
Function DCFenetreForm(CaptionFenetre As String) As Long
Dim hwnd As Long
'renvoie le hdc d'un UserForm (mais pas d'un contrôle)
hwnd = FindWindow(vbNullString, Me.Caption)
'hwnd = FindWindow(vbNullString, CaptionFenetre)
DCFenetreForm = GetDC(hwnd)
End Function
Function hwndFenetreForm(CaptionFenetre As String) As Long
hwndFenetreForm = FindWindow(vbNullString, CaptionFenetre)
End Function
Function HwndFenetreXL() As Long
HwndFenetreXL = FindWindow("XLMAIN", Application.Caption)
End Function
wort, "*") + 1))
End Function