VB 5/6-Tipp 0792: Maus-Ereignisse für Shape-Steuerelemente simulieren
von Zardoz
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: | Verwendete API-Aufrufe: CreateEllipticRgn, CreateRectRgn, CreateRoundRectRgn, DeleteObject, PtInRect, PtInRegion, SetRect | Download: |
'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-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
VB4 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
VB5 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
VB6 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
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.