hatena
hatena
2022/02/21 (月) 17:15:16
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対応に書き換える時間がなかなか取れなかったので回答が遅くなりました。
通報 ...