Startseite / Tipps / VB 5/6-Tipp 0232: Scrollbars in ein Formular einbauen

VB 5/6-Tipp 0232: Scrollbars in ein Formular einbauen

 von Herfried K. Wagner

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Beschriftungsfeld "Label1"

Option Explicit

Private LabelTop As Long
Private LabelLeft As Long

Private WithEvents oVScroll As Class1

Private Sub Form_Load()
    Set oVScroll = New Class1
    
    With oVScroll
        .SubClass (Me.hWnd)
        .VScroll = True
        .VDisableNoScroll = True
        .VMin = 3
        .VMax = ScaleHeight * 2
        .VPage = ScaleHeight
        .VSmallChange = 10
        
        .HScroll = True
        .HDisableNoScroll = True
        .HMin = 3
        .HMax = ScaleWidth * 2
        .HPage = ScaleWidth
        .HSmallChange = 10
    End With
    
    With Label1
        LabelTop = .Top
        LabelLeft = .Left
    End With
End Sub

Private Sub oVScroll_HChange(ByVal nCurPos As Long)
    Label1.Left = -(nCurPos - LabelLeft)
End Sub

Private Sub oVScroll_HScroll(ByVal nCurPos As Long)
    Label1.Left = -(nCurPos - LabelLeft)
End Sub

Private Sub oVScroll_VChange(ByVal nCurPos As Long)
    Label1.Top = -(nCurPos - LabelTop)
End Sub

Private Sub oVScroll_VScroll(ByVal nCurPos As Long)
    Label1.Top = -(nCurPos - LabelTop)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set oVScroll = Nothing
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Klasse "Class1" alias Class1.cls  ---------

Option Explicit

Private Declare Function GetScrollInfo Lib "user32" (ByVal _
        hWnd As Long, ByVal fnBar As HORZ_VERT, lpScrollInfo As _
        SCROLLINFO) As Long
                
Private Declare Function SetScrollInfo Lib "user32" (ByVal _
        hWnd As Long, ByVal fnBar As HORZ_VERT, lpcScrollInfo As _
        SCROLLINFO, ByVal fRedraw As Long) As Long
                
Private Declare Function ShowScrollBar Lib "user32" (ByVal _
        hWnd As Long, ByVal wBar As Long, ByVal bShow As Long) As Long

Private Const WM_HSCROLL As Long = &H114&
Private Const WM_VSCROLL As Long = &H115&

Private Const SB_CTL As Long = 2&
Private Const SB_BOTH As Long = 3&

Private Const SB_LINEUP As Long = 0&
Private Const SB_LINELEFT As Long = 0&
Private Const SB_LINEDOWN As Long = 1&
Private Const SB_LINERIGHT As Long = 1&
Private Const SB_PAGEUP As Long = 2&
Private Const SB_PAGELEFT As Long = 2&
Private Const SB_PAGEDOWN As Long = 3&
Private Const SB_PAGERIGHT As Long = 3&
Private Const SB_THUMBPOSITION As Long = 4&
Private Const SB_THUMBTRACK As Long = 5&
Private Const SB_TOP As Long = 6&
Private Const SB_LEFT As Long = 6&
Private Const SB_BOTTOM As Long = 7&
Private Const SB_RIGHT As Long = 7&
Private Const SB_ENDSCROLL As Long = 8&

Public Enum SIF_MASK
    SIF_RANGE = &H1&
    SIF_PAGE = &H2&
    SIF_POS = &H4&
    SIF_DISABLENOSCROLL = &H8&
    SIF_TRACKPOS = &H10&
    SIF_ALL = SIF_RANGE Or SIF_PAGE Or SIF_POS
End Enum

Private Type SCROLLINFO
    cbSize As Long
    fMask As SIF_MASK
    nMin As Long
    nMax As Long
    nPage As Long
    nPos As Long
    nTrackPos As Long
End Type

Private m_WinProcOld As Long
Private m_hWnd As Long

Private Enum HORZ_VERT
    SB_HORZ = 0&
    SB_VERT = 1&
End Enum

Private m_bHScroll As Boolean
Private m_bHDisableNoScroll As Boolean
Private m_nHSmallChange As Long
Private m_bVScroll As Boolean
Private m_bVDisableNoScroll As Boolean
Private m_nVSmallChange As Long

