Option Compare Database
Option Explicit
'''http://www.arkmicrosystems.com/Articles_MSAccess/0022-How%20to%20use%20mouse%20wheel%20scrolling%20in%20MS%20Access.php
Private Const modename = "Scrolltextbox"
Public Const WM_VSCROLL = &H115
Public Const WM_HSCROLL = &H114
Public Const SB_LINEUP = 0
Public Const SB_LINEDOWN = 1
Public Const SB_PAGEUP = 2
Public Const SB_PAGEDOWN = 3
#If VBA7 Then
' Code is running in the new VBA7 editor
#If Win64 Then
'Code is running in 64-bit version of Microsoft Office
Private Declare PtrSafe Function focus Lib "User32" Alias "GetFocus" () As LongPtr
Public Declare PtrSafe Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As LongPtr
#Else
'Code is running in 32-bit version of Microsoft Office
Private Declare Function focus Lib "User32" Alias "GetFocus" () As Long
Public Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
#End If
#Else
'Code is running in VBA version 6 or earlier
Private Declare Function focus Lib "User32" Alias "GetFocus" () As Long
Public Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
#End If
'Private Declare Function focus Lib "User32" Alias "GetFocus" () As Long
'Public Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
#If VBA7 Then
' Code is running in the new VBA7 editor
#If Win64 Then
'Code is running in 64-bit version of Microsoft Office
Public Function funx(ctl As control) As LongPtr
On Error Resume Next
'ctl.SetFocus
If err Then
funx = 0
Else
funx = focus
End If
On Error GoTo 0
End Function
#Else
'Code is running in 32-bit version of Microsoft Office
Public Function funx(ctl As control) As Long
On Error Resume Next
'ctl.SetFocus
If err Then
funx = 0
Else
funx = focus
End If
On Error GoTo 0
End Function
#End If
#Else
'Code is running in VBA version 6 or earlier
Public Function funx(ctl As control) As Long
On Error Resume Next
'ctl.SetFocus
If err Then
funx = 0
Else
funx = focus
End If
On Error GoTo 0
End Function
#End If
Public Sub Scroll(frm As Form, Count As Long)
On Error GoTo err
Dim LinesToScroll As Integer
'Dim hwndActCtl As LongPtr
#If VBA7 Then
'Code is running in the new VBA7 editor
#If Win64 Then
'Code is running in 64-bit version of Microsoft Office
Dim hwndActCtl As LongPtr
#Else
'Code is running in 32-bit version of Microsoft Office
Dim hwndActCtl As Long
#End If
#Else
'Code is running in VBA version 6 or earlier
Dim hwndActCtl As Long
#End If
Dim a As Long
If frm.ActiveControl.Properties.Item("controltype") = acTextBox Then
If frm.ActiveControl.Properties("enterkeybehavior") = True Or frm.ActiveControl.Properties("tag") Like "*scroll*" Then
hwndActCtl = funx(Screen.ActiveControl)
For a = 1 To Abs(Count)
SendMessage hwndActCtl, WM_VSCROLL, IIf(Count < 0, SB_LINEUP, SB_LINEDOWN), 0&
Next
End If
End If
Exit Sub
err:
If err.Number = 2474 Then Exit Sub 'the expression you entered requires the control to be in the active window
Debug.Print "Error in scroll sub: " & err.Description
End Sub