By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
424,475 Members | 1,372 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 424,475 IT Pros & Developers. It's quick & easy.

Mousewheel problem

P: n/a
Seems the mousewheel isn't controlled in earlier versions like A97 or
2000. So you can accidentally use the mousewheel to scroll to the next
record in an unbound form. And that can cause Access to hang-up, with
an unbound form.

I had this little popup box that was an alternative to editing text in
a memo field. And every now and then I'd forget about the mousewheel
problem and just habitually scrool as if editing in U-edit or
something. And crash. I'd have to ctrl-alt-delete to get rid of
Access, and try again.

I came across this code, below. But I don't know where it came from.
It works well enough. I see other solutions that require an external
dll. This doesn't. But if you don't 'unhook', or rather try to
double-hook, it can make your Access disappear real fast (just closes
it right up). But this below doesn't do that. But I just wonder who
came up with it:
basMouseWheel :

Public Const GWL_WNDPROC = -4
Public boolHooked As Boolean
Public lpPrevWndProc As Long
Public gHW As Long
Public Sub Hook()

If Not boolHooked Then lpPrevWndProc = SetWindowLong(gHW,
GWL_WNDPROC, AddrOf("WindowProc"))
boolHooked = True

End Sub

Public Sub Unhook()
Dim lngDum As Long

lngDum = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
boolHooked = False

End Sub

Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam
As Long, ByVal lParam As Long) As Long

If uMsg = GetMouseWheelMsg Then
WindowProc = 0
Else
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam,
lParam)
End If

End Function
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long, lngResult As Long, lpfn As Long
Dim strID As String, strFuncNameUnicode As String
Const NO_ERROR = 0

strFuncNameUnicode = StrConv(strFuncName, vbUnicode)

Call GetCurrentVbaProject(hProject)
If hProject <> 0 Then
lngResult = GetFuncID(hProject, strFuncNameUnicode, strID)

If lngResult = NO_ERROR Then
lngResult = GetAddrByID(hProject, strID, lpfn)
If lngResult = NO_ERROR Then AddrOf = lpfn

End If
End If

End Function
Public Function GetMouseWheelMsg() As Long

' 522 for 98 and 2K, otherwise use:
RegisterWindowMessageA("MSWHEEL_ROLLMSG")
GetMouseWheelMsg = 522

End Function

basWinAPI :

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 RegisterWindowMessageA Lib "user32" _
(ByVal lpString As String)

Public Declare Function GetCurrentVbaProject Lib "vba332.dll" Alias
"EbGetExecutingProj" _
(hProject As Long) As Long

Public Declare Function GetFuncID Lib "vba332.dll" Alias
"TipGetFunctionId" _
(ByVal hProject As Long, _
ByVal strFunctionName As String, _
ByRef strFunctionId As String) As Long

Public Declare Function GetAddrByID Lib "vba332.dll" Alias
"TipGetLpfnOfFunctionId" _
(ByVal hProject As Long, _
ByVal strFunctionId As String, _
ByRef lpfn 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


And in the class module of the form calling this:

Public Sub Form_Load()
gHW = Me.hwnd
Hook
End Sub
Private Sub Form_Unload(Cancel As Integer)
Unhook
End Sub
Nov 13 '05 #1
Share this question for a faster answer!
Share on Google+

This discussion thread is closed

Replies have been disabled for this discussion.