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