Microsoft Access 掲示板

縦スクロールバーをマウスでつかむときに表示される レコード:13/44 の値を取得したい / 10

19 コメント
views
4 フォロー
10

Windows API を使う方法です。

標準モジュールに下記のコードをコピーしてください。

Option Compare Database
Option Explicit

Declare PtrSafe Function GetScrollInfo Lib "user32" (ByVal hwnd As LongPtr, ByVal n As Long, lpScrollInfo As SCROLLINFO) As Long

#If Win64 Then
    Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
    Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#End If

Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr
Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Private Const GWL_STYLE = (-16)
' Window Style Flags
Private Const WS_VISIBLE = &H10000000
Private Const WS_VSCROLL = &H200000

' Scroll Bar Styles
Private Const SBS_HORZ = &H0&
Private Const SBS_VERT = &H1&
Private Const SBS_SIZEBOX = &H8&

' 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)

' Scroll Bar Constants
Private Const SB_HORZ = 0
Private Const SB_CTL = 2
Private Const SB_VERT = 1

' Windows Message Constant
Private Const WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114

' GetWindow() Constants
Private Const GW_HWNDNEXT = 2
'Private Const GW_HWNDPREV = 3
'Private Const GW_OWNER = 4
Private Const GW_CHILD = 5
'Private Const GW_MAX = 5

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

Public Function fGetScrollBarPos(frm As Form) As Long
    Dim lngret As Long
    Dim sInfo As SCROLLINFO
    
    sInfo.fMask = SIF_ALL
    sInfo.cbSize = Len(sInfo)
    sInfo.nPos = 0
    sInfo.nTrackPos = 0
    
    Dim hWndSB As LongPtr
    hWndSB = fIsScrollBar(frm)
    
    lngret = GetScrollInfo(hWndSB, SB_CTL, sInfo)
    fGetScrollBarPos = sInfo.nPos + 1
End Function

Public Function fIsScrollBar(frm As Form) As LongPtr
    Dim hWnd_VSB As LongPtr
    Dim hwnd As LongPtr
    hwnd = frm.hwnd
    hWnd_VSB = GetWindow(hwnd, GW_CHILD)
                
    Do
        Select Case fGetClassName(hWnd_VSB)
        Case "scrollBar", "NUIScrollBar"
            If GetWindowLongPtr(hWnd_VSB, GWL_STYLE) And SBS_VERT Then
                fIsScrollBar = hWnd_VSB
                Exit Function
            End If
        End Select
        hWnd_VSB = GetWindow(hWnd_VSB, GW_HWNDNEXT)
    Loop While hWnd_VSB <> 0
    
    fIsScrollBar = -1
End Function

Private Function fGetClassName(hwnd As LongPtr)
    Dim strBuffer As String
    Dim lngLen As Long
    Const MAX_LEN = 255
    strBuffer = Space$(MAX_LEN)
    lngLen = GetClassName(hwnd, strBuffer, MAX_LEN)
    If lngLen > 0 Then fGetClassName = Left$(strBuffer, lngLen)
End Function

フォーム上にコマンドボタンを配置して、下記で表示されるようです。

Private Sub コマンド1_Click()
    MsgBox "レコード: " & fGetScrollBarPos(Me) & "/" & Me.Recordset.RecordCount
End Sub

Office2019 64bit で動作確認。

64bit対応に書き換える時間がなかなか取れなかったので回答が遅くなりました。

通報 ...