Private m_nHScrollPos As Long
Private m_nVScrollPos As Long

Private m_tagSCROLLINFO As SCROLLINFO

Event HChange(ByVal nCurPos As Long)
Event HScroll(ByVal nCurPos As Long)
Event VChange(ByVal nCurPos As Long)
Event VScroll(ByVal nCurPos As Long)

Friend Function ScrollProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
    
    Select Case uMsg
        Case WM_VSCROLL
            With Me
                Select Case LoWord(wParam)
                    Case SB_BOTTOM
                        .VPos = .VMax
                        RaiseEvent VChange(m_nVScrollPos)
                        
                    Case SB_TOP
                        .VPos = .VMin
                        RaiseEvent VChange(m_nVScrollPos)
                        
                    Case SB_LINEDOWN
                        .VPos = .VPos + m_nVSmallChange
                        RaiseEvent VChange(m_nVScrollPos)
                        
                    Case SB_LINEUP
                        .VPos = .VPos - m_nVSmallChange
                        RaiseEvent VChange(m_nVScrollPos)
                        
                    Case SB_PAGEDOWN
                        .VPos = .VPos + .VPage
                        RaiseEvent VChange(m_nVScrollPos)
                        
                    Case SB_PAGEUP
                        .VPos = .VPos - .VPage
                        RaiseEvent VChange(m_nVScrollPos)
                        
                    Case SB_THUMBPOSITION, SB_THUMBTRACK
                        .VPos = HiWord(wParam)
                        RaiseEvent VScroll(m_nVScrollPos)
                End Select
            End With
                
            ScrollProc = 0&
            Exit Function
                
        Case WM_HSCROLL
            With Me
                Select Case LoWord(wParam)
                    Case SB_BOTTOM
                        .HPos = .HMax
                        RaiseEvent HChange(m_nHScrollPos)
                        
                    Case SB_TOP
                        .HPos = .HMin
                        RaiseEvent HChange(m_nHScrollPos)
                        
                    Case SB_LINERIGHT
                        .HPos = .HPos + m_nHSmallChange
                        RaiseEvent HChange(m_nHScrollPos)
                        
                    Case SB_LINELEFT
                        .HPos = .HPos - m_nHSmallChange
                        RaiseEvent HChange(m_nHScrollPos)
                        
                    Case SB_PAGERIGHT
                        .HPos = .HPos + .HPage
                        RaiseEvent HChange(m_nHScrollPos)
                        
                    Case SB_PAGELEFT
                        .HPos = .HPos - .HPage
                        RaiseEvent HChange(m_nHScrollPos)
                        
                    Case SB_THUMBPOSITION, SB_THUMBTRACK
                        .HPos = HiWord(wParam)
                        RaiseEvent HScroll(m_nHScrollPos)
                End Select
            End With
            
            ScrollProc = 0&
        Exit Function
    End Select
        
    ScrollProc = CallWindowProc(m_WinProcOld, hWnd, uMsg, wParam, lParam)
End Function

Public Property Get HScroll() As Boolean
    HScroll = m_bHScroll
End Property

Public Property Let HScroll(ByVal bNewVal As Boolean)
    If m_bHScroll <> bNewVal Then
        m_bHScroll = bNewVal
            
        ShowSB SB_HORZ, bNewVal
    End If
End Property

Public Property Get HMin() As Long
    With m_tagSCROLLINFO
        .fMask = SIF_RANGE
        Call GetScrollInfo(m_hWnd, SB_HORZ, m_tagSCROLLINFO)
        HMin = .nMin
    End With
End Property

Public Property Let HMin(ByVal nNewVal As Long)
    With m_tagSCROLLINFO
        .fMask = SIF_RANGE
        .nMin = nNewVal
        .nMax = HMax
    End With
        
    Call CallSetHScrollInfo
End Property

Public Property Get HMax() As Long
    With m_tagSCROLLINFO
        .fMask = SIF_RANGE
        Call GetScrollInfo(m_hWnd, SB_HORZ, m_tagSCROLLINFO)
        HMax = .nMax
    End With
End Property

Public Property Let HMax(ByVal nNewVal As Long)
    With m_tagSCROLLINFO
        .fMask = SIF_RANGE
        .nMin = HMin
        .nMax = nNewVal
    End With
        
    Call CallSetHScrollInfo
End Property

Public Property Get HPage() As Long
    With m_tagSCROLLINFO
        .fMask = SIF_PAGE
        Call GetScrollInfo(m_hWnd, SB_HORZ, m_tagSCROLLINFO)
        HPage = .nPage
    End With
End Property

Public Property Let HPage(ByVal nNewVal As Long)
    With m_tagSCROLLINFO
        .fMask = SIF_PAGE
        .nPage = nNewVal
    End With
        
    Call CallSetHScrollInfo
End Property

Public Property Get HPos() As Long
    With m_tagSCROLLINFO
        .fMask = SIF_POS
        Call GetScrollInfo(m_hWnd, SB_HORZ, m_tagSCROLLINFO)
        HPos = .nPos
    End With
End Property

Public Property Let HPos(ByVal nNewVal As Long)
    With m_tagSCROLLINFO
        .fMask = SIF_POS
        .nPos = nNewVal
    End With
        
    CallSetHScrollInfo
End Property

Public Property Get HSmallChange() As Long
    HSmallChange = m_nHSmallChange
End Property

Public Property Let HSmallChange(ByVal nNewVal As Long)
    m_nHSmallChange = nNewVal
End Property

Public Property Get HDisableNoScroll() As Boolean
    HDisableNoScroll = m_bHDisableNoScroll
End Property

Public Property Let HDisableNoScroll(ByVal bNewVal As Boolean)
    m_bHDisableNoScroll = bNewVal
End Property

Private Sub CallSetHScrollInfo()
    If m_bHDisableNoScroll Then
        With m_tagSCROLLINFO
            .fMask = .fMask Or SIF_DISABLENOSCROLL
        End With
    End If
        
    m_nHScrollPos = SetScrollInfo(m_hWnd, SB_HORZ, m_tagSCROLLINFO, 1&)
End Sub

Public Property Get VScroll() As Boolean
    VScroll = m_bVScroll
End Property

Public Property Let VScroll(ByVal bNewVal As Boolean)
    If m_bVScroll <> bNewVal Then
        m_bVScroll = bNewVal
        Call ShowSB(SB_VERT, bNewVal)
    End If
End Property

Public Property Get VMin() As Long
    With m_tagSCROLLINFO
        .fMask = SIF_RANGE
        Call GetScrollInfo(m_hWnd, SB_VERT, m_tagSCROLLINFO)
        VMin = .nMin
    End With
End Property

Public Property Let VMin(ByVal nNewVal As Long)
    With m_tagSCROLLINFO
        .fMask = SIF_RANGE
        .nMin = nNewVal
        .nMax = VMax
    End With
        
    CallSetVScrollInfo
End Property

Public Property Get VMax() As Long
    With m_tagSCROLLINFO
        .fMask = SIF_RANGE
        Call GetScrollInfo(m_hWnd, SB_VERT, m_tagSCROLLINFO)
        VMax = .nMax
    End With
End Property

Public Property Let VMax(ByVal nNewVal As Long)
    With m_tagSCROLLINFO
        .fMask = SIF_RANGE
        .nMin = VMin
        .nMax = nNewVal
    End With
        
    Call CallSetVScrollInfo
End Property

Public Property Get VPage() As Long
    With m_tagSCROLLINFO
        .fMask = SIF_PAGE
        Call GetScrollInfo(m_hWnd, SB_VERT, m_tagSCROLLINFO)
        VPage = .nPage
    End With
End Property

Public Property Let VPage(ByVal nNewVal As Long)
    With m_tagSCROLLINFO
        .fMask = SIF_PAGE
        .nPage = nNewVal
    End With
        
    Call CallSetVScrollInfo
End Property

Public Property Get VPos() As Long
    With m_tagSCROLLINFO
        .fMask = SIF_POS
        Call GetScrollInfo(m_hWnd, SB_VERT, m_tagSCROLLINFO)
            VPos = .nPos
    End With
End Property

Public Property Let VPos(ByVal nNewVal As Long)
    With m_tagSCROLLINFO
        .fMask = SIF_POS
        .nPos = nNewVal
    End With
        
    Call CallSetVScrollInfo
End Property

Public Property Get VSmallChange() As Long
    VSmallChange = m_nVSmallChange
End Property

Public Property Let VSmallChange(ByVal nNewVal As Long)
    m_nVSmallChange = nNewVal
End Property

Public Property Get VDisableNoScroll() As Boolean
    VDisableNoScroll = m_bVDisableNoScroll
End Property

Public Property Let VDisableNoScroll(ByVal bNewVal As Boolean)
    m_bVDisableNoScroll = bNewVal
End Property

Private Sub CallSetVScrollInfo()
    If m_bVDisableNoScroll Then
        With m_tagSCROLLINFO
            .fMask = .fMask Or SIF_DISABLENOSCROLL
        End With
    End If
        
    m_nVScrollPos = SetScrollInfo(m_hWnd, SB_VERT, m_tagSCROLLINFO, 1&)
End Sub

Private Sub ShowSB(ByVal eType As HORZ_VERT, ByVal bShow As Boolean)
    Dim fShow As Long
    
    Select Case bShow
        Case True: fShow = 1&
        Case False: fShow = 0&
    End Select
    
    Call ShowScrollBar(m_hWnd, eType, fShow)
End Sub

Public Sub SubClass(ByVal hWnd&)
    If IsWindow(hWnd) Then
        If GetProp(hWnd, "nvStdScroll") Then Exit Sub
        
        If SetProp(hWnd, ByVal "nvStdScroll", ObjPtr(Me)) Then
            m_WinProcOld = SetWindowLong(hWnd, GWL_WNDPROC, _
                           AddressOf Module1.StdScrollProc)
            
            m_hWnd = hWnd
        End If
    End If
End Sub

Private Sub UnSubClass()
    If IsWindow(m_hWnd) Then
        If m_WinProcOld Then
            Call SetWindowLong(m_hWnd, GWL_WNDPROC, m_WinProcOld)
            Call RemoveProp(m_hWnd, "nvStdScroll")
            m_WinProcOld = 0
            m_hWnd = 0
        End If
    End If
End Sub

Private Sub Class_Initialize()
    m_tagSCROLLINFO.cbSize = Len(m_tagSCROLLINFO)
End Sub

Private Sub Class_Terminate()
    UnSubClass
End Sub
'---------- Ende Klasse "Class1" alias Class1.cls  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------

Option Explicit

Public Declare Function SetWindowLong Lib "user32" Alias _
       "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal _
       dwNewLong As Long) As Long

Public Declare Function SetProp Lib "user32" Alias "SetPropA" _
       (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
       
Public Declare Function GetProp Lib "user32" Alias "GetPropA" _
       (ByVal hWnd As Long, ByVal lpString As String) As Long
       
Public Declare Function RemoveProp Lib "user32" Alias _
       "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long

Public Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) _
       As Long
       
Public 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
       
Public Declare Sub CopyMemory Lib "kernel32" Alias _
       "RtlMoveMemory" (lpDest As Any, lpSource As Any, _
       ByVal cBytes As Long)

Public Const GWL_WNDPROC As Long = -4&

Public Function LoWord(ByVal dwValue As Long) As Integer
  Call CopyMemory(LoWord, dwValue, 2&)
End Function

Public Function HiWord(ByVal dwValue As Long) As Integer
  Call CopyMemory(HiWord, ByVal VarPtr(dwValue) + 2, 2&)
End Function

Public Function StdScrollProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal _
                wParam As Long, ByVal lParam As Long) As Long
                               
  StdScrollProc = Class1FromhWnd(hWnd).ScrollProc _
                  (hWnd, uMsg, wParam, lParam)
End Function

Private Function Class1FromhWnd(ByVal hWnd As Long) As Class1
  Dim StdScrollBarEx As Class1, pObj As Long
    
    pObj = GetProp(hWnd, ByVal "nvStdScroll")
    
    Call CopyMemory(StdScrollBarEx, pObj, 4&)
    Set Class1FromhWnd = StdScrollBarEx
    Call CopyMemory(StdScrollBarEx, 0&, 4&)
End Function
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 13 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.