Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0389: Magnetisch andockende Fenster

VB 5/6-Tipp 0389: Magnetisch andockende Fenster

 von Benjamin Wilger

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GetCursorPos, GetWindowRect, SetWindowPos, SystemParametersInfoA (SystemParametersInfo)

Download: Download des Beispielprojektes [6,22 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: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit

Private Sub Command1_Click()
    Dim frm As Form

    For Each frm In Forms
        Unload frm
    Next frm
End Sub

Private Sub Form_Load()
    Form4.Show
    Form3.Show
    Form2.Show
    Form1.Show
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then Call startDrag(Me.hWnd)
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call dragFrm(Me.hWnd)
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call stopDrag
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Formular "Form2" alias Form2.frm  ---------
' Steuerelement: Schaltfläche "Command1"
Option Explicit

Private Sub Command1_Click()
    Dim frm As Form
    
    For Each frm In Forms
        Unload frm
    Next frm
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then Call startDrag(Me.hWnd)
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Call dragFrm(Me.hWnd)
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Call stopDrag
End Sub
'---------- Ende Formular "Form2" alias Form2.frm  ----------
'--------- Anfang Formular "Form3" alias Form3.frm  ---------
Option Explicit

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then Call startDrag(Me.hWnd)
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call dragFrm(Me.hWnd)
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call stopDrag
End Sub
'---------- Ende Formular "Form3" alias Form3.frm  ----------
'--------- Anfang Formular "Form4" alias Form4.frm  ---------
Option Explicit

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then Call startDrag(Me.hWnd)
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call dragFrm(Me.hWnd)
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call stopDrag
End Sub

'---------- Ende Formular "Form4" alias Form4.frm  ----------
'--------- Anfang Modul "snapMod" alias snapMod.bas ---------
'Dieser Code zeigt, wie man Winamp-alike Effekte auch für die
'eigenen Forms nutzen kann. Ist sicherlich noch ausbaufähig.
'Zum Beispiel funktioniert dieser "Snaping"-Effekt nur beim Ver-
'schieben, nicht beim verändern der Größe. Dafür müsste dann
'Subclassing ran...

'Copyright (C) 2001 Benjamin Wilger
'Code kann frei weitergegeben werden. Bei Veröffentlichung auf
'anderen Seiten bitte ich um eine Mail an mich:
'Benjamin@ActiveVB.de

'Währe nett, wenn dieses Kommentar erhalten bleibt... ;D

Option Explicit

Private Declare Function SystemParametersInfo Lib "user32" Alias _
        "SystemParametersInfoA" (ByVal uAction As Long, ByVal _
        uParam As Long, lpvParam As Any, ByVal fuWinIni 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 GetCursorPos Lib "user32" (lpPoint As _
        POINTAPI) As Long
        
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd _
        As Long, lpRect As RECT) As Long
      
Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Const SPI_GETWORKAREA = 48&

Private Const SWP_NOMOVE As Long = &H2&
Private Const SWP_NOSIZE As Long = &H1&
Private Const SWP_NOZORDER As Long = &H4&
Private Const SWP_FLAGS As Long = SWP_NOSIZE Or SWP_NOZORDER

Private XDif As Integer
Private YDif As Integer
Private FMove As Boolean
Private Points() As RECT
Private ClX As Integer
Private ClY As Integer
Private scrRECT As RECT

'Abstand ab wann die Form "einschnappt".
Private Const SNAP_WIDTH As Integer = 10

Public Sub dragFrm(hWnd As Long)
    Dim r As RECT
    Dim p As POINTAPI
    Dim fX As Integer
    Dim fY As Integer
    Dim cX As Integer
    Dim cY As Integer
    Dim oX As Integer
    Dim oY As Integer
    Dim i As Integer
    Dim X As Integer
    Dim Y As Integer
    Dim foundEdge As Boolean

    GetCursorPos p
    X = p.X
    Y = p.Y

    Call GetWindowRect(hWnd, r)

    If FMove Then
        cX = X - XDif
        cY = Y - YDif
        fX = r.Left + cX
        fY = r.Top + cY
        
        'Sieht schlimmer aus, als es ist... (c:
        'Erläuterung zu den Kommentaren:
        'z.B. Links-Rechts bedeutet: Die linke Seite der eigenen
        'Form an der rechten Seite des anderen Objektes.
        
        For i = 0 To UBound(Points)
        
            'Links-Rechts
            If (r.Left >= (Points(i).Right - SNAP_WIDTH) And r.Left _
                <= (Points(i).Right + SNAP_WIDTH)) And (cX >= _
                -SNAP_WIDTH And cX <= SNAP_WIDTH) And ((r.Top <= _
                Points(i).Bottom) And (r.Bottom >= Points(i).Top) And _
                Not (r.Left + SNAP_WIDTH >= scrRECT.Right)) Then
                
                oX = fX
                fX = Points(i).Right
                XDif = XDif + (oX - X) + ClX
                foundEdge = True
                Exit For
                
            'Rechts-Rechts
            ElseIf r.Right >= (Points(i).Right - SNAP_WIDTH) And _
                r.Right <= (Points(i).Right + SNAP_WIDTH) And _
                cX >= -SNAP_WIDTH And cX <= SNAP_WIDTH And _
                ((r.Top <= Points(i).Bottom) And (r.Bottom >= _
                Points(i).Top)) Then
    
                oX = fX
                fX = Points(i).Right - (r.Right - r.Left)
                XDif = XDif + (oX - X) + ClX
                foundEdge = True
                Exit For
            
            'Links-Links
            ElseIf (r.Left >= (Points(i).Left - SNAP_WIDTH) And _
                r.Left <= (Points(i).Left + SNAP_WIDTH)) And _
                (cX >= -SNAP_WIDTH And cX <= SNAP_WIDTH) And _
                ((r.Top <= Points(i).Bottom) And (r.Bottom >= _
                Points(i).Top)) Then
                
                oX = fX
                fX = Points(i).Left
                XDif = XDif + (oX - X) + ClX
                foundEdge = True
                Exit For
                
            'Rechts-Links
            ElseIf r.Right >= (Points(i).Left - SNAP_WIDTH) And _
                r.Right <= (Points(i).Left + SNAP_WIDTH) And _
                cX >= -SNAP_WIDTH And cX <= SNAP_WIDTH And _
                ((r.Top <= Points(i).Bottom) And (r.Bottom >= _
                Points(i).Top) And Not (r.Right - SNAP_WIDTH _
                <= scrRECT.Left)) Then
                
                oX = fX
                fX = Points(i).Left - (r.Right - r.Left)
                XDif = XDif + (oX - X) + ClX
                foundEdge = True
                Exit For
            End If
        Next i
        
        If Not foundEdge Then XDif = X
        foundEdge = False
        
        For i = 0 To UBound(Points)
            
            'Oben-Unten
            If (r.Top >= (Points(i).Bottom - SNAP_WIDTH) And r.Top _
                <= (Points(i).Bottom + SNAP_WIDTH)) And (cY >= _
                -SNAP_WIDTH And cY <= SNAP_WIDTH) And ((r.Left <= _
                Points(i).Right) And (r.Right >= Points(i).Left) And _
                Not (r.Top + SNAP_WIDTH >= scrRECT.Bottom)) Then
                
                oY = fY
                fY = Points(i).Bottom
                YDif = YDif + (oY - Y) + ClY
                foundEdge = True
                Exit For
    
            'Unten-Unten
            ElseIf r.Bottom >= (Points(i).Bottom - SNAP_WIDTH) And _
                r.Bottom <= (Points(i).Bottom + SNAP_WIDTH) And _
                cY >= -SNAP_WIDTH And cY <= SNAP_WIDTH And _
                ((r.Left <= Points(i).Right) And (r.Right >= _
                Points(i).Left)) Then
                
                oY = fY
                fY = Points(i).Bottom - (r.Bottom - r.Top)
                YDif = YDif + (oY - Y) + ClY
                foundEdge = True
                Exit For
                
            'Oben-Oben
            ElseIf (r.Top >= (Points(i).Top - SNAP_WIDTH) And _
                r.Top <= (Points(i).Top + SNAP_WIDTH)) And _
                (cY >= -SNAP_WIDTH And cY <= SNAP_WIDTH) And _
                ((r.Left <= Points(i).Right) And (r.Right >= _
                Points(i).Left)) Then
                
                oY = fY
                fY = Points(i).Top
                YDif = YDif + (oY - Y) + ClY
                foundEdge = True
                Exit For
            
            'Unten-Oben
            ElseIf r.Bottom >= (Points(i).Top - SNAP_WIDTH) And _
                r.Bottom <= (Points(i).Top + SNAP_WIDTH) And _
                cY >= -SNAP_WIDTH And cY <= SNAP_WIDTH And _
                ((r.Left <= Points(i).Right) And (r.Right >= _
                Points(i).Left) And Not (r.Bottom - SNAP_WIDTH _
                <= scrRECT.Top)) Then
                
                oY = fY
                fY = Points(i).Top - (r.Bottom - r.Top)
                YDif = YDif + (oY - Y) + ClY
                foundEdge = True
                Exit For
                
            End If
        Next i
        
        If Not foundEdge Then YDif = Y
        Call SetWindowPos(hWnd, 0&, fX, fY, 0&, 0&, SWP_FLAGS)
    End If
End Sub

Public Sub startDrag(hWnd As Long)
    Dim p As POINTAPI
    Dim rF As RECT
    Dim frm As Form
    Dim i As Integer
    
    FMove = True
    ReDim Points(0)
    
    'Desktopgröße ohne die Taskleiste ermitteln...
    Call SystemParametersInfo(SPI_GETWORKAREA, vbNull, scrRECT, 0)
    
    Points(0) = scrRECT
    i = 1
    
    'RECTs der Forms ermitteln.
    For Each frm In Forms
        If (Not hWnd = frm.hWnd) And frm.Visible = True Then
            ReDim Preserve Points(0 To i)
            GetWindowRect frm.hWnd, Points(i)
            i = i + 1
        End If
    Next frm
    
    Call GetCursorPos(p)
    
    XDif = p.X
    YDif = p.Y
    
    Call GetWindowRect(hWnd, rF)
    
    ClX = p.X - rF.Left
    ClY = p.Y - rF.Top
End Sub

Public Sub stopDrag()
    FMove = False
End Sub
'---------- Ende Modul "snapMod" alias snapMod.bas ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------