В проекте использую форму со скролбаром. Код взял на просторах инета давно, уже не помню где. Код этот для меня – дремучий лес, как для первоклашки - интегралы. Мне над, чтоб 1 фрейм с несколькими контролами в нём при скроллинге оставался на месте, остальные контролы должны нормально скроллироваться . Подскажите пожалуйста, как мне это реализовать? Спасибо!
- Код: Выделить всё
Option Explicit
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
Private Declare Function SetScrollInfo Lib "user32" (ByVal hWnd As Long, ByVal n As Long, lpcScrollInfo As SCROLLINFO, ByVal bool As Boolean) As Long
Private Declare Function GetScrollInfo Lib "user32" (ByVal hWnd As Long, ByVal n As Long, lpScrollInfo As SCROLLINFO) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function ScrollWindowByNum Lib "user32" Alias "ScrollWindow" (ByVal hWnd As Long, ByVal XAmount As Long, ByVal YAmount As Long, ByVal lpRect As Long, ByVal lpClipRect As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const GWL_WNDPROC = (-4)
Private Const WS_VSCROLL = &H200000
Private Const WS_HSCROLL = &H100000
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOSIZE = &H1
Private Const SB_HORZ = 0
Private Const SB_VERT = 1
Private Const SB_BOTH = 3
Private Const SB_LINEDOWN = 1
Private Const SB_LINEUP = 0
Private Const SB_PAGEDOWN = 3
Private Const SB_PAGEUP = 2
Private Const SB_THUMBTRACK = 5
Private Const WM_HSCROLL = &H114
Private Const WM_VSCROLL = &H115
Private Const WM_DESTROY = &H2
Private Const SIF_ALL = &H17
Dim s As SCROLLINFO, OldProc As Long, hObj As Long
Public Sub SetScrollBar(objTarget As Object, sbPos As ScrollBarConstants)
Dim lStyle As Long
If hObj <> 0 Then Exit Sub
On Error Resume Next
hObj = objTarget.hWnd
If Err Then
MsgBox "Can not set scrollbars on this object!", vbCritical
Exit Sub
End If
On Error GoTo 0
lStyle = sbPos * &H100000
SetWindowLong hObj, GWL_STYLE, GetWindowLong(hObj, GWL_STYLE) Or lStyle
SetWindowPos hObj, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOSIZE
s.cbSize = Len(s)
s.fMask = SIF_ALL
s.nMin = 0
s.nPos = 0
If (sbPos And vbVertical) = vbVertical Then
s.nMax = objTarget.Height \ Screen.TwipsPerPixelY
s.nPage = s.nMax \ 10
Call SetScrollInfo(hObj, SB_VERT, s, True)
End If
If (sbPos And vbHorizontal) = vbHorizontal Then
s.nMax = objTarget.Width \ Screen.TwipsPerPixelX
s.nPage = s.nMax \ 10
Call SetScrollInfo(hObj, SB_HORZ, s, True)
End If
OldProc = SetWindowLong(hObj, GWL_WNDPROC, AddressOf WndProc)
End Sub
Public Function WndProc(ByVal hOwner As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim nOldPos As Long
Select Case wMsg
Case WM_VSCROLL, WM_HSCROLL
GetScrollInfo hOwner, wMsg - WM_HSCROLL, s
nOldPos = s.nPos
Select Case GetLoWord(wParam)
Case SB_LINEDOWN
s.nPos = s.nPos + 1
Case SB_LINEUP
s.nPos = s.nPos - 1
Case SB_PAGEDOWN
s.nPos = s.nPos + s.nPage
Case SB_PAGEUP
s.nPos = s.nPos - s.nPage
Case SB_THUMBTRACK
s.nPos = GetHiWord(wParam)
End Select
If s.nPos < s.nMin Then s.nPos = s.nMin
If s.nPos > s.nMax Then s.nPos = s.nMax
SetScrollInfo hOwner, wMsg - WM_HSCROLL, s, True
If wMsg = WM_VSCROLL Then
ScrollWindowByNum hOwner, 0, nOldPos - s.nPos, 0, 0
Else
ScrollWindowByNum hOwner, nOldPos - s.nPos, 0, 0, 0
End If
Case WM_DESTROY
If hObj <> 0 Then Call SetWindowLong(hObj, GWL_WNDPROC, OldProc)
Case Else
End Select
WndProc = CallWindowProc(OldProc, hOwner, wMsg, wParam, lParam)
End Function
Private Function GetHiWord(dw As Long) As Long
If dw And &H80000000 Then
GetHiWord = (dw \ 65535) - 1
Else
GetHiWord = dw \ 65535
End If
End Function
Private Function GetLoWord(dw As Long) As Long
If dw And &H8000& Then
GetLoWord = &H8000 Or (dw And &H7FFF&)
Else
GetLoWord = dw And &HFFFF&
End If
End Function
В форме:
- Код: Выделить всё
Private Sub Form_Load()
SetScrollBar Me, vbVertical
End Sub
