这个窗体到底能否实现鼠标滚动功能

wkbu

在论坛上搜索了很久，没有答案，如何才能让鼠标滚轮起作用？
鼠标滚动功能.rar (11.58 KB, 下载次数: 227)

2010-12-22 20:08 上传

点击文件名下载附件

[ 本帖最后由 wkbu 于 2010-12-24 20:15 编辑 ]

lsftest

'不难.....
'模块1改为:
Option Explicit
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public 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
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = -4&
Public Const WM_MOUSEWHEEL = &H20A
Public OldWindowProc As Long
Public hwnd As Long
Public Function lsftest(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next
    If Msg = WM_MOUSEWHEEL Then
        
            If wParam = -7864320 Then
                UserForm1.Scroll fmScrollActionNoChange, fmScrollActionLineDown
            ElseIf wParam = 7864320 Then
                UserForm1.Scroll fmScrollActionNoChange, fmScrollActionLineUp
            End If

    Else
        lsftest = CallWindowProc(OldWindowProc, hwnd, Msg, wParam, lParam)
    End If
End Function
Sub Show()
UserForm1.Show
End Sub

lsftest

'再把UserForm_Initialize改为下面即可.
Private Sub UserForm_Initialize()
hwnd = FindWindow(vbNullString, "UserForm1")
OldWindowProc = GetWindowLong(hwnd, GWL_WNDPROC)
Call SetWindowLong(hwnd, GWL_WNDPROC, AddressOf lsftest)
UserForm1.Height = 500
UserForm1.ScrollHeight = 1500
End Sub

wkbu

感谢lsftest的回复，问题解决，如果滚动速度再快一些就更完美了! 再次感谢

lsftest

原帖由 wkbu 于 2010-12-24 22:07 发表
感谢lsftest的回复，问题解决，如果滚动速度再快一些就更完美了! 再次感谢
847906

'也不难,修改成下面的样子可实现3倍速滚动(这方法是不是有点混帐???呵呵....):
            If wParam = -7864320 Then
                UserForm1.Scroll fmScrollActionNoChange, fmScrollActionLineDown
                UserForm1.Scroll fmScrollActionNoChange, fmScrollActionLineDown
                UserForm1.Scroll fmScrollActionNoChange, fmScrollActionLineDown
            ElseIf wParam = 7864320 Then
                UserForm1.Scroll fmScrollActionNoChange, fmScrollActionLineUp
                UserForm1.Scroll fmScrollActionNoChange, fmScrollActionLineUp
                UserForm1.Scroll fmScrollActionNoChange, fmScrollActionLineUp
            End If

wkbu

如果20倍速，我可以再加一个for 循环了，哈哈，多谢指点，受益匪浅。

参照此功能，完成了我的“考试系统”制作，还请各位老师多提意见。
http://club.excelhome.net/thread-671218-1-1.html

[ 本帖最后由 wkbu 于 2011-1-14 21:48 编辑 ]

qczvba

API不错，学习了。谢了。

hanter007

有意思,收下了.

CLTZGS

收下，学习！谢谢！

dy_ysl

收藏了。。