Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0463: Magnetische Fenster II

VB 5/6-Tipp 0463: Magnetische Fenster II

 von Benjamin Wilger

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CallWindowProcA (CallWindowProc), RtlMoveMemory (CopyMemory), GetCursorPos, GetWindowLongA (GetWindowLong), GetWindowRect, OffsetRect, SendMessageA (SendMessage), SetWindowLongA (SetWindowLong), SetWindowPos, SystemParametersInfoA (SystemParametersInfo_Rect)

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

Private Sub Command1_Click()
    Form2.Show
End Sub

Private Sub Command2_Click()
    Form3.Show
End Sub

Private Sub Command3_Click()
    Unload Me
End Sub

'Bester Weg, eine Anwendung zu beenden
'KEIN End nehmen! VB *WIRD* abstürzen!
Private Sub Command4_Click()
    Dim frm As Form
    
    For Each frm In Forms
        Unload frm
        Set frm = Nothing
    Next frm
End Sub

Private Sub Form_Load()
    'Mit diesem schnieken Befehl starten Sie das Ganze
    DockingStart Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'Und hier mit machen wir es wieder aus. Das wars auch schon!
    DockingTerminate Me
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Formular "Form2" alias Form2.frm  ---------
' Steuerelement: Schaltfläche "Command1"
Option Explicit

Private Sub Command1_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    Me.Top = Form1.Top
    Me.Left = Form1.Left + Form1.Width
    
    DockingStart Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    DockingTerminate Me
End Sub

'---------- Ende Formular "Form2" alias Form2.frm  ----------
'--------- Anfang Formular "Form3" alias Form3.frm  ---------
' Steuerelement: Schaltfläche "Command1"
Option Explicit

Private Sub Command1_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    Me.Top = Form1.Top
    Me.Left = Form1.Left + Form1.Width
    
    DockingStart Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    DockingTerminate Me
End Sub


'---------- Ende Formular "Form3" alias Form3.frm  ----------
'------ Anfang Modul "Docking" alias MagneticForms.bas ------
'Magnetische Forms Modul.
'Copyright (C) 2001 Benjamin Wilger
'Benjamin@ActiveVB.de

'Die Methode, wie die Fenster organisiert werden, stammt aus:
'----------------------------------------------------
'MinMax.bas
'(w) by Mathias Schiffer, basicpro
'(w) by Marcus Warm, mwarm@geosoft.de
'----------------------------------------------------
Option Explicit

'API Deklarationen
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 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 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 Sub CopyMemory Lib "kernel32" _
                    Alias "RtlMoveMemory" ( _
                    pDest As Any, _
                    pSrc As Any, _
                    ByVal ByteLen As Long)
                    
Private Declare Function SystemParametersInfo_Rect Lib "user32" _
                         Alias "SystemParametersInfoA" ( _
                         ByVal uAction As Long, _
                         ByVal uParam As Long, _
                         lpvParam As RECT, _
                         ByVal fuWinIni As Long) As Long
                         
Private Declare Function GetWindowRect Lib "user32" ( _
                         ByVal hWnd As Long, _
                         lpRect As RECT) As Long
                         
Private Declare Function SendMessage Lib "user32" _
                         Alias "SendMessageA" ( _
                         ByVal hWnd As Long, _
                         ByVal wMsg As Long, _
                         ByVal wParam As Long, _
                         lParam As Any) As Long
                         
Private Declare Function GetCursorPos Lib "user32" ( _
                         lpPoint As POINTAPI) 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 OffsetRect Lib "user32" ( _
                         lpRect As RECT, _
                         ByVal x As Long, _
                         ByVal y As Long) As Long

Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOACTIVATE = &H10

Private Const WM_MOVING = &H216
Private Const WM_SIZING = &H214
Private Const WM_ENTERSIZEMOVE = &H231
Private Const WM_EXITSIZEMOVE = &H232

Private Const GWL_WNDPROC = (-4)
Private Const GWL_STYLE = (-16)

Private Const SPI_GETWORKAREA = 48

