Считывание и установка позиции скроллбаров у формы Access (+ пример)

По материалам: http://am.rusimport.ru/MsAccess/topic.aspx?id=237

Описание:
    С помощью функций данного модуля можно получить информацию о том, есть ли в данный момент у формы полосы прокрутки и если есть - считать (и при желании установить) текущее местоположение ползунка.

    Данный модуль также может просто рассматриваться как пример работы с окнами на форме MS Access - например здесь можно посмотреть как найти интересующее Вас окно на форме (если конечно оно существует ;))

Пример эксплуатации в форме:

Private Sub Button2_Click()
Dim v As Long, h As Long
Dim lHWnd As Long
    lHWnd = Me.hWnd
    Me.Painting = False
    GetScrollBarPos lHWnd, v, h 'Запоминаем
    If IsNull(Me.TextBox2) Then
        Me.TextBox2 = "Сurrent ScrollPos: v = " & v & ", h = " & h
    Else
        Me.TextBox2 = Me.TextBox2 & vbNewLine & "Сurrent ScrollPos: v = " & v & ", h = " & h
    End If
    Me.Requery 'Обновляем
    SetScrollBarPos lHWnd, v, h 'Восстанавлмваем
    Me.Painting = True
End Sub

Модуль:

'---------------------------------------------------------------------------------------------------
' Name      : modFormsScrollBarPosition_API
' Kind      : Module
' Purpose   : Считывание и установка позиции скроллбаров у (ленточной) формы Access после её обновления
' Author 00 : am (aka Андрей Митин) 02.09.2013
'           : mailto: a_mitin@ mail.ru
' Author 02 : es (совсем чуток подправил + малость адаптировал для MSO x64)
' Date LE   : 20.10.2019 - 11.07.2001  v004
' Link 00   : http://am.rusimport.ru/MsAccess/topic.aspx?ID=237
'---------------------------------------------------------------------------------------------------
'GetScrollBarPosV

Option Compare Database
Option Explicit

