Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0317: Steuerelemente markieren, beliebig dehnen und verschieben

 von 

Beschreibung 

Dieser Tipp gestattet es Picture- und TextBoxen wie in der IDE zu verschieben und in ihrer Größe zu verändern. Dabei können sowohl im Raum als auch in den Abmaßen Ober- und Untergrenzen vorgegeben werden. Theoretisch würde dies auch mit List- und ComboBoxen funktionieren. Allerdings müßte hierfür ein zusätzliche Berechnung vorgenommen werden, da diese Steuerelemente in ihrer vertikalen Größe nicht fließend sondern nur sprunghaft änderbar sind.

Schwierigkeitsgrad:

Schwierigkeitsgrad 1

Verwendete API-Aufrufe:

GetWindowPlacement, SetWindowPlacement

Download:

Download des Beispielprojektes [4,16 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: Bildfeld-Steuerelement "Picture1" (Index von 0 bis 7)
' Steuerelement: Textfeld "Text1"
' Steuerelement: Beschriftungsfeld "Label1"

Option Explicit

Private Declare Function GetWindowPlacement Lib "user32" _
        (ByVal hwnd As Long, lpwndpl As WINDOWPLACEMENT) As _
        Long

Private Declare Function SetWindowPlacement Lib _
        "user32" (ByVal hwnd As Long, lpwndpl _
        As WINDOWPLACEMENT) 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 Type WINDOWPLACEMENT
  Length As Long
  flags As Long
  showCmd As Long
  ptMinPosition As POINTAPI
  ptMaxPosition As POINTAPI
  rcNormalPosition As RECT
End Type



'Konfiguration
'------------------------------------------------
'Abstand der Markierungskästchen vom Control
Const Sp = 1&

'Minimale & Maximale Abmaße des Controls
Const Wmin = 6&
Const Wmax = 350&
Const Hmin = 19&
Const Hmax = 250&

'Eckerkoordinaten des erlaubten Bewegungsraumes
Const LimX1 = 10&
Const LimY1 = 10&
Const LimX2 = 500&
Const LimY2 = 300&
'------------------------------------------------

Dim DragFlag As Boolean, MoveFlag As Boolean
Dim Fetched As Boolean
Dim StartX&, Starty&
Dim MCtrl As Control

Private Sub Form_Load()
  Dim TPX&, TPY&
  
    'Begrenzungsrahmen zeichnen
    Me.AutoRedraw = True
    TPX = Screen.TwipsPerPixelX
    TPY = Screen.TwipsPerPixelY
    Me.Line (LimX1 * TPX, LimY1 * TPY)-(LimX2 * TPX, LimY2 _
                                        * TPY), 0, B
    Me.AutoRedraw = False
End Sub

Private Sub Form_Click()
  Dim x%
    
    For x = 0 To 7
      Picture1(x).Visible = False
    Next x
    If Fetched Then
      MCtrl.MousePointer = vbDefault
      Fetched = False
    End If
End Sub

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

Private Sub Text1_Click()
  Set MCtrl = Text1
  Text1.MousePointer = vbSizeAll
  Call DrawPics
  Fetched = True
End Sub

Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, _
                            x As Single, Y As Single)
  MoveFlag = True
  StartX = x
  Starty = Y
End Sub

Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, _
                          x As Single, Y As Single)
  MoveFlag = False
End Sub

Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, _
                            x As Single, Y As Single)
  Dim xD&, yD&, TPX&, TPY&
  Static Doing As Boolean
  
    If Doing Or Not Fetched Then Exit Sub
    
    Doing = True
    If MoveFlag Then
      TPX = Screen.TwipsPerPixelX
      TPY = Screen.TwipsPerPixelY
      
      xD = Text1.Left + (x - StartX)
      If xD + Text1.Width > LimX2 * TPX Then
        xD = LimX2 * TPX - Text1.Width
      ElseIf xD < LimX1 * TPX Then
        xD = LimX1 * TPX
      End If
      
      yD = Text1.Top + (Y - Starty)
      If yD + Text1.Height > LimY2 * TPY Then
        yD = LimY2 * TPY - Text1.Height
      ElseIf yD < LimY1 * TPY Then
        yD = LimY1 * TPY
      End If
      
      Text1.Left = xD
      Text1.Top = yD
      Call DrawPics
    End If
    Doing = False
End Sub

Private Sub Picture1_MouseDown(Index As Integer, Button As _
                               Integer, Shift As Integer, x _
                               As Single, Y As Single)
  DragFlag = True
End Sub

Private Sub Picture1_MouseUp(Index As Integer, Button As _
                             Integer, Shift As Integer, x _
                             As Single, Y As Single)
  DragFlag = False
End Sub

Private Sub Picture1_MouseMove(Index As Integer, Button As _
                               Integer, Shift As Integer, x _
                               As Single, Y As Single)
                               
  Dim xP&, yP&, x1&, x2&, y1&, y2&, WPM As WINDOWPLACEMENT
  Dim TPX%, TPY&, XNoSize As Boolean, YNoSize As Boolean
  Static MemX1&, MemX2&, MemY1&, Memy2&
  Static Doing As Boolean
    
    If Doing Then Exit Sub
    Doing = True
     
    If DragFlag Then
      TPX = Screen.TwipsPerPixelX
      TPY = Screen.TwipsPerPixelY
      xP = x / TPX
      yP = Y / TPY
      
      WPM.Length = Len(WPM)
      Call GetWindowPlacement(MCtrl.hwnd, WPM)
      x1 = WPM.rcNormalPosition.Left
      x2 = WPM.rcNormalPosition.Right
      y1 = WPM.rcNormalPosition.Top
      y2 = WPM.rcNormalPosition.Bottom
    
      With Picture1(Index)
            
        If Index = 0 Or Index = 1 Or Index = 2 Then
          If x1 + xP > x2 - Wmin Then
            XNoSize = True
            x1 = x2 - Wmin
          ElseIf x2 - (x1 + xP) > Wmax Then
            XNoSize = True
            x1 = x2 - Wmax
          Else
            x1 = x1 + xP
          End If
          If x1 <= LimX1 Then
            XNoSize = True
            x1 = LimX1
          End If
        End If
        
        If Index = 4 Or Index = 5 Or Index = 3 Then
          If x2 + xP < x1 + Wmin Then
            XNoSize = True
            x2 = x1 + Wmin
          ElseIf x2 + xP - x1 > Wmax Then
            XNoSize = True
            x2 = x1 + Wmax
          Else
            x2 = x2 + xP
          End If
          
          If x2 > LimX2 Then
            XNoSize = True
            x2 = LimX2
          End If
        End If
        
        If Index = 0 Or Index = 6 Or Index = 3 Then
          If y1 + yP > y2 - Hmin Then
            YNoSize = True
            y1 = y2 - Hmin
          ElseIf y2 - (y1 + yP) > Hmax Then
            YNoSize = True
            y1 = y2 - Hmax
          Else
            y1 = y1 + yP
          End If
          
          If y1 <= LimY1 Then
            YNoSize = True
            y1 = LimY1
          End If
        End If
         
        If Index = 7 Or Index = 2 Or Index = 5 Then
          If y2 + yP < y1 + Hmin Then
            YNoSize = True
            y2 = y1 + Hmin
          ElseIf y2 + yP - y1 > Hmax Then
            YNoSize = True
            y2 = y1 + Hmax
          Else
            y2 = y2 + yP
          End If
          
          If y2 > LimY2 Then
            YNoSize = True
            y2 = LimY2
          End If
        End If
    
      Select Case Index
        Case 0, 2, 3, 5: Y = Y + .Top
                         x = x + .Left
                        
        Case 1, 4:       x = x + .Left
                         Y = .Top
               
        Case 6, 7:       Y = Y + .Top
                         x = .Left
      End Select
      
      If Not YNoSize Then .Top = Y
      If Not XNoSize Then .Left = x
    End With

    If MemX1 <> x1 Or MemX2 <> x2 Or MemY1 <> y1 _
                   Or Memy2 <> y2 Then
      If TypeOf MCtrl Is ListBox Or TypeOf MCtrl Is ComboBox Then
        '...
      Else
        WPM.rcNormalPosition.Left = x1
        WPM.rcNormalPosition.Top = y1
        WPM.rcNormalPosition.Right = x2
        WPM.rcNormalPosition.Bottom = y2
        Call SetWindowPlacement(MCtrl.hwnd, WPM)
        Call DrawPics
      End If
    End If
    
    MemX1 = x1
    MemX2 = x2
    MemY1 = y1
    Memy2 = y2
  End If
  
  Doing = False
End Sub

Private Sub DrawPics()
  Dim TPX%, TPY&, x%
     
     TPX = Screen.TwipsPerPixelX
     TPY = Screen.TwipsPerPixelY
     
     With MCtrl
       Picture1(0).Left = .Left - Sp * TPX - Picture1(0).Width
       Picture1(1).Left = .Left - Sp * TPX - Picture1(1).Width
       Picture1(2).Left = .Left - Sp * TPX - Picture1(2).Width
       Picture1(0).Top = .Top - Sp * TPY - Picture1(0).Height
       Picture1(1).Top = .Top + (.Height - Picture1(1).Height) / 2
       Picture1(2).Top = .Top + .Height + Sp * TPY
       
       Picture1(3).Left = .Left + .Width + Sp * TPX
       Picture1(4).Left = .Left + .Width + Sp * TPX
       Picture1(5).Left = .Left + .Width + Sp * TPX
       Picture1(3).Top = .Top - Sp * TPY - Picture1(0).Height
       Picture1(4).Top = .Top + (.Height - Picture1(1).Height) / 2
       Picture1(5).Top = .Top + .Height + Sp * TPY
       
       Picture1(6).Left = .Left + (.Width - Picture1(6).Width) / 2
       Picture1(7).Left = .Left + (.Width - Picture1(6).Width) / 2
       
       Picture1(6).Top = .Top - Sp * TPY - Picture1(0).Height
       Picture1(7).Top = .Top + .Height + Sp * TPY
     End With
     
    If Not Picture1(0).Visible Then
      For x = 0 To 7
        Picture1(x).Visible = True
      Next x
    End If
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- 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.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 6 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 Guido Eisenbeis am 22.05.2004 um 00:10

Der Code ist cool !

Ich habe ihn umgeschrieben auf Twips (ohne API).
Er kommt jetzt auch mit Labels zurecht. Es wird kein KlassenModul benötigt.


Gruss, Guido

Kommentar von Philipp Stephani am 21.04.2004 um 22:51

@III:
Weil Labels keine richtigen Controls sind. Sie sind nur Texte, dir direkt auf die Form gezeichnet werden.

Kommentar von III am 08.03.2004 um 14:51

Mal ne dumme Frage, aber warum funktioniert das nicht mit Labelfeldern?

Kommentar von Interflo am 28.03.2003 um 13:38

Für alle die beim Verschieben das Problem haben, dass sich das control ständig auf der Form abzeichnet ;)
Baut ins MouseMove ereignis nen Me.cls ein ;)

Kommentar von Litschi am 09.08.2001 um 16:10

Hier sieht man wie es mit List/Comboboxen /Rectangel/Lines etc... funktioniert.
Grüße, Litschi
ftp://ftp.softcircuits.com/vbsrc/formdsgn.zip

Kommentar von Hans am 12.01.2001 um 11:18

Hallo,
ich habe den Code etwas umgeschrieben, so dass ich eine universelle MoveControl-Funktion erhalten habe, die ich in den jeweiligen MouseMove-Ereignissen aufrufe. Dies klappt wunderbar, solange das entsprechende Control ein eigenes MouseMove-Ereignis besitzt.
Nun habe ich aber ein Control ohne dieses Ereignis und versuchte, das MouseMove des Containers des Controls zu nutzen. Dabei wird die Funktion aber irgendwie zu oft aufgerufen, so dass eine kleine Mausbewegung dass Control gleich eine viel zu weite Strecke zurücklegen lässt.
Weiss jemand wie ich das, vielleicht mittels eines Flags, wieder korrigieren kann, der Quellcode ist zu lang um ihn hier zu posten, aber ich kann ihn per Mail verschicken.
Danke