Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0566: Einrastbare Toolbar realisieren

VB 5/6-Tipp 0566: Einrastbare Toolbar realisieren

 von Sean Mertiens

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GetCursorPos, GetDesktopWindow, GetParent, ScreenToClient, SetParent

Download: Download des Beispielprojektes [5,7 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 Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Bildfeld-Steuerelement "picTool"
' Steuerelement: Timersteuerelement "Timer1" auf picTool
' Steuerelement: Schaltfläche "Command3" auf picTool
' Steuerelement: Schaltfläche "Command6" auf picTool
' Steuerelement: Schaltfläche "Command5" auf picTool
' Steuerelement: Schaltfläche "Command4" auf picTool
' Steuerelement: Schaltfläche "Command2" auf picTool
' Steuerelement: Schaltfläche "Command1" auf picTool
' Steuerelement: Textfeld "Text1"

'
'Autor: Sean Mertiens <sean.mertiens@gmx.de>

Option Explicit

' Gibt an ob die Toolbar gezogen wird
Dim DragFlag As Boolean

' Gibt an ob die Toolbar an ihrem richtigen Platz ist
Public ToolVisible As Boolean

Private Sub Command1_Click()
    WriteText "Neu"
End Sub

Private Sub Command2_Click()
    WriteText "Speichern"
End Sub

Private Sub Command3_Click()
    WriteText "Öffnen"
End Sub

Private Sub Command4_Click()
    WriteText "Ausschneiden"
End Sub

Private Sub Command5_Click()
    WriteText "Kopieren"
End Sub

Private Sub Command6_Click()
    WriteText "Einfügen"
End Sub

Private Sub Form_Load()
    'Toolbar erstellen
    CreateToolbar picTool, sttMouseDefault
    ToolVisible = True
End Sub

Private Sub CreateToolbar(pic As PictureBox, Optional state As STATECONSTANTS = sttMouseDefault)
    ' pic vorbereiten
    pic.AutoRedraw = True
    pic.BorderStyle = 0
    pic.Cls

    If state = sttMouseDefault Then
        ' Maus ist nicht drüber
        pic.Line (2, 2)-(150, pic.ScaleHeight), TLB_DEFAULT, BF
    ElseIf state = sttMouseOver Then
        ' Maus ist über dem Ziehbereich: anders färben
        pic.Line (2, 2)-(150, pic.ScaleHeight), TLB_OVER, BF
    End If
    
    ' 3d-effekt:
    pic.Line (1, 1)-(pic.ScaleWidth, 1), vbWhite
    pic.Line (1, 1)-(1, pic.ScaleHeight), vbWhite
    pic.Line (pic.ScaleWidth - 10, 1)-(pic.ScaleWidth - 10, pic.ScaleHeight - 10), vbBlack
    pic.Line (1, pic.ScaleHeight - 10)-(pic.ScaleWidth, pic.ScaleHeight - 10), vbBlack
    pic.Refresh
End Sub

Public Sub Form_Resize()
    Dim tH%
    ' Ist die Toolbar auf der Form, Platz lassen
    If ToolVisible Then
        tH = picTool.ScaleHeight
    Else
        tH = 0
    End If
    
    ' Textfeld anpassen
    Text1.Move 0, tH, Me.ScaleWidth, Me.ScaleHeight - tH
    
    ' Nur wenn toolbar in diesem Fenster:
    If GetParent(picTool.hwnd) = Me.hwnd Then
        picTool.Width = Me.ScaleWidth
    End If
End Sub

Private Sub picTool_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button <> vbLeftButton Then Exit Sub
    ' Verhindert, dass die Toolbar im falschen Fenster gezogen wird
    If GetParent(picTool.hwnd) <> Me.hwnd Then Exit Sub
    ' Toolbar kann nur mit dem Ziehbereich bewegt werden
    If picTool.Point(X, Y) <> TLB_OVER Then Exit Sub
    
    ' Ziehen starten
    DragFlag = True
End Sub

Private Sub picTool_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' Hover-Effekt aktualisieren
    If picTool.Point(X, Y) = TLB_DEFAULT Or picTool.Point(X, Y) = TLB_OVER Then
        CreateToolbar picTool, sttMouseOver
    Else
        CreateToolbar picTool, sttMouseDefault
    End If
End Sub

Private Sub picTool_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' Ziehen beenden, eventuell Toolbar "zurückschnappen" lassen
    If GetParent(picTool.hwnd) = Me.hwnd Then
        picTool.Move 0, 0
    End If
    
    DragFlag = False
End Sub

Private Sub Timer1_Timer()
    If Not DragFlag Then Exit Sub
    
    Dim PT As POINTAPI
    
    ' Cursor-Koordinaten ermitteln und umrechnen
    Call GetCursorPos(PT)
    Call ScreenToClient(Me.hwnd, PT)
    
    PT.X = PT.X * Screen.TwipsPerPixelX
    PT.Y = PT.Y * Screen.TwipsPerPixelY
    
    ' Toolbar bewegen
    picTool.Move PT.X, PT.Y
    
    ' Wenn die Toolbar vollständig aus ihrem Bereich gezogen wurde
    If picTool.Top >= (picTool.ScaleHeight) Then
        ' Ziehen beenden
        DragFlag = False
        
        ' Fenster anzeigen
        Form2.Show
        
        ' Toolbar in Fenster einbinden und Fenster als Child setzen
        Call SetParent(picTool.hwnd, Form2.hwnd)
        Call SetParent(Form2.hwnd, Me.hwnd)
        
        ' Fenster an Toolbar-Koordinaten bewegen
        Form2.Move PT.X, PT.Y
        
        ' Toolbar an Fenster anpassen
        picTool.Move 0, 0, Form2.ScaleWidth - 100, Form2.ScaleHeight
        
        ' Toolbar neuzeichnen
        CreateToolbar picTool
        ToolVisible = False
        Call Form_Resize
        
        WriteText "Um die Toolbar zurückzubewegen Fenster schließen"
    End If
End Sub
Sub WriteText(txt As String)
    Text1.Text = txt & vbCrLf & Text1.Text
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Formular "Form2" alias Form2.frm  ---------
Option Explicit

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
' Wird die Toolbar geschlossen, wird sie wieder am oberen Rand angedockt
    Call SetParent(Form1.picTool.hwnd, Form1.hwnd)
    Call SetParent(Me.hwnd, GetDesktopWindow)
    Form1.ToolVisible = True
    Call Form1.Form_Resize
    
    Unload Me
End Sub
'---------- Ende Formular "Form2" alias Form2.frm  ----------
'------ Anfang Modul "modDeclare" alias modDeclare.bas ------
Option Explicit

' Gibt an ob die Maus über der Ziehfläche ist
Public Enum STATECONSTANTS
    sttMouseDefault = 0
    sttMouseOver = 1
End Enum

' Farben für die Zieh-Fläche
Public Const TLB_DEFAULT = &H8F0000
Public Const TLB_OVER = vbBlue

' Zum ermitteln der Mauskoordinaten
Public Declare Function GetCursorPos Lib "user32" ( _
     lpPoint As POINTAPI) As Long

Public Type POINTAPI
    X As Long
    Y As Long
End Type

' umrechnen auf Client-Wert
Public Declare Function ScreenToClient Lib "user32" ( _
     ByVal hwnd As Long, _
     lpPoint As POINTAPI) As Long

' Eltern-fenster ermitteln
Public Declare Function GetParent Lib "user32" (ByVal hwnd As Long) _
As Long

' Eltern-fenster setzen
Public Declare Function SetParent Lib "user32" _
        (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

' Desktop-fenster ermittlen
Public Declare Function GetDesktopWindow Lib "user32" () As Long


'------- Ende Modul "modDeclare" alias modDeclare.bas -------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 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.