Private Const WMSZ_LEFT = 1
Private Const WMSZ_TOPLEFT = 4
Private Const WMSZ_BOTTOMLEFT = 7
Private Const WMSZ_TOP = 3
Private Const WMSZ_TOPRIGHT = 5

'Eigene Deklarationen
'-----------------
Private Enum SnapFormMode
    Moving = 1
    Sizing = 2
End Enum

'Die Daten der Forms werden in dieser UDT organisiert.
Private Type DockingLog
    hWnd As Long
    oldProc As Long
End Type

Private Logs() As DockingLog, LogCount As Integer, MaxLogs As Integer

Private MouseX As Long, MouseY As Long
Public SnappedX As Boolean, SnappedY As Boolean
Public Rects() As RECT

'Hier kann der Wert, wo die Formen einrasten eingestellt werden
Private Const SnapWidth = 15

'Da Subclassing das Debuggen meist unmöglich macht, kann dies hier abgeschaltet werden
Private Const DoSubClass As Boolean = True

'Deaktiviert Docking für eine Form
Public Sub DockingTerminate(f As Form)
    Dim t As Integer, H As Long
    
    H = f.hWnd
    'Durchsuche alle Fenster
    For t = 0 To LogCount - 1
        If Logs(t).hWnd = H Then
            'Alte Windowproc setzen
            SetWindowLong H, GWL_WNDPROC, Logs(t).oldProc
            'Eintrag im Array entfernen
            For H = t To LogCount - 2
                Logs(H) = Logs(H + 1)
            Next H
            LogCount = LogCount - 1
            Exit For
        End If
    Next t
    
End Sub

'Aktiviert Docking für die Form
Public Sub DockingStart(f As Form)
    Dim H As Long, t As Integer
    
    If Not DoSubClass Then Exit Sub
    
    'Es wird nur in 10er Schritten das UDT-Array redimensioniert.
    If LogCount + 10 > MaxLogs Then
        MaxLogs = LogCount + 10
        ReDim Preserve Logs(MaxLogs)
    End If
    
    For t = 0 To LogCount - 1
        If Logs(t).hWnd = f.hWnd Then
            Debug.Print "Fenster " & f.Name & " ist bereits magnetisch!"
            Exit Sub
        End If
    Next t

    H = f.hWnd
    Logs(LogCount).hWnd = H
    'Start des Subclassings
    Logs(LogCount).oldProc = SetWindowLong(H, GWL_WNDPROC, AddressOf WindowProc)

    LogCount = LogCount + 1
    
End Sub

