467,074 Members | 939 Online
Bytes | Developer Community
Ask Question

Home New Posts Topics Members FAQ

Post your question to a community of 467,074 developers. It's quick & easy.

Mousewheel problem

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
  • viewed: 1597
Share:

This discussion thread is closed

Replies have been disabled for this discussion.

Similar topics

reply views Thread by Mark Johnson | last post: by
1 post views Thread by Marcel Sengers | last post: by
4 posts views Thread by tlemcenvisit | last post: by
3 posts views Thread by Dave K | last post: by
reply views Thread by WaterWalk | last post: by
1 post views Thread by =?Utf-8?B?UmljaA==?= | last post: by
By using this site, you agree to our Privacy Policy and Terms of Use.