Option Compare Database
Option Explicit
 
' == IM MODUL ================
Public lpPrevWndProc As Long
Public Const GWL_WNDPROC = (-4)
 
' Window-Messages
Public Const WM_MOUSEWHEEL = &H20A
 
' == API's =============================
Public Declare Function SetWindowLong Lib "user32" _
               Alias "SetWindowLongA" _
              (ByVal hWnd&, _
               ByVal nIndex&, _
               ByVal dwNewLong&) As Long
 
Public Declare Function CallWindowProc Lib "user32" _
               Alias "CallWindowProcA" _
              (ByVal lpPrevWndFunc&, _
               ByVal hWnd&, _
               ByVal Msg&, _
               ByVal wParam&, _
               ByVal lParam&) As Long
 
 
' == FUNCTIONS ========================
Public Function SubWindowProc(ByVal hWnd&, ByVal uMsg&, _
                              ByVal wP&, ByVal lP&) As Long
' Fensterfunktion des Formulars / Controls
 
    On Error Resume Next
 
    ' Messages hier bearbeiten
    If uMsg = WM_MOUSEWHEEL Then
        ' nichts zu tun hier
        SubWindowProc = 1
        Exit Function
    End If
 
    'return to the message original proc
    SubWindowProc = CallWindowProc(lpPrevWndProc, hWnd, uMsg, wP, lP)
 
End Function
 
Public Sub HookMe(hw&)
' Subclass by the given handle
' Aufruf zb aus Form_Load() mit
' Call HookMe(Me.hwnd)
 
    lpPrevWndProc = SetWindowLong(hw&, GWL_WNDPROC, _
                                  AddrOf("SubWindowProc"))
 
End Sub
 
Public Sub UnHookMe(hw&)
' Unhook the given handle
' Aufruf zb aus Form_UnLoad() mit
' Call UnHookMe(Me.hwnd)
    If lpPrevWndProc& <> 0 Then: Call SetWindowLong(hw&, _
                                      GWL_WNDPROC, lpPrevWndProc&)
    lpPrevWndProc = 0
End Sub

Option Compare Database
Option Explicit
 
Private Declare Function GetCurrentVbaProject Lib "vba332.dll" _
                Alias "EbGetExecutingProj" (hProject&) As Long
 
Private Declare Function GetFuncID Lib "vba332.dll" _
                Alias "TipGetFunctionId" _
               (ByVal hProject&, _
                ByVal strFunctionName$, _
                ByRef strFunctionId$) As Long
 
Private Declare Function GetAddr Lib "vba332.dll" _
                Alias "TipGetLpfnOfFunctionId" _
               (ByVal hProject&, _
                ByVal strFunctionId$, _
                ByRef lpfn&) As Long
 
' ==< FUNCTIONS > =========================================
Public Function AddrOf&(strFuncName$)
' gibt den Funktionszeiger einer public VBA Funktion zurück
' Parameter: strFuncName ... Funktionsname
' Return: >0 Adresse, 0 Fehler
' Aufruf zb lFuncPtr& = AddrOf("MyPublicFunc")
     Dim hProject&, lResult&, lpfn&
     Dim strID$, strFuncNameUnicode$
 
     Const NO_ERROR = 0
     AddrOf = 0
 
     ' Konvert strFuncName Unicode
     strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
 
     ' Handle des VBA - Moduls holen
     Call GetCurrentVbaProject(hProject)
 
     If hProject <> 0 Then
         ' FunktionsID der VBA-Funktion ermitteln
         lResult = GetFuncID(hProject, strFuncNameUnicode, strID)
         If lResult = NO_ERROR Then
              ' Adresse des FunktionsID holen
              lResult = GetAddr(hProject, strID, lpfn)
              If lResult = NO_ERROR Then: AddrOf = lpfn
         End If
     End If
 
End Function

Private Sub Form_Load()
    'Subclassing auf Formular anwenden
    Call HookMe(Me.hWnd)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'Subclassing auf Formular anwenden
    Call UnHookMe(Me.hWnd)
End Sub