Code:
Option Compare Database
Option Explicit
'Module : clsSyncScrollbars
'Created by : RMittelman@gmail.com
' Recreated from Stephen Lebans' code in GetSetScrollbars.mdb project,
' updated and simplified for 64-bit Access 2016
'
'Purpose : Gets / sets a form's vertical or horizontal scrollbar positions,
' or synchronizes 2 different SubForms' scrollbar positions.
'
'History : 6/25/2022 Initial release.
' 6/26/2022 Added ability to sync scrollbar positions between 2 scrollbars.
' 6/29/2022 Added clsTimer so this class can auto-sync without form timer.
' 12/14/2022 Removed clsTimer. Now uses a form timer to prevent crashing during debugging
'
'Notes : - Typically used for a continuous SubForm in a main form, but can be also used
' on main form without a SubForm.
' - For syncing scrollbars, requires having 2 SubForms on your form,
' each SubForm typically configured as continuous form.
' - Requires setting the MasterForm property of the class.
' - If syncing, also requires setting the SlaveForm property.
' - Requires modSyncScrollbars
' - Requires clsTimer, modTimer
'
' - Created as a class rather than a module, because there are no events triggered
' on Access Forms when scrollbar position is changed.
' - Requires clsTimer to periodically test if scrollbar positions changed.
'
'Usage : At top of form:
' Dim ss As clsSyncScrollbars
' Public masterForm As Form
' Public slaveForm As Form
'
' In Form_Close event:
' Set ss = Nothing
'
' In Form_Load event:
'
' ' so we don't have to continuously use the ".Form" property on subforms:
' Set masterForm = Me.SubformControl1.Form 'replace "SubformControl1" with actual name
' Set slaveForm = Me.SubformControl2.Form 'replace "SubformControl2" with actual name
'
' With ss
'
' ' initial setup
' Set .MasterForm = masterForm
' Set .SlaveForm = slaveForm
'
' ' for getting Scrollbar positions:
' ' (maybe put these in a button_click event?)
' Me.txtHoriz = .GetScrollbarPos(frm, sbtHorizontal)
' Me.txtVert = .GetScrollbarPos(frm, sbtVertical)
'
' ' for setting Scrollbar positions:
' ' (maybe put these in a button_click event?)
' .SetScrollbarPos frm, sbtHorizontal, Me.txtHoriz, newPosition
' .SetScrollbarPos frm, sbtVertical, Me.txtVert, newPosition
'
' ' for syncing Scrollbars:
' .SyncType = stHorizontal ' or stVertical or stBoth
' ' - optional, default is stNone.
' ' - if not stNone, requires both MasterForm & SlaveForm properties to be set.
' ' - stHorizontal, stVertical, stBoth set which scrollbars will be sync'd.
'
' ' to manually sync Scrollbars:
' isOK = .SyncScrollbars
'
' ' to Auto-Sync Scrollbars:
' .AutoSyncInterval = 250
' ' - timer interval in milliseconds for how often to sync
' ' - set to > 0 to start auto-syncing
' ' - set to 0 to stop auto-syncing
' ' - optional, defaults to 0
'
' End With
Public Enum ScrollBarTypeEnum
sbtHorizontal
sbtVertical
End Enum
Public Enum SyncTypeEnum
stNone
stHorizontal
stVertical
stBoth
End Enum
Public Enum SyncDirectionEnum
sdNone
sdFirstToSecond
sdSecondToFirst
End Enum
' Scroll Bar Constants
Private Const SB_CTL = 2
'Private Const SB_HORZ = 0
'Private Const SB_VERT = 1
' ScrollInfo fMask's
Private Const SIF_RANGE = &H1
Private Const SIF_PAGE = &H2
Private Const SIF_POS = &H4
Private Const SIF_DISABLENOSCROLL = &H8
Private Const SIF_TRACKPOS = &H10
Private Const SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS)
' windows message constants
Private Const WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114
Private Const GWL_STYLE = (-16)
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
' scrollbar commands
Private Const SB_THUMBPOSITION = 4
'Public WithEvents oTimer As clsTimer
Private WithEvents m_MasterForm As Form
Private m_SlaveForm As Form
'Private m_sourceForm As Form
'Private m_destForm As Form
Private m_syncDirection As SyncDirectionEnum
Private m_syncType As SyncTypeEnum
Private m_syncInterval As Long
Private oldHorizValue As Long
Private oldVertValue As Long
Private Type SCROLLINFO
cbSize As Long
fMask As Long
nMin As Long
nMax As Long
nPage As Long
nPos As Long
nTrackPos As Long
End Type
Private Declare PtrSafe Function GetScrollInfo Lib "user32" (ByVal hWnd As LongPtr, ByVal n As Long, lpScrollInfo As SCROLLINFO) As Long
'<Events>
Private Sub m_MasterForm_Timer()
SyncScrollbars
End Sub
'</Events>
'<Properties>
Public Property Get AutoSyncInterval() As Long
AutoSyncInterval = m_syncInterval
End Property
Public Property Let AutoSyncInterval(vData As Long)
' verify prerequisites
If m_MasterForm Is Nothing Then
MsgBox "You must first set the MasterForm property.", vbExclamation, "Error"
Exit Property
End If
If vData > 0 And m_SlaveForm Is Nothing Then
MsgBox "You must first set the SlaveForm property.", vbExclamation, "Error"
Exit Property
End If
If vData > 0 And m_syncType = stNone Then
MsgBox "You must first set SyncType property", vbExclamation, "Error"
Exit Property
End If
m_syncInterval = vData
With m_MasterForm
.OnTimer = "[Event Procedure]"
.TimerInterval = m_syncInterval
End With
End Property
Public Property Get SyncType() As SyncTypeEnum
SyncType = m_syncType
End Property
Public Property Let SyncType(vData As SyncTypeEnum)
If vData <> stNone Then
If m_MasterForm Is Nothing Then
MsgBox "You must first set the MasterForm property.", vbExclamation, "Error"
Exit Property
End If
If m_SlaveForm Is Nothing Then
MsgBox "You must first set the SlaveForm property.", vbExclamation, "Error"
Exit Property
End If
If vData <> stHorizontal And vData <> stVertical And vData <> stBoth Then
MsgBox "You must select either sdFirstToSecond, sdSecondToFirst, or asdBoth", vbExclamation, "Error"
Exit Property
End If
End If
m_syncType = vData
End Property
Public Property Get MasterForm() As Form
Set MasterForm = m_MasterForm
End Property
Public Property Set MasterForm(ByVal vData As Form)
Set m_MasterForm = vData
End Property
Public Property Get SlaveForm() As Form
Set SlaveForm = m_SlaveForm
End Property
Public Property Set SlaveForm(ByVal vData As Form)
Set m_SlaveForm = vData
End Property
'</Properties>
'<Public Methods>
Public Function GetScrollbarPos(frm As Form, scrollbarType As ScrollBarTypeEnum) As Long
Dim hWndSB As LongPtr
Dim retVal As Long
Dim sInfo As SCROLLINFO
GetScrollbarPos = 0
If Not frm Is Nothing Then
sInfo.fMask = SIF_ALL
sInfo.cbSize = Len(sInfo)
sInfo.nPos = 0
sInfo.nTrackPos = 0
' if scrollbar visible, get handle and continue
hWndSB = get_scrollbar_handle(frm, scrollbarType)
If hWndSB <> -1 Then
retVal = GetScrollInfo(hWndSB, SB_CTL, sInfo)
GetScrollbarPos = sInfo.nPos + 1
' Debug.Print "hWndSB:" & hWndSB & " nPos:" & sInfo.nPos & " nPage:" & sInfo.nPage & " nMax:" & sInfo.nMax
End If
End If
End Function
Public Function SetScrollbarPos(frm As Form, scrollbarType As ScrollBarTypeEnum, newPosition As Long) As Boolean ' LongPtr
Dim hWndForm As LongPtr
Dim hWndSB As LongPtr
Dim retVal As LongPtr
Dim thumb As LongPtr
Dim wMsg As Long
SetScrollbarPos = False
If Not frm Is Nothing Then
hWndForm = frm.hWnd
' if scrollbar visible, get handle and continue
hWndSB = get_scrollbar_handle(frm, scrollbarType)
If hWndSB <> -1 Then
wMsg = IIf(scrollbarType = sbtHorizontal, WM_HSCROLL, WM_VSCROLL)
thumb = make_dword(SB_THUMBPOSITION, CInt(newPosition - 1))
retVal = SendMessage(hWndForm, wMsg, ByVal thumb, ByVal hWndSB)
SetScrollbarPos = CBool(retVal) <> 0
End If
End If
End Function
Public Function SyncScrollbars() As Boolean
Dim scrollPos As Long
Dim sbType As ScrollBarTypeEnum
SyncScrollbars = False
' verify prerequisites
If m_MasterForm Is Nothing Then
MsgBox "You must first set the MasterForm property.", vbExclamation, "Error"
Exit Function
End If
If m_SlaveForm Is Nothing Then
MsgBox "You must first set the SlaveForm property.", vbExclamation, "Error"
Exit Function
End If
If m_syncType = stNone Then
MsgBox "You must first set SyncType property", vbExclamation, "Error"
Exit Function
End If
If m_syncType = stVertical Or m_syncType = stBoth Then
sbType = sbtVertical
scrollPos = GetScrollbarPos(m_MasterForm, sbType)
SyncScrollbars = SetScrollbarPos(m_SlaveForm, sbType, scrollPos)
End If
If m_syncType = stHorizontal Or m_syncType = stBoth Then
sbType = sbtHorizontal
scrollPos = GetScrollbarPos(m_MasterForm, sbType)
SyncScrollbars = SetScrollbarPos(m_SlaveForm, sbType, scrollPos)
End If
End Function
'</Public Methods>
'<Private Methods>
Private Function get_class_name(hWnd As LongPtr) As String
Const max_len As Long = 255
Dim sBuffer As String
Dim retLen As Long
get_class_name = ""
sBuffer = Space$(max_len)
retLen = GetClassName(hWnd, sBuffer, max_len)
If retLen > 0 Then get_class_name = Left$(sBuffer, retLen)
End Function
Private Function get_scrollbar_handle(frm As Form, scrollbarType As ScrollBarTypeEnum) As LongPtr
Const cls_name As String = "NUIScrollbar"
Dim hWndForm As LongPtr
Dim hWndSB As LongPtr
Dim sbStyle As LongPtr
Dim clsName As String
get_scrollbar_handle = -1
If Not frm Is Nothing Then
' get form's first child window
hWndForm = frm.hWnd
hWndSB = GetWindow(hWndForm, GW_CHILD)
' loop thru each child window looking for scrollbars
Do
clsName = get_class_name(hWndSB)
If clsName = cls_name Then
' scrollbar found, get style and verify it's the one we want
' (horiz = 137573172, vert = 137573173)
#If Win64 Then
sbStyle = GetWindowLongPtr(hWndSB, GWL_STYLE)
#Else 'added by isladogs
sbStyle = GetWindowLong(hWndSB, GWL_STYLE)
#End If
If (sbStyle And scrollbarType) = scrollbarType Then
get_scrollbar_handle = hWndSB
Exit Do
End If
End If
hWndSB = GetWindow(hWndSB, GW_HWNDNEXT)
Loop While hWndSB <> 0
End If
End Function
Private Function make_dword(loword As Integer, hiword As Integer) As Long
make_dword = (hiword * &H10000) Or (loword And &HFFFF&)
End Function
'</Private Methods>
Private Sub Class_Initialize()
m_syncType = sdNone
m_syncInterval = 0
End Sub
Private Sub Class_Terminate()
AutoSyncInterval = 0
Set m_MasterForm = Nothing
Set m_SlaveForm = Nothing
End Sub
Windows 10 
Access 2016
Reply With Quote
. Many thanks.
Originally Posted by RMittelman
