[AccessD] record scroll

Thu May 22 00:15:34 CDT 2008

Replied off list with attached file: Here is the body of the solution.  The attached file can be created by yourself using the MS link in this email.  You need VB6 to do this.  I am going to upload this file and email content to my website tonight at: www.excelyourbusiness.com.au so others can use it.  It took me days and days to sort all this out and if I can save other the trouble than I am most happy.

John, if you have further questions feel free to contact me offlist.

cheers
Darryl

<copied email follows>

'-----

Hey John - To make the mouse wheel behave in Access as the user expects I had to do the following.  It took days of research to make this work as I could not access the registry or have any admin rights and IT techs wouldn't install the file automatically.  Don't freak out as more than half of this email is code used to ensure the DAO350.dll and Mousewheel.dll files are registered correctly. If you have admin rights then you can skip all that bit without bother.  NOTE!! You will have to change/check the directory paths in some of that code.

Anyway.. here is what you do.

PART ONE

1: MOUSE WHEEL SUPPORT
' ---------------------------------------------------------------------------------------------------------

Download and install Freewheel. It is free, non hostile, don't need to register and don't need admin rights to install. I have used on personal PC's and on multiple corporate networks for years without any hassles ever.  It will ensure the mouse wheel behaves as the user expects, although it does not prevent the skipping between records issue.

http://www.geocities.com/SiliconValley/2060/freewheel.html
Personally, this is the one I would recommend as it fixes the mouse wheel problem *everywhere* in all apps - it just works.

Microsoft also have a solution (at least for the VBE - not sure if it fixes all mouse wheel issues in other apps or not).
http://office.microsoft.com/en-us/help/HA101175901033.aspx
That you may wish to consider if you don't want to use freewheel, however you need admin rights and registry access to do this.

2: MouseWheel.dll
' ------------------------------------------------------------------------------------------------
"MouseWheel.dll" is used to capture the mouse wheel event and prevent the user from using the mouse wheel to jump between records.   

MouseWheel.dll source code and details are located here: http://support.microsoft.com/kb/278379.  I have already made this file and attached it for you to this email. I am providing the link in case there is some issue about using a dll file that you didn't make and it also give your instructions in case I foul this email up somewhere.

If you get this error http://support.microsoft.com/kb/292054 . The DAO350.dll and Mousewheel.dll file need to be registered.  You can normally do this via the START > RUN option (see the MS link for details) or you can workaround this by opening the VBE in MS Access, un-reference and then re-reference the MouseWheel.dll file manually and restart. However this is clearly not acceptable if you are not the end user. If you are like me and your corporate PC is locked down tighter than a snake bum and/or the above options are unavailable to you then I have code which will automatically register the dll files for you which I have posted at the bottom of this email.

In addition to the dll file you will need to do the following.

Create a regular code module in the VBE - Call it "basSubClassWindow" and copy and paste the following code into it.

' =========== START CODE =====================

Option Compare Database
Option Explicit

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
    (ByVal hwnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

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 Const GWL_WNDPROC = -4
Public Const WM_MouseWheel = &H20A
Public lpPrevWndProc As Long
Public CMouse As CMouseWheel

Public Function WindowProc(ByVal hwnd As Long, _
    ByVal uMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long

    'Look at the message passed to the window. If it is
    'a mouse wheel message, call the FireMouseWheel procedure
    'in the CMouseWheel class, which in turn raises the MouseWheel
    'event. If the Cancel argument in the form event procedure is
    'set to False, then we process the message normally, otherwise
    'we ignore it.  If the message is something other than the mouse
    'wheel, then process it normally
    Select Case uMsg
        Case WM_MouseWheel
            CMouse.FireMouseWheel
            If CMouse.MouseWheelCancel = False Then
                WindowProc = CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam, lParam)
            End If

        Case Else
           WindowProc = CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam, lParam)
    End Select
End Function

' =========== END CODE =====================

Now for each form you want to restrict the mouse wheel you need to add the following code in the FORM code module

' =========== START CODE =====================

Option Compare Database
Option Explicit

Private WithEvents clsMouseWheel As MouseWheel.CMouseWheel

Private Sub Form_Load()
    On Error GoTo Form_Load_Error

    Set clsMouseWheel = New MouseWheel.CMouseWheel
    Set clsMouseWheel.Form = Me
    clsMouseWheel.SubClassHookForm

   'On Error GoTo 0
   Exit Sub

Form_Load_Error:

    'MsgBox "Mouse Wheel Restrictor File Needs Attention, Please Contact PMO Group for Assistance", vbInformation, "Contact PMO Group..."
End Sub