Private Const WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Const GWL_STYLE = (-16)
Private Const SBS_HORZ = &H0&
Private Const SBS_VERT = &H1&
Private Const SBS_SIZEBOX = &H8&
Private Const SB_CTL = 2
Private Const SB_THUMBPOSITION = 4
'---------------------------------------------------------------------------------------------------
Public Declare PtrSafe Function GetClassName Lib "User32" Alias "GetClassNameA" _
    (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As Long
Public Declare PtrSafe Function GetWindow Lib "User32" _
    (ByVal hWnd As LongPtr, ByVal wCmd As Long) As Long

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongPtrA" _
            (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" _
            (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #End If
#Else
    Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" _
        (ByVal hWnd As Long, ByVal nIndex As Long) As Long
#End If

Private Declare PtrSafe Function SendMessageLong& Lib "User32" Alias "SendMessageA" _
    (ByVal hWnd&, ByVal message&, ByVal wParam&, lParam As Any)

Private Declare PtrSafe Function GetScrollPos Lib "User32" (ByVal hWnd As LongPtr, ByVal nBar As Long) As Long
'Не используется пока
'Private Declare PtrSafe Function SetScrollPos Lib "User32" _
    (ByVal hWnd As Long, ByVal nBar As Long, ByVal nPos As Long, ByVal bRedraw As Long) As LongPtr

Private Function GetSB_Hwnd(FormHWND As Long, SB_Type As Integer) As Long
'Получаем hwnd скролбара формы если они есть конечно
'SB_Type=1 = вертик. скроллбар, SB_Type=0 + горизонт. скроллбар
'---------------------------------------------------------------------------------------------------
Dim hwndChild As Long
Dim sVal As String
Dim Style As LongPtr '&
Dim iAccessVer%, sSubWindowName$

    iAccessVer = CInt(Mid(Application.Version, 1, 2))
    
    'Для 2010 акцесса строку надо заменить ... "NUIScrollbar" = Done!  :)
    If iAccessVer < 14 Then 'Для MSO 2007 и ниже
        sSubWindowName = "SCROLLBAR"
    Else                    'Для MSO 2010 и выше
        sSubWindowName = "NUIScrollbar" 'Для 2010 акцесса и выше
    End If
    
    'Находим всех детей формы - и ищем скроллбары
    hwndChild = GetWindow(FormHWND, GW_CHILD)
    If hwndChild = 0 Then
        GetSB_Hwnd = 0
    Else
        Do
            sVal = wndClassName(hwndChild)
            
            If StrComp(sVal, sSubWindowName, vbTextCompare) = 0 Then
                'это скролбар - проверим тип
                Style = GetWindowLong(hwndChild, GWL_STYLE)
                If (Style And SBS_SIZEBOX) = False And (Style And &H1) = SBS_HORZ Then
                    'горизонтальный
                    If SB_Type = 0 Then
                        'нашли
                        GetSB_Hwnd = hwndChild ' GetScrollPos(hwndChild, SB_CTL)
                        Exit Function
                    End If
                End If
                If (Style And &H1) = SBS_VERT Then
                    'вертикильный
                    If SB_Type = 1 Then
                        'нашли
                        GetSB_Hwnd = hwndChild 'GetScrollPos(hwndChild, SB_CTL)
                        Exit Function
                    End If
                End If
            End If
            hwndChild = GetWindow(hwndChild, GW_HWNDNEXT)
        Loop While hwndChild <> 0
    End If
End Function

Public Sub GetScrollBarPos(FormHWND&, ByRef VSB_Pos&, ByRef HSB_Pos&)
'Получаем текущее расположение скролбара (если есть)
'---------------------------------------------------------------------------------------------------

Dim hwndVSB As Long
Dim hwndHSB As Long
On Error GoTo Ex_
    hwndHSB = GetSB_Hwnd(FormHWND, SBS_HORZ)
    hwndVSB = GetSB_Hwnd(FormHWND, SBS_VERT)
    If hwndHSB = 0 Then
        HSB_Pos = 0
    Else
        HSB_Pos = GetScrollPos(hwndHSB, SB_CTL)
    End If
    If hwndVSB = 0 Then
        VSB_Pos = 0
    Else
        VSB_Pos = GetScrollPos(hwndVSB, SB_CTL)
    End If
Ex_:
    Exit Sub
Err_:
    MsgBox Err.Description
    Resume Ex_
End Sub

Public Function GetScrollBarPosV(FormHWND&) As Long
'Получаем текущее расположение вертикального скролбара (если есть)
'---------------------------------------------------------------------------------------------------
Dim hwndVSB As Long
On Error GoTo Ex_
    hwndVSB = GetSB_Hwnd(FormHWND, SBS_VERT)
    If hwndVSB = 0 Then
        GetScrollBarPosV = 0
    Else
        GetScrollBarPosV = GetScrollPos(hwndVSB, SB_CTL)
    End If
Ex_:
    Exit Function
Err_:
    MsgBox Err.Description
    Resume Ex_
End Function

Public Sub SetScrollBarPos(FormHWND As Long, VSB_Pos As Long, HSB_Pos As Long)
'Устанавливаем расположение скролбара (если есть)
'Если *_Pos < 0 - то не устанавливать этот параметр
'---------------------------------------------------------------------------------------------------
Dim hwndVSB As Long
Dim hwndHSB As Long
On Error GoTo Err_
    hwndHSB = GetSB_Hwnd(FormHWND, SBS_HORZ)
    hwndVSB = GetSB_Hwnd(FormHWND, SBS_VERT)
    If hwndHSB <> 0 And HSB_Pos >= 0 Then
        'это можно и не делать было бы
        'SetScrollPos hwndHSB, SB_CTL, HSB_Pos, 1
        Call SendMessageLong&(FormHWND, WM_HSCROLL, (HSB_Pos * 2 ^ 16) Or SB_THUMBPOSITION, 0)
    End If
    If hwndVSB <> 0 And VSB_Pos >= 0 Then
        'это можно и не делать было бы
        'SetScrollPos hwndVSB, SB_CTL, VSB_Pos, 1
        Call SendMessageLong&(FormHWND, WM_VSCROLL, (VSB_Pos * 2 ^ 16) Or SB_THUMBPOSITION, 0)
    End If
Ex_:
    Exit Sub
Err_:
    MsgBox Err.Description
    Resume Ex_
End Sub

Private Function StrZ(par As String) As String
Dim nSize As Long, iVal As Long
   nSize = Len(par)
   iVal = InStr(1, par, Chr(0)) - 1
   If iVal > nSize Then iVal = nSize
   If iVal < 0 Then iVal = nSize
   StrZ = Mid(par, 1, iVal)
End Function

Private Function wndClassName(hWnd As Long) As String
Dim sVal As String
Dim lVal&
    sVal = String(128, " ")
    lVal = GetClassName(hWnd, sVal, 127)
    wndClassName = StrZ(sVal)
End Function

MSA-2000 + MSA-2007 ( 84 kB) Пример