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

Автор: Андрей Митин http://am.rusimport.ru/MsAccess/topic.aspx?id=237

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

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

Private Declare Function GetClassName Lib "user32" _

Alias "GetClassNameA" (ByVal hWnd As Long, _

ByVal lpClassName As String, _

ByVal nMaxCount As Long) As Long

Private Declare Function GetWindow Lib "user32" _

(ByVal hWnd As Long, ByVal wCmd As Long) As Long

Private Declare Function GetWindowLong Lib "user32" _

Alias "GetWindowLongA" (ByVal hWnd As Long, _

ByVal nIndex As Long) As Long

Private Declare Function SendMessageLong& Lib "user32" _

Alias "SendMessageA" (ByVal hWnd&, _

ByVal message&, ByVal wParam&, lParam As Any)

Private Declare Function GetScrollPos Lib "user32" _

(ByVal hWnd As Long, ByVal nBar As Long) As Long

Private Declare Function SetScrollPos Lib "user32" _

(ByVal hWnd As Long, ByVal nBar As Long, _

ByVal nPos As Long, ByVal bRedraw As Long) As Long

'*********************************************************

'Назначение:получаем текущее расположение скролбара (если есть)

'Входы:

'Выходы:

'am v1.0.0_030222

'http://am.rusimport.ru

'mailto:a_mitin@mail.ru

'*********************************************************

Public Sub GetScrollBarPos(FormHWND As Long, _

ByRef VSB_Pos As Long, _

ByRef HSB_Pos As Long)

Dim hwndVSB As Long

Dim hwndHSB As Long

On Error GoTo Ex_

Dim s As String

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

'*********************************************************

'Назначение:устанавливаем расположение скролбара (если есть)

'Входы:'Если *_Pos < 0 - то не устанавливать этот параметр

'Выходы:

'am v1.0.0_030222

'http://am.rusimport.ru

'mailto:a_mitin@mail.ru

'*********************************************************

Public Sub SetScrollBarPos(FormHWND As Long, _

VSB_Pos As Long, _

HSB_Pos As Long)

Dim hwndVSB As Long

Dim hwndHSB As Long

On Error GoTo Err_

Dim s As String

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

'v_1.0.0 990630

Private Function StrZ(par As String) As String

Dim nSize As Long, i As Long, Rez As String

nSize = Len(par)

i = InStr(1, par, Chr(0)) - 1

If i > nSize Then i = nSize

If i < 0 Then i = nSize

StrZ = mID(par, 1, i)

End Function

'am 030222

Public Function wndClassName(hWnd As Long) As String

Dim s As String

Dim r&

s = String(128, " ")

r& = GetClassName(hWnd, s, 127)

wndClassName = StrZ(s)

End Function

'*********************************************************

'Назначение:получаем hwnd скролбара формы

'если они есть конечно

'Входы:SB_Type=1 - вертик. скроллбар, SB_Type=0 - горизонт. скроллбар

'Выходы:

'am v1.0.0_030222

'http://am.rusimport.ru

'mailto:a_mitin@mail.ru

'*********************************************************

Public Function GetSB_Hwnd(FormHWND As Long, SB_Type As Integer) As Long

Dim hwndChild As Long

Dim s As String

Dim style&

'находим всех детей формы - и ищем скроллбары

hwndChild = GetWindow(FormHWND, GW_CHILD)

If hwndChild = 0 Then

GetSB_Hwnd = 0

Else

Do

s = wndClassName(hwndChild)

If StrComp(s, "SCROLLBAR", 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