Private Sub Form_Close()
   On Error GoTo Form_Close_Error

   clsMouseWheel.SubClassUnHookForm
   Set clsMouseWheel.Form = Nothing
   Set clsMouseWheel = Nothing

   'On Error GoTo 0
   Exit Sub

Form_Close_Error:

    'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Form_Close of VBA Document Form_frm_SubCurrentAchievments"
End Sub

Private Sub clsMouseWheel_MouseWheel(Cancel As Integer)
    MsgBox "You cannot use the mouse wheel to scroll records."
    Cancel = True
End Sub

' =========== END CODE =====================

PART TWO (only needed if you get the dreaded 429 Active X error)

That should work fine for you - However as I couldn't register the mousewheel.dll file the 'normal' way I kept getting "Active X 429 - Cannot create object" Error.  If you are getting this then apply the following fix.

IN CASE OF ACTIVE X 429 ERROR.
Create a normal code module and call it "Function_DaoReg" - then copy the following code

' =========== START CODE =====================

Option Compare Database
Option Explicit

'http://www.trigeminal.com/usenet/usenet026.asp
'http://www.trigeminal.com/code/RegisterDao.bas

Private Const HKEY_LOCAL_MACHINE = &H80000002
Public Const KEY_QUERY_VALUE = &H1
Public Const ERROR_SUCCESS = 0&
Public Const MAX_PATH = 260
Public Const S_OK = &H0

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long

Private Declare Function RegDaoDll Lib "dao360.dll" Alias "DllRegisterServer" () As Long

Private Const REGKEY As String = "SOFTWARE\Microsoft\Windows\CurrentVersion"
Private Const REGVAL As String = "CommonFilesDir"
Private Const DLLLOCATION As String = "\Microsoft Shared\DAO\dao360.dll"

Public Function DaoReg() As Boolean
Dim hKey As Long
Dim stName As String
Dim cb As Long
Dim hMod As Long
    ' First, find DAO. Ordinarily we could call the shell32/shfolder
    ' functions to find the location of the "Common Files" folder,
    ' but this will not work on Windows 95. So, go right to the
    ' registry to find:
    '   $(PROGRAM FILES)\$(COMMON FILES)\Microsoft Shared\DAO

    If (ERROR_SUCCESS = RegOpenKeyEx(HKEY_LOCAL_MACHINE, REGKEY, 0, KEY_QUERY_VALUE, hKey)) Then
        cb = MAX_PATH
        stName = String$(cb, vbNullChar)

        If (ERROR_SUCCESS = RegQueryValueEx(hKey, REGVAL, 0&, ByVal 0&, ByVal stName, cb)) Then
            ' Ok, now build the full DLL path
            stName = StFromSz(stName) & DLLLOCATION

            ' Load DAO so we can try to register it
            hMod = LoadLibrary(stName)
            If hMod Then
                ' Find out if the registration works
                DaoReg = (RegDaoDll() = S_OK)

                Call FreeLibrary(hMod)
            End If
        End If
        Call RegCloseKey(hKey)
    End If
End Function

'------------------------------------------------------------
'   StFromSz
'
'    Find the first vbNullChar in a string, and return
'    everything prior to that character. Extremely
'    useful when combined with the Windows API function calls.
'------------------------------------------------------------
Public Function StFromSz(ByVal sz As String) As String

    Dim ich As Integer

    ich = InStr(sz, vbNullChar)
    Select Case ich
        ' It's best to put the most likely case first.
        Case Is > 1
            ' Found in the string, so return the portion
            ' up to the null character.
            StFromSz = Left$(sz, ich - 1)
        Case 0
            ' Not found at all, so just
            ' return the original value.
            StFromSz = sz
        Case 1
            ' Found at the first position, so return an empty string.
            StFromSz = vbNullString
    End Select
End Function

' =========== END CODE =====================

Create another code module, call it "Function_RegisterMouseWheel" and add in the following code

' =========== START CODE =====================

Option Compare Database
Option Explicit

'http://www.trigeminal.com/usenet/usenet026.asp
'http://www.trigeminal.com/code/RegisterDao.bas

Private Const HKEY_LOCAL_MACHINE = &H80000002
Public Const KEY_QUERY_VALUE = &H1
Public Const ERROR_SUCCESS = 0&
Public Const MAX_PATH = 260
Public Const S_OK = &H0

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long

Private Declare Function RegDaoDll Lib "MouseWheel.dll" Alias "DllRegisterServer" () As Long

'\\dingo\grpdata\IT Project Status Reporting\Icons\MouseWheel.dll

