Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0792: Maus-Ereignisse für Shape-Steuerelemente simulieren

 von 

Beschreibung 

Shapes sind ganz praktisch. Sie lassen sich transparent überlagern und benötigen wenig Ressourcen. Einziger Nachteil sind die fehlenden Ereignisse. Hier drei Varianten zum Simulieren von Maus-Events.

Variante 1: Erkennt das Shape anhand seiner Koordinaten. Funktioniert für Quadrate, Rechtecke und Kreise. Andere Shape-Typen wären auch möglich, aber unnötig aufwändig.

Variante 2: Nutzt die PtInRect-Api. Nur geeignet für Quadrate und Rechtecke.

Variante 3: Verwendet die Region-Apis. Hiermit lassen sich alle Shape-Typen erfassen.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

CreateEllipticRgn, CreateRectRgn, CreateRoundRectRgn, DeleteObject, PtInRect, PtInRegion, SetRect

Download:

Download des Beispielprojektes [8,3 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"
' Steuerelement: Figur-Steuerelement "Shape6"
' Steuerelement: Figur-Steuerelement "Shape5"
' Steuerelement: Figur-Steuerelement "Shape3"
' Steuerelement: Figur-Steuerelement "Shape2"
' Steuerelement: Figur-Steuerelement "Shape4"
' Steuerelement: Figur-Steuerelement "Shape1"
' Steuerelement: Figur-Steuerelement "Shape7"
Option Explicit

Private XM As Single, YM As Single

Private Sub Form_Load()
  
  Me.ScaleMode = vbPixels ' Einheit Pixel
  
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  
  Dim ShapeName As String
  
  ' Koordinaten für Click-Event eintragen
  XM = x
  YM = y
  
  If Mouse_over_Shape(x, y, ShapeName) = True Then
    Label1.Caption = "Mauszeiger über " & ShapeName
  Else
    Label1.Caption = "Kein Kreis / Rechteck / Quadrat-Shape"
  End If
  
End Sub

Private Sub Form_Click()

  Dim ShapeName As String

  If Mouse_over_Shape(XM, YM, ShapeName) = True Then
    MsgBox "Mausclick auf " & ShapeName, vbOKOnly + vbInformation, Me.Caption
  End If

End Sub

Private Function Mouse_over_Shape(x As Single, y As Single, ShapeName As String) As Boolean
  ' Befindet sich der Mauszeiger über einem Shape?

  Dim XPos As Single, YPos As Single
  Dim ShpWidth As Single, ShpHeight As Single
  Dim C As Control, Radius As Single
  Dim DX As Single, DY As Single
    
  Mouse_over_Shape = False
  For Each C In Me.Controls
    ' Ist Control ein Shape?
    If TypeOf C Is Shape Then
      ' Sichtbar?
      If C.Visible = True Then
        ' Typ zulässig?
        Select Case C.Shape
          Case vbShapeRectangle, vbShapeSquare, vbShapeCircle
            XPos = C.Left
            YPos = C.Top
            ShpWidth = C.Width
            ShpHeight = C.Height
            If C.Shape <> vbShapeRectangle Then
            ' Sonderfall: Shape-Grafik kleiner als Control
              If ShpWidth < ShpHeight Then
                YPos = YPos + (ShpHeight - ShpWidth) / 2
                ShpHeight = ShpWidth
              Else
                XPos = XPos + (ShpWidth - ShpHeight) / 2
                ShpWidth = ShpHeight
              End If
            End If
            If C.Shape = vbShapeCircle Then
              ' Kreis
              Radius = ShpWidth / 2
              DX = XPos + ShpWidth / 2 - x
              DY = YPos + ShpHeight / 2 - y
              If DX * DX + DY * DY <= Radius * Radius Then
                ShapeName = C.Name
                Mouse_over_Shape = True
                Exit For
              End If
            ' Rechteck oder Quadrat
            ElseIf x >= XPos And x < XPos + ShpWidth And _
              y >= YPos And y < YPos + ShpHeight Then
              ShapeName = C.Name
              Mouse_over_Shape = True
              Exit For
            End If
        End Select
      End If
    End If
  Next C

End Function

Private Sub Command1_Click()
  
  Unload Me

End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Formular "Form2" alias Form2.frm  ---------
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "Label1"
' Steuerelement: Figur-Steuerelement "Shape5"
' Steuerelement: Figur-Steuerelement "Shape3"
' Steuerelement: Figur-Steuerelement "Shape2"
' Steuerelement: Figur-Steuerelement "Shape4"
' Steuerelement: Figur-Steuerelement "Shape1"
Option Explicit

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

' Deklarationen
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private XM As Single, YM As Single

Private Sub Form_Load()
  
  Me.ScaleMode = vbPixels ' Einheit Pixel

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  
  Dim ShapeName As String
  
  ' Koordinaten für Click-Event eintragen
  XM = x
  YM = y
  
  If Mouse_over_Shape(x, y, ShapeName) = True Then
    Label1.Caption = "Mauszeiger über " & ShapeName
  Else
    Label1.Caption = "Kein Rechteck / Quadrat-Shape"
  End If
  
End Sub

Private Sub Form_Click()

  Dim ShapeName As String

  If Mouse_over_Shape(XM, YM, ShapeName) = True Then
    MsgBox "Mausclick auf " & ShapeName, vbOKOnly + vbInformation, Me.Caption
  End If

End Sub

Private Function Mouse_over_Shape(x As Single, y As Single, ShapeName As String) As Boolean
  ' Befindet sich der Mauszeiger über einem Shape?

  Dim C As Control, R1 As RECT
  Dim XPos As Single, YPos As Single
  Dim ShpWidth As Single, ShpHeight As Single
  
  Mouse_over_Shape = False
  For Each C In Me.Controls
    ' Ist Control ein Shape?
    If TypeOf C Is Shape Then
      ' Sichtbar?
      If C.Visible = True Then
        ' Shapetyp zulässig?
        If C.Shape = vbShapeRectangle Or C.Shape = vbShapeSquare Then
          XPos = C.Left
          YPos = C.Top
          ShpWidth = C.Width
          ShpHeight = C.Height
          If C.Shape = vbShapeSquare Then
            ' Sonderfall: Shape-Grafik kleiner als Control
            If ShpWidth < ShpHeight Then
              YPos = YPos + (ShpHeight - ShpWidth) / 2
              ShpHeight = ShpWidth
            Else
              XPos = XPos + (ShpWidth - ShpHeight) / 2
              ShpWidth = ShpHeight
            End If
          End If
          Call SetRect(R1, XPos, YPos, XPos + ShpWidth, YPos + ShpHeight)
          If PtInRect(R1, x, y) <> 0 Then
            ShapeName = C.Name
            Mouse_over_Shape = True
            Exit For ' Shape gefunden, nix wie raus hier
          End If
        End If
      End If
    End If
  Next C

End Function

Private Sub Command1_Click()
  
  Unload Me

End Sub
'---------- Ende Formular "Form2" alias Form2.frm  ----------
'--------- Anfang Formular "Form3" alias Form3.frm  ---------
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "Label1"
' Steuerelement: Figur-Steuerelement "Shape2"
' Steuerelement: Figur-Steuerelement "Shape6"
' Steuerelement: Figur-Steuerelement "Shape5"
' Steuerelement: Figur-Steuerelement "Shape4"
' Steuerelement: Figur-Steuerelement "Shape3"
' Steuerelement: Figur-Steuerelement "Shape1"
' Copyright © 2010 by Zardoz

Option Explicit

' Deklarationen
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long

Private RgnCount As Long
Private XM As Single, YM As Single
Private RgnList() As Long, NameList() As String

Private Sub Form_Load()
  
  Me.ScaleMode = vbPixels ' Einheit Pixel
  Call CreateRgnList

End Sub

Private Sub CreateRgnList()
  ' Für jedes Shape eine Region anlegen

  Dim XPos As Single, YPos As Single
  Dim ShpWidth As Single, ShpHeight As Single
  Dim C As Control
  
  RgnCount = Me.Controls.Count
  ReDim NameList(RgnCount), RgnList(RgnCount)
  RgnCount = -1
  ' Alle Controls durchgehen
  For Each C In Me.Controls
    ' Ist es ein Shape?
    If TypeOf C Is Shape Then
      With C
        ' Sichtbar?
        If .Visible = True Then
          RgnCount = RgnCount + 1
          NameList(RgnCount) = .Name
          XPos = .Left
          YPos = .Top
          ShpWidth = .Width
          ShpHeight = .Height
          ' Sonderfall: Shape-Grafik kleiner als Control
          Select Case .Shape
            Case vbShapeSquare, vbShapeCircle, vbShapeRoundedSquare
              If ShpWidth < ShpHeight Then
                YPos = YPos + (ShpHeight - ShpWidth) / 2
                ShpHeight = ShpWidth
              Else
                XPos = XPos + (ShpWidth - ShpHeight) / 2
                ShpWidth = ShpHeight
              End If
          End Select
          ' Für Shapetyp passende Region erstellen
          Select Case .Shape
            Case vbShapeCircle, vbShapeOval
              RgnList(RgnCount) = CreateEllipticRgn(XPos, YPos, XPos + ShpWidth, YPos + ShpHeight)
            Case vbShapeSquare, vbShapeRectangle
              RgnList(RgnCount) = CreateRectRgn(XPos, YPos, XPos + ShpWidth, YPos + ShpHeight)
            Case vbShapeRoundedSquare, vbShapeRoundedRectangle
              RgnList(RgnCount) = CreateRoundRectRgn(XPos, YPos, XPos + ShpWidth, YPos + ShpHeight, ShpWidth * 0.05, ShpHeight * 0.05)
          End Select
        End If
      End With
    End If
  Next C
  ' Arrays anpassen
  If RgnCount >= 0 Then
    ReDim Preserve NameList(RgnCount), RgnList(RgnCount)
  Else
    Erase NameList, RgnList
  End If
  
End Sub

Private Sub DeleteRgnList()
  ' Regions löschen
  
  Dim i As Long
  
  ' Regions vorhanden?
  If RgnCount >= 0 Then
    ' Alle Regions löschen
    For i = 0 To RgnCount
      Call DeleteObject(RgnList(i))
    Next i
    ' Arrays löschen
    Erase RgnList, NameList
  End If
  RgnCount = -1

End Sub

Private Sub RefreshRgnList()
  ' Wenn sich zur Laufzeit die Position, Grösse oder
  ' Visible-Eigenschaft eines Shapes ändert,
  ' diese Sub aufrufen. Dann werden die Regions angepasst.
  
  Call DeleteRgnList
  Call CreateRgnList

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  
  Dim ShapeName As String
  
  ' Koordinaten für Click-Event eintragen
  XM = x
  YM = y
  
  If Mouse_over_Shape(x, y, ShapeName) = True Then
    Label1.Caption = "Mauszeiger über " & ShapeName
  Else
    Label1.Caption = "Kein Shape"
  End If
  
End Sub

Private Sub Form_Click()
  
  Dim ShapeName As String
  
  If Mouse_over_Shape(XM, YM, ShapeName) = True Then
    MsgBox "Mausclick auf " & ShapeName, vbOKOnly + vbInformation, Me.Caption
  End If
  
End Sub

Private Function Mouse_over_Shape(x As Single, y As Single, ShapeName As String) As Boolean
  ' Befindet sich der Mauszeiger über einem Shape?

  Dim i As Long

  Mouse_over_Shape = False
  ' Regions vorhanden?
  If RgnCount >= 0 Then
    ' Alle Regions durchgehen
    For i = 0 To RgnCount
      If PtInRegion(RgnList(i), x, y) <> 0 Then
        Mouse_over_Shape = True ' Mauszeiger auf Region
        ShapeName = NameList(i)
        Exit For ' Shape gefunden, nix wie raus hier
      End If
    Next i
  End If

End Function

Private Sub Command1_Click()
  
  Unload Me

End Sub

Private Sub Form_Unload(Cancel As Integer)
  ' Beim Beenden Speicher aufräumen
  
  Call DeleteRgnList

End Sub
'---------- Ende Formular "Form3" alias Form3.frm  ----------
'--------- Anfang Formular "Form4" alias Form4.frm  ---------
' Steuerelement: Schaltfläche "Command1" (Index von 0 bis 2)
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit

Private Sub Command1_Click(Index As Integer)
  
  Select Case Index
    Case 0
      Form1.Show vbModal
    Case 1
      Form2.Show vbModal
    Case 2
      Form3.Show vbModal
  End Select
  
End Sub

Private Sub Command2_Click()
  
  Unload Me

End Sub
'---------- Ende Formular "Form4" alias Form4.frm  ----------
'-------------- Ende Projektdatei Projekt1.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.