'Hier werden sämtliche Nachrichten aller Fenster abgefangen und bearbeitet.
'Nicht benötigte Nachrichten werden an die alte Routine weitergeleitet
Public Function WindowProc(ByVal hWnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    
    Dim t As Integer ' Counter-Variable
    Dim oldProc As Long ' Adresse der originalen WindowProc
    Dim r As RECT, p As POINTAPI
    Dim runProc As Boolean
    Dim frm As Form
    runProc = True
    
    'Search Window in Array
    For t = 0 To LogCount - 1
        If Logs(t).hWnd = hWnd Then
            oldProc = Logs(t).oldProc
            Exit For
        End If
    Next t
    
    If oldProc = 0 Then Exit Function 'Jetzt hätten wir ein klitzekleines Problem
    
    If wMsg = WM_ENTERSIZEMOVE Then 'Windows sagt, der User beginnt einen Größenänderungs-
                                    'oder Verschiebungsvorgang
        GetWindowRect hWnd, r
        GetCursorPos p
        MouseX = p.x - r.Left
        MouseY = p.y - r.Top
        
        GetFrmRects hWnd 'Rechtecke aller offenen Forms ermitteln

    ElseIf wMsg = WM_SIZING Or wMsg = WM_MOVING Then 'Während des Verschiebens/Resizen
                                                'haben wir die Möglichkeit, einzugreifen.
        CopyMemory r, ByVal lParam, Len(r) 'UDT-Daten vom Pointer holen
        
        'Nun starten wir die Funktion DockFormRect, die das Rechteck der Form anpasst
        If wMsg = WM_SIZING Then
            DockFormRect hWnd, Sizing, r, wParam
        Else
            DockFormRect hWnd, Moving, r, wParam, MouseX, MouseY
        End If
        
        'zurückschreiben
        CopyMemory ByVal lParam, r, Len(r)
        
        'Wir müssen 1(=True) zurückgeben
        WindowProc = 1
        
        runProc = False 'die originale Prozedur nicht starten
    End If
    
    'Nachricht an originale Routine weiterleiten
    If runProc Then WindowProc = CallWindowProc(oldProc, hWnd, wMsg, wParam, lParam)
    
End Function

Private Function GetFrmRects(ByVal hWnd As Long)
    Dim frm As Form, i As Integer
    
    ReDim Rects(0 To 0)
    SystemParametersInfo_Rect SPI_GETWORKAREA, vbNull, Rects(0), 0
    
    i = 1
    For Each frm In Forms
        If frm.Visible And Not frm.hWnd = hWnd Then
            ReDim Preserve Rects(0 To i)
            GetWindowRect frm.hWnd, Rects(i)
            
            i = i + 1
            
        End If
    Next frm

End Function

'Das Herzstück des Modules.
Private Sub DockFormRect(ByVal hWnd As Long, ByVal Mode As SnapFormMode, _
    GivenRect As RECT, Optional SizingEdge As Long, Optional MouseX As Long, _
    Optional MouseY As Long)
    
    Dim p As POINTAPI
    Dim i As Integer, diffX As Integer, diffY As Integer, diffWnd As Long
    Dim tmpRect As RECT, W As Integer, H As Integer, frmRect As RECT
    Dim XPos As Integer, YPos As Integer
    Dim tmpXPos As Integer, tmpYPos As Integer
    Dim tmpMouseX As Long, tmpMouseY As Long
    Dim FoundX As Boolean, FoundY As Boolean
    
    diffX = SnapWidth
    diffY = SnapWidth
    
    'Kopien des originalen Rechtecks erstellen
    tmpRect = GivenRect
    frmRect = GivenRect
    
    'Ein paar kleine Berechnungen, um die Position des Rechtecks zu korrigieren
    If Mode = Moving Then
        GetCursorPos p
        If SnappedX Then
            tmpMouseX = p.x - tmpRect.Left
            OffsetRect tmpRect, tmpMouseX - MouseX, 0
            OffsetRect GivenRect, tmpMouseX - MouseX, 0
        Else
            MouseX = p.x - tmpRect.Left
        End If
        If SnappedY Then
            tmpMouseY = p.y - tmpRect.Top
            OffsetRect tmpRect, 0, tmpMouseY - MouseY
            OffsetRect GivenRect, 0, tmpMouseY - MouseY
        Else
            MouseY = p.y - tmpRect.Top
        End If
    End If
    
    W = tmpRect.Right - tmpRect.Left
    H = tmpRect.Bottom - tmpRect.Top
    
    'Jetzt kommt der etwas schwer lesbare Teil...
    If Mode = Moving Then
        For i = 0 To UBound(Rects)
            If (tmpRect.Left >= (Rects(i).Left - SnapWidth) And _
                tmpRect.Left <= (Rects(i).Left + SnapWidth)) And _
                ((tmpRect.Top - SnapWidth) < Rects(i).Bottom And _
                (tmpRect.Bottom + SnapWidth) > Rects(i).Top) And _
                Abs(tmpRect.Left - Rects(i).Left) < diffX _
                Then
                
                GivenRect.Left = Rects(i).Left
                GivenRect.Right = GivenRect.Left + W
                
                diffX = Abs(tmpRect.Left - Rects(i).Left)
                
                FoundX = True
                
            ElseIf i > 0 And (tmpRect.Left >= (Rects(i).Right - SnapWidth) And _
                tmpRect.Left <= (Rects(i).Right + SnapWidth)) And _
                ((tmpRect.Top - SnapWidth) < Rects(i).Bottom And _
                (tmpRect.Bottom + SnapWidth) > Rects(i).Top) And _
                Abs(tmpRect.Left - Rects(i).Right) < diffX _
                Then
                
                GivenRect.Left = Rects(i).Right
                GivenRect.Right = GivenRect.Left + W
                
                diffX = Abs(tmpRect.Left - Rects(i).Right)
                
                FoundX = True
                
            ElseIf i > 0 And (tmpRect.Right >= (Rects(i).Left - SnapWidth) And _
                tmpRect.Right <= (Rects(i).Left + SnapWidth)) And _
                ((tmpRect.Top - SnapWidth) < Rects(i).Bottom And _
                (tmpRect.Bottom + SnapWidth) > Rects(i).Top) And _
                Abs(tmpRect.Right - Rects(i).Left) < diffX _
                Then
                
                GivenRect.Right = Rects(i).Left
                GivenRect.Left = GivenRect.Right - W
                
                diffX = Abs(tmpRect.Right - Rects(i).Left)
                
                FoundX = True
                
            ElseIf (tmpRect.Right >= (Rects(i).Right - SnapWidth) And _
                tmpRect.Right <= (Rects(i).Right + SnapWidth)) And _
                ((tmpRect.Top - SnapWidth) < Rects(i).Bottom And _
                (tmpRect.Bottom + SnapWidth) > Rects(i).Top) And _
                Abs(tmpRect.Right - Rects(i).Right) < diffX _
                Then
                
                GivenRect.Right = Rects(i).Right
                GivenRect.Left = GivenRect.Right - W
                
                diffX = Abs(tmpRect.Right - Rects(i).Right)
                
                FoundX = True
                
            End If
            
            'Y
            If (tmpRect.Top >= (Rects(i).Top - SnapWidth) And _
                tmpRect.Top <= (Rects(i).Top + SnapWidth)) And _
                ((tmpRect.Left - SnapWidth) < Rects(i).Right And _
                (tmpRect.Right + SnapWidth) > Rects(i).Left) And _
                Abs(tmpRect.Top - Rects(i).Top) < diffY _
                Then
                
                GivenRect.Top = Rects(i).Top
                GivenRect.Bottom = GivenRect.Top + H
                
                diffY = Abs(tmpRect.Top - Rects(i).Top)
                
                FoundY = True
                
            ElseIf i > 0 And (tmpRect.Top >= (Rects(i).Bottom - SnapWidth) And _
                tmpRect.Top <= (Rects(i).Bottom + SnapWidth)) And _
                ((tmpRect.Left - SnapWidth) < Rects(i).Right And _
                (tmpRect.Right + SnapWidth) > Rects(i).Left) And _
                Abs(tmpRect.Top - Rects(i).Bottom) < diffY _
                Then
                
                GivenRect.Top = Rects(i).Bottom
                GivenRect.Bottom = GivenRect.Top + H
                
                diffY = Abs(tmpRect.Top - Rects(i).Bottom)
                
                FoundY = True
                
            ElseIf i > 0 And (tmpRect.Bottom >= (Rects(i).Top - SnapWidth) And _
                tmpRect.Bottom <= (Rects(i).Top + SnapWidth)) And _
                ((tmpRect.Left - SnapWidth) < Rects(i).Right And _
                (tmpRect.Right + SnapWidth) > Rects(i).Left) And _
                Abs(tmpRect.Bottom - Rects(i).Top) < diffY _
                Then
                
                GivenRect.Bottom = Rects(i).Top
                GivenRect.Top = GivenRect.Bottom - H
                
                diffY = Abs(tmpRect.Bottom - Rects(i).Top)
                
                FoundY = True
                
            ElseIf (tmpRect.Bottom >= (Rects(i).Bottom - SnapWidth) And _
                tmpRect.Bottom <= (Rects(i).Bottom + SnapWidth)) And _
                ((tmpRect.Left - SnapWidth) < Rects(i).Right And _
                (tmpRect.Right + SnapWidth) > Rects(i).Left) And _
                Abs(tmpRect.Bottom - Rects(i).Bottom) < diffY _
                Then
                
                GivenRect.Bottom = Rects(i).Bottom
                GivenRect.Top = GivenRect.Bottom - H
                
                diffY = Abs(tmpRect.Bottom - Rects(i).Bottom)
                
                FoundY = True
                
            End If
        Next i
        
        'Wir merken uns, ob die Form irgendwo eingerastet ist
        SnappedX = FoundX
        SnappedY = FoundY
        
    ElseIf Mode = Sizing Then
        If SizingEdge = WMSZ_LEFT Or SizingEdge = WMSZ_TOPLEFT Or _
            SizingEdge = WMSZ_BOTTOMLEFT Then
            
            XPos = GivenRect.Left
        Else
            XPos = GivenRect.Right
        End If
        
        If SizingEdge = WMSZ_TOP Or SizingEdge = WMSZ_TOPLEFT Or _
            SizingEdge = WMSZ_TOPRIGHT Then
            
            YPos = GivenRect.Top
        Else
            YPos = GivenRect.Bottom
        End If

        tmpXPos = XPos
        tmpYPos = YPos

        For i = 0 To UBound(Rects)
            If ((tmpXPos >= (Rects(i).Left - SnapWidth) And _
                tmpXPos <= (Rects(i).Left + SnapWidth)) And _
                ((tmpRect.Top - SnapWidth) < Rects(i).Bottom And _
                (tmpRect.Bottom + SnapWidth) > Rects(i).Top) And _
                Abs(tmpXPos - Rects(i).Left) < diffX) _
                Then

                XPos = Rects(i).Left
                
                diffX = Abs(tmpXPos - Rects(i).Left)
                
            ElseIf (tmpXPos >= (Rects(i).Right - SnapWidth) And _
                tmpXPos <= (Rects(i).Right + SnapWidth)) And _
                ((tmpRect.Top - SnapWidth) < Rects(i).Bottom And _
                (tmpRect.Bottom + SnapWidth) > Rects(i).Top) And _
                Abs(tmpXPos - Rects(i).Right) < diffX _
                Then
                
                XPos = Rects(i).Right
                
                diffX = Abs(tmpXPos - Rects(i).Right)
    
            End If
            
            'Y
            If (tmpYPos >= (Rects(i).Top - SnapWidth) And _
                tmpYPos <= (Rects(i).Top + SnapWidth)) And _
                ((tmpRect.Left - SnapWidth) < Rects(i).Right And _
                (tmpRect.Right + SnapWidth) > Rects(i).Left) And _
                Abs(tmpYPos - Rects(i).Top) < diffY _
                Then
                
                YPos = Rects(i).Top
                
                diffY = Abs(tmpYPos - Rects(i).Top)
                
            ElseIf (tmpYPos >= (Rects(i).Bottom - SnapWidth) And _
                tmpYPos <= (Rects(i).Bottom + SnapWidth)) And _
                ((tmpRect.Left - SnapWidth) < Rects(i).Right And _
                (tmpRect.Right + SnapWidth) > Rects(i).Left) And _
                Abs(tmpYPos - Rects(i).Bottom) < diffY _
                Then
                
                YPos = Rects(i).Bottom
                
                diffY = Abs(tmpYPos - Rects(i).Bottom)
            End If
        Next i

        If SizingEdge = WMSZ_LEFT Or SizingEdge = WMSZ_TOPLEFT Or _
            SizingEdge = WMSZ_BOTTOMLEFT Then
            
            GivenRect.Left = XPos
        Else
            GivenRect.Right = XPos
        End If
    
        If SizingEdge = WMSZ_TOP Or SizingEdge = WMSZ_TOPLEFT Or _
            SizingEdge = WMSZ_TOPRIGHT Then
            
            GivenRect.Top = YPos
        Else
            GivenRect.Bottom = YPos
        End If
    End If
    
End Sub

'------- Ende Modul "Docking" alias MagneticForms.bas -------
'-------------- Ende Projektdatei Project1.vbp --------------

Archivierte Nutzerkommentare 

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