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