Private Const REGKEY As String = "SOFTWARE\Microsoft\Windows\CurrentVersion"
Private Const REGVAL As String = "CommonFilesDir"
Private Const DLLLOCATION As String = "\\dingo\grpdata\IT Project Status Reporting\Icons\MouseWheel.dll"

Public Function DaoMouseWheel() As Boolean
Dim hKey As Long
Dim stName As String
Dim cb As Long
Dim hMod As Long
    ' First, find DAO. Ordinarily we could call the shell32/shfolder
    ' functions to find the location of the "Common Files" folder,
    ' but this will not work on Windows 95. So, go right to the
    ' registry to find:
    '   $(PROGRAM FILES)\$(COMMON FILES)\Microsoft Shared\DAO

    If (ERROR_SUCCESS = RegOpenKeyEx(HKEY_LOCAL_MACHINE, REGKEY, 0, KEY_QUERY_VALUE, hKey)) Then
        cb = MAX_PATH
        stName = String$(cb, vbNullChar)

        If (ERROR_SUCCESS = RegQueryValueEx(hKey, REGVAL, 0&, ByVal 0&, ByVal stName, cb)) Then
            ' Ok, now build the full DLL path
            stName = DLLLOCATION 'StFromSz(stName) &

            ' Load DAO so we can try to register it
            hMod = LoadLibrary(stName)
            If hMod Then
                ' Find out if the registration works
                DaoMouseWheel = (RegDaoDll() = S_OK)

                Call FreeLibrary(hMod)
            End If
        End If
        Call RegCloseKey(hKey)
    End If
End Function

'------------------------------------------------------------
'   StFromSz
'
'    Find the first vbNullChar in a string, and return
'    everything prior to that character. Extremely
'    useful when combined with the Windows API function calls.
'------------------------------------------------------------
Public Function StFromSz(ByVal sz As String) As String

    Dim ich As Integer

    ich = InStr(sz, vbNullChar)
    Select Case ich
        ' It's best to put the most likely case first.
        Case Is > 1
            ' Found in the string, so return the portion
            ' up to the null character.
            StFromSz = Left$(sz, ich - 1)
        Case 0
            ' Not found at all, so just
            ' return the original value.
            StFromSz = sz
        Case 1
            ' Found at the first position, so return an empty string.
            StFromSz = vbNullString
    End Select
End Function

' =========== END CODE =====================

Create a 3rd module, call it "CreateMouseWheelRef_" and add the following code

' =========== START CODE =====================
Option Compare Database
Option Explicit

Sub CreateMouseWheelReference()

Dim sPATH As String
Dim ref As Access.Reference

For Each ref In References
    If ref.IsBroken = True Then
        On Error Resume Next
        Access.References.Remove ref
    End If
Next ref

For Each ref In References
    If ref.name = "MouseWheel" Then
        If ref.IsBroken = True Then
            Access.References.Remove ref
        Else
            Exit Sub
        End If
    End If
Next ref

sPATH = "\\dingo\grpdata\IT Project Status Reporting\Icons\MouseWheel.dll"
'sPATH = "\\goanna\grpdata\PMO Team\DarrylCollins\Test Database\Icons\MouseWheel.dll"

If ReferenceFromFile(sPATH) = True Then
    MsgBox "Reference set successfully. Automatic Compile will take approx 30 seconds...", vbInformation, "Please Note:"
Else
    MsgBox "MouseWheel Reference not set successfully. - Please Contact PMO for Advice.", vbCritical, "Action Required!"
    'Application.Quit
End If

' Call a hidden SysCmd to automatically compile/save all modules.
Call SysCmd(504, 16483)

End Sub

' =========== END CODE =====================

Then in the MAIN MENU or Startup FORM when the database opens place the following code

' =========== START CODE =====================
Private Sub Form_Open(Cancel As Integer)

DoCmd.Maximize

Call DaoReg
Call DaoMouseWheel
Call CreateMouseWheelReference

' =========== END CODE =====================

-----Original Message-----
From: John Eget [mailto:joeget at vgernet.net]
Sent: Thursday, 22 May 2008 2:38 PM
To: Darryl Collins
Subject: Re: [AccessD] record scroll

YES IT IS!!!!!!!

This email and any attachments may contain privileged and confidential information and are intended for the named addressee only. If you have received this e-mail in error, please notify the sender and delete this e-mail immediately. Any confidentiality, privilege or copyright is not waived or lost because this e-mail has been sent to you in error. It is your responsibility to check this e-mail and any attachments for viruses.  No warranty is made that this material is free from computer virus or any other defect or error.  Any loss/damage incurred by using this material is not the sender's responsibility.  The sender's entire liability will be limited to resupplying the material.