Die Community zu .NET und Classic VB.
Menü

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

 von 

Beschreibung 

Fenster haben unter Windows grundsätzlich das Recht auf eigene Scrollbalken. Unter VB ist das standardmäßig verwehrt. Diese Klasse erlaubt es eigene Formulare mit diesen Balken zu bestücken um bei großen darzustellenden Flächen den Fensterinhalt hin- und herzubewegen.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

CallWindowProcA (CallWindowProc), RtlMoveMemory (CopyMemory), GetPropA (GetProp), GetScrollInfo, IsWindow, RemovePropA (RemoveProp), SetPropA (SetProp), SetScrollInfo, SetWindowLongA (SetWindowLong), ShowScrollBar

Download:

Download des Beispielprojektes [5,43 KB]

'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-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

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

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Scrollbar und Scale - Wolfram 21.03.12 20:43 1 Antwort
Scrollbar und Scale - Wolfram 21.03.12 20:43 3 Antworten

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.

Kommentar von Uwe Gärtner am 14.05.2003 um 15:21

Ich habe bei mir Scrollbars mit Hilfe dieses Tipps in ein MDI-Child Formular eingebunden. Mein Problem ist nun Folgendes: Die Scrollbars sind nur zu sehen, wenn das Parent Formular maximiert ist. Ich möchte aber erreichen, dass die Scrollbars im MDI-Child auch sichtbar sind, wenn das Parent-Formular nicht maximiert ist.
Kann mir jmd. helfen?

Kommentar von Hans-Jörg Stradtmann am 07.05.2003 um 15:31

Leider steigt das Programm beim Schliessen unter VB6 und XP mit einer Fehlermeldung aus und VB wird beendet. Worankönnte das liegen ?

Kommentar von Thomasz am 23.08.2002 um 19:36

Was muß ich schreiben um auch die restlichen
Button ,Label,Textbox,
mit zu scrollen
Ich sag schon mal Danke für jede Antwort

Kommentar von David am 27.04.2002 um 21:36

was muss ich machen damit auch schaltflächen usw. mitscrollen.
mfg
david

Kommentar von Stefan am 06.12.2001 um 23:13

Hi.
Ich hab das Zeug nu eingebaut und stelle fest, dass es ganz gut läuft. Nur habe ich noch nicht herausbekommen, wie ich diese Scrollbars auch wieder deaktivieren (ausblenden) kann. Vielleicht weiß ja jemand Rat.

Kommentar von Hirf am 26.07.2001 um 22:33

Ich kenne leider das Problem selbst nicht. Da das Beispiel SubClassing verwendet, dürfen Sie NICHT auf den Stop-Button der IDE klicken, sonst gibt es eine Schutzverletzung.
Grüsse,
Hirf

Kommentar von André Lauer am 24.07.2001 um 11:41

Ich habe den obigen Script in ein Formular eingebunden und er funktioniert fehlerfrei. jedoch habe ich das Problem, dass wenn ich mit Tab von Textbox zu Textbox springe die Scrollbar nicht mit springt und so der Focus teilweise verschwindet.
Für eine Hilfe wäre ich sehr dankbar!

Kommentar von Markus am 28.06.2001 um 07:48

Warum werden eingefügte Frames im Label nicht mitgescrollt???
Weiss jemand Antwort?

Kommentar von konrad doblander am 24.06.2001 um 18:37

Habe heute im Forum eine entsprechende Frage gestellt und erst danach diesen Tip gefunden - leider verabschiedet sich VB5
nach dem Aufruf des beigefügten Bsp.Programms - hat jemand schone eine Idee woran das liegt ?

Kommentar von Max am 02.12.2000 um 15:35

Hallo Leute
Das selbe passiert bei mir auch Stefan.
Aber warum ich das schreibe: Ich will eine Figur hier nach links und rechts bewegen und wenn diese eine Größere lefteigenschaft als 6000 hab, so soll die Form rüberscrollen.
Das Problem ist, hier gibt es keine Valueeigenschaft!!!
Wer kann helfen???

Kommentar von Götz Reinecke am 12.11.2000 um 18:44

Hallo Christian,
mhm, aber genau das macht doch dieser Tip hier, oder etwa nicht?

Kommentar von Christian am 09.11.2000 um 09:12

Hallo liebes ActiveVB-Team. Zuerstmal muß ich euch loben: Ihr habt echt brauchbare Tips auf euren Seiten! Nun zu meinem Problem: Wie kann ich den Fensterinhalt auf einem normalen Formular (nicht MDI-Child) scrollen? Bitte helft mir!

Kommentar von Stefan Payer am 04.11.2000 um 14:54

Ich habe Scrollbalken, ungefähr auf diese Weise zu einem OCX hinzugefügt. das funktionierte problemlos, aber beim erstellen einer zweiten Instanz auf dem selben Testformular stürzte VB6 ab. Nach erneutem Startversuch von VB hängt sich dann mein PC komplett auf und mir bleibt nur der RESET.
Ich hoffe Sie haben eine Lösung.