Um Aktionen ausführen zu lassen, wenn die Maus ein Control überfährt, benötigt man bekannterweise eine Art MouseIn-/MouseOut-Ereignis. Leider besitzen die VB-Standard-Controls diese Ereignisse nicht, so dass wir uns wieder einmal selbst behelfen müssen. In der jeweiligen Form werden "Pseudo-Ereignisse" ("MouseIn" und "MouseOut") angelegt. Diese können dann genauso wie "normale" Ereignisse (z.B. Click) aufgerufen werden. Das Besondere an "MouseInOut (GES)" ist, dass das Control kein hWnd besitzen muss (z.B. Label und Image). Geprüft wird die Maus-Position und ein Comparing-hWnd. Berücksichtigt wird auch, ob sich ein Control in anderen Controls (Container) befindet. Diese MouseInOut-Überwachung funktioniert sehr präzise. Im Gegensatz zu Codes mit "SetCapture, ReleaseCapture" gibt es hier kein "Hängenbleiben"! Bereits vor einem knappen Jahr haben wir in unserem Extra-Tipps Bereich einen entsprechenden Code vorgestellt. Dieser Tipp wurde jetzt nochmals überarbeitet und verbessert.
Fügen Sie Ihrem Projekt ein neues Modul hinzu und kopieren nachfolgenden Code in das Modul: Option Explicit ' Benötigte API-Deklarationen Private Declare Function SetTimer Lib "user32.dll" ( _ ByVal hwnd As Long, _ ByVal nIDEvent As Long, _ ByVal uElapse As Long, _ ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32.dll" ( _ ByVal hwnd As Long, _ ByVal nIDEvent As Long) As Long Public lEvent As Long ' Timer-ID Private Declare Function GetCursorPos Lib "user32" ( _ lpPoint As POINTAPI) As Long Private Declare Function ClientToScreen Lib "user32" ( _ ByVal hwnd As Long, _ lpPoint As POINTAPI) As Long Private Declare Function GetWindowRect Lib "user32" ( _ ByVal hwnd As Long, _ lpRect As RECT) As Long Private Declare Function PtInRect Lib "user32" ( _ lpRect As RECT, _ ByVal X As Long, _ ByVal Y As Long) As Long Private Declare Function WindowFromPoint Lib "user32" ( _ ByVal xPoint As Long, _ ByVal yPoint As Long) As Long Private Declare Function GetForegroundWindow Lib "user32" () As Long Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type POINTAPI X As Long Y As Long End Type Private fForm As Form ' Wird für "CallByName" benötigt Private Ctrl As Control ' Ist das zu überwachende Control Private CtrlRect As RECT ' Ist das Control-Rechteck (die Fläche) Private CompHWND As Long ' hWnd, das zum Überwachen benutzt wird Private M_Enter As Boolean ' Indikator für "MouseIn" Public CtrlIndex As Integer ' Falls es sich um ein Steuerelementefeld handelt, ' kann im "Pseudo-Ereignis" der Form der jeweilige ' Index über "CtrlIndex" verwendet werden. ' (Beispiel siehe ganz unten.) ' Starten der MouseInOut-Überwachung Public Sub MouseInOutTracking(ByVal cControl As Control) Dim Ret As Long ' für verschiedene Rückgabewerte Dim TmpCtrl As Object ' zum Ermitteln der (Parent-)Form Dim Cont As Object ' Container des jeweiligen Controls Dim ContRect As RECT ' Container-Rechteck (Fläche) Dim P1 As POINTAPI ' Begrenzungs-Punkte ... Dim P2 As POINTAPI ' ... des Control-Rechtecks ' MouseOut auslösen, falls das im MouseMove übergebene ' Control nicht das überwachte Control ist. ' (Sehr wichtig, falls 2 überwachte Controls sehr dicht ' beieinander, oder ineinander (Container) liegen, oder ' sich überlappen.) If ((Not Ctrl Is cControl)) Then ' MouseOut nur auslösen, falls der Timer schon läuft If (lEvent <> 0) Then ' ************ Maus hat das Control verlassen ************ DisableTimer M_Enter = False ' MouseOut-Routine aufrufen Call DoByMouseOut ' ******************************************************** End If ' Die (Parent-)Form des übergebenen Controls ermitteln Set TmpCtrl = cControl Do ' Solange den nächsthöheren Container prüfen, ' bis die Form gefunden ist. Set TmpCtrl = TmpCtrl.Container If (TypeOf TmpCtrl Is Form) Then Set fForm = TmpCtrl ' Übergabe an Modul-weit gültige Variable Set TmpCtrl = Nothing ' Speicher freigeben Exit Do End If Loop Set Ctrl = cControl ' Übergabe an Modul-weit gültige Variable End If ' MouseInOut-Überwachung nur dann starten: ' - falls die Überwachung noch nicht gestartet ist ' - und falls die Form aktiv ist ' (verhindert das Flackern von Controls (Labels)) If ((lEvent = 0) And (fForm.hwnd = GetForegroundWindow)) Then On Error Resume Next ' Fehlerbehandlung für Prüfungen ausschalten ' Index zuweisen, falls es sich um ein Steuerelementefeld handelt CtrlIndex = Ctrl.Index CompHWND = 0 ' zurücksetzen! CompHWND = Ctrl.hwnd ' Wegen "On Error ..."-Prüfung gesondert zuweisen If (CompHWND <> 0) Then ' Control besitzt ein HWND Ret = 0 ' zurücksetzen! Ret = Ctrl.ScaleMode ' Prüfen auf VB-konformen ScaleMode ' (nur Controls mit ScaleMode 1 bis 7 werden unterstützt!) On Error GoTo 0 ' Fehlerbehandlung wieder ausschalten ' Begrenzungs-Punkte des Control-Rechtecks ermitteln If (Ret > 0) Then ' Nur "Innen-Fläche" (Form, PictureBox) berücksichtigen ' (wo auch MouseMove beginnt). Emöglicht grosse Genauigkeit. P1.X = 0 P1.Y = 0 P2.X = Ctrl.ScaleX(Ctrl.ScaleWidth, Ctrl.ScaleMode, vbPixels) P2.Y = Ctrl.ScaleY(Ctrl.ScaleHeight, Ctrl.ScaleMode, vbPixels) Call ClientToScreen(Ctrl.hwnd, P1) Call ClientToScreen(Ctrl.hwnd, P2) Else Call GetWindowRect(Ctrl.hwnd, CtrlRect) P1.X = CtrlRect.Left P1.Y = CtrlRect.Top P2.X = CtrlRect.Right P2.Y = CtrlRect.Bottom End If Else ' Control ohne HWND ' Eine Prüfung per "WindowFromPoint" gibt bei einem ' Control ohne hWnd das hWnd des Containers zurück. ' Deshalb das Container-hWnd für Überprüfung zuweisen. CompHWND = Ctrl.Container.hwnd Set Cont = Ctrl.Container ' Container-Rechteck ermitteln Call GetWindowRect(Cont.hwnd, ContRect) Ret = 0 ' zurücksetzen! Ret = Cont.ScaleMode ' Prüfen auf VB-konformen ScaleMode ' (nur Container mit ScaleMode 1 bis 7 werden unterstützt!) ' Begrenzungs-Punkte des Control-Rechtecks ermitteln If (Ret > 0) Then ' (Form, PictureBox, ... mit ScaleMode ab 1) P1.X = Cont.ScaleX(Ctrl.Left, Cont.ScaleMode, vbPixels) P1.Y = Cont.ScaleY(Ctrl.Top, Cont.ScaleMode, vbPixels) P2.X = P1.X + Cont.ScaleX(Ctrl.Width, Cont.ScaleMode, vbPixels) P2.Y = P1.Y + Cont.ScaleY(Ctrl.Height, Cont.ScaleMode, vbPixels) Call ClientToScreen(Cont.hwnd, P1) Call ClientToScreen(Cont.hwnd, P2) Else ' (Frame, ... immer mit Twips) P1.X = ContRect.Left + (Ctrl.Left / Screen.TwipsPerPixelX) P1.Y = ContRect.Top + (Ctrl.Top / Screen.TwipsPerPixelY) P2.X = P1.X + (Ctrl.Width / Screen.TwipsPerPixelX) P2.Y = P1.Y + (Ctrl.Height / Screen.TwipsPerPixelY) End If End If ' Die Punkte dem Control-Rechteck zuweisen CtrlRect.Left = P1.X CtrlRect.Top = P1.Y CtrlRect.Right = P2.X CtrlRect.Bottom = P2.Y ' Timer starten (Interval-Angabe in Millisekunden) Call EnableTimer(50) End If End Sub ' Startet den Timer für die MouseInOut-Überwachung Private Sub EnableTimer(ByVal msInterval As Long) If (lEvent = 0) Then lEvent = SetTimer(fForm.hwnd, 44, msInterval, AddressOf TimerProc) End If End Sub ' Timer-Prozedur: löst im Abstand der festgelegten ' Millisekunden die Aktionen für die MouseInOut-States aus. Private Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) Dim CP As POINTAPI If (M_Enter = False) Then ' ************* Maus tritt in das Control ein ************ M_Enter = True ' MouseIn-Routine aufrufen Call DoByMouseIn End If ' Cursor-Position ermitteln Call GetCursorPos(CP) ' - Ist der Cursor innerhalb des Control-Rechtecks? ' - Ist die Form aktiv? ' - Ist das Control von einer inaktiven "OnTop"-Form ' oder "OnTop"-MsgBox teilweise verdeckt? If (PtInRect(CtrlRect, CP.X, CP.Y) _ And (fForm.hwnd = GetForegroundWindow) _ And (WindowFromPoint(CP.X, CP.Y) = CompHWND)) Then ' ************** Maus ist über dem Control *************** ' MouseOver-Routine aufrufen (optional) ' Call DoByMouseOver Else ' ************ Maus hat das Control verlassen ************ DisableTimer M_Enter = False ' MouseOut-Routine aufrufen Call DoByMouseOut End If End Sub ' Beendet den Timer für die MouseInOut-Überwachung Public Sub DisableTimer() If (lEvent <> 0) Then KillTimer fForm.hwnd, lEvent lEvent = 0 End If End Sub ' Auszuführende Aktionen für Maus-Eintritt ("MouseIn") Private Sub DoByMouseIn() On Error Resume Next ' "Pseudo-Ereignis" in der Form aufrufen ' * Wichtige Hinweise für "CallByName" siehe unten! Call CallByName(fForm, Ctrl.Name & "_MouseIn", VbMethod) End Sub ' Auszuführende Aktionen für Maus-Austritt ("MouseOut") Private Sub DoByMouseOut() On Error Resume Next ' "Pseudo-Ereignis" in der Form aufrufen ' * Wichtige Hinweise für "CallByName" siehe unten! Call CallByName(fForm, Ctrl.Name & "_MouseOut", VbMethod) CtrlIndex = -1 'Index als uniniziiert markieren (Optional) End Sub Wichtige Hinweise für "CallByName" Ein solches "Pseudo-Ereignis" besteht aus dem Namen des zu überwachenden Controls (z. B. Label1), plus einem Unterstrich, plus entweder MouseIn oder MouseOut. Beispiele für die Anwendung Beispiel 1 (Label): ' MouseInOut-Überwachung starten Private Sub Label1_MouseMove(Button As Integer, _ Shift As Integer, X As Single, Y As Single) Call MouseInOutTracking(Label1) End Sub ' "Pseudo-Ereignise" ' Maus-Eintritt Public Sub Label1_MouseIn() Label1.ForeColor = vbRed Me.Caption = "Maus befindet sich über Label1" End Sub ' Maus-Austritt Public Sub Label1_MouseOut() Label1.ForeColor = vbBlack Me.Caption = "Außerhalb" End Sub Beispiel 2 (Label-Steuerelementfeld): ' MouseInOut-Überwachung starten Private Sub Label1_MouseMove(Index As Integer, Button As Integer, _ Shift As Integer, X As Single, Y As Single) Call MouseInOutTracking(Label1(Index)) End Sub ' "Pseudo-Ereignise" ' Maus-Eintritt Public Sub Label1_MouseIn() Label1(CtrlIndex).ForeColor = vbRed Me.Caption = "Maus befindet sich über Label1(" & CtrlIndex & ")" End Sub ' Maus-Austritt Public Sub Label1_MouseOut() Label1(CtrlIndex).ForeColor = vbBlack Me.Caption = "Außerhalb" End Sub Dieser Tipp wurde bereits 20.055 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
sevAniGif (VB/VBA) Anzeigen von animierten GIF-Dateien Ab sofort lassen sich auch unter VB6 und VBA (Access ab Version 2000) animierte GIF-Grafiken anzeigen und abspielen, die entweder lokal auf dem System oder auf einem Webserver gespeichert sind. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. Access-Tools Vol.1 Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |