TopPicLogo TopPicText

Считывание и установка позиции скроллбаров у формы 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






Назад ToTop
L.E. 22.11.2012
Рейтинг@Mail.ru