07.02.2024, 11:10
Hallo Forum,
alternativ zur bekannten Methode, ein DropDown-Objekt aus der Datenüberprüfung per Sendkeys automatisch aufzuklappen, hier eine alternative Lösung mit der Maus, sozusagen als virtueller Mitarbeiter....
Beim Code zum Beitrag vom 07.11.2023 mit gleichem Betreff hatte sich noch ein kleiner Klammerfehler eingeschlichen. Fällt nicht auf, so lange die Excelseite nicht gezoomt ist.
Bei gezoomtem Bildschirm wurde die vertikale Mausposition jedoch falsch berechnet, da Excelpixel anstelle von Screenpixel verwendet wurden.
alternativ zur bekannten Methode, ein DropDown-Objekt aus der Datenüberprüfung per Sendkeys automatisch aufzuklappen, hier eine alternative Lösung mit der Maus, sozusagen als virtueller Mitarbeiter....
Beim Code zum Beitrag vom 07.11.2023 mit gleichem Betreff hatte sich noch ein kleiner Klammerfehler eingeschlichen. Fällt nicht auf, so lange die Excelseite nicht gezoomt ist.
Bei gezoomtem Bildschirm wurde die vertikale Mausposition jedoch falsch berechnet, da Excelpixel anstelle von Screenpixel verwendet wurden.
Code:
Option Explicit
Private Declare PtrSafe Function SetCursorPos Lib "user32" ( _
ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare PtrSafe Sub mouse_event Lib "user32" ( _
ByVal dwFlags As Long, _
ByVal dx As Long, ByVal dy As Long, _
ByVal cButtons As Long, ByVal dwExtraInfo As LongPtr)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Datenüberprüfung (Dropdown) automatisch aufklappen
Dim Pt As POINTAPI
On Error GoTo Fehler
' Testen, ob Dropdown vorhanden
If Target.Validation.Type <> xlValidateList Then Exit Sub
With ActiveWindow.ActivePane
GetCursorPos Pt ' Mausposition retten
SetCursorPos .PointsToScreenPixelsX(Target.Offset(1, 1).Left) + 10, _
.PointsToScreenPixelsY(Target.Offset(1, 1).Top) - 10
mouse_event &H6, 0, 0, 0, 0 ' Buttonclick leftdown + leftup
SetCursorPos Pt.x, Pt.y ' Alte Mausposition wiederherstellen
End With
Fehler:
End Sub
Private Declare PtrSafe Function SetCursorPos Lib "user32" ( _
ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare PtrSafe Sub mouse_event Lib "user32" ( _
ByVal dwFlags As Long, _
ByVal dx As Long, ByVal dy As Long, _
ByVal cButtons As Long, ByVal dwExtraInfo As LongPtr)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Datenüberprüfung (Dropdown) automatisch aufklappen
Dim Pt As POINTAPI
On Error GoTo Fehler
' Testen, ob Dropdown vorhanden
If Target.Validation.Type <> xlValidateList Then Exit Sub
With ActiveWindow.ActivePane
GetCursorPos Pt ' Mausposition retten
SetCursorPos .PointsToScreenPixelsX(Target.Offset(1, 1).Left) + 10, _
.PointsToScreenPixelsY(Target.Offset(1, 1).Top) - 10
mouse_event &H6, 0, 0, 0, 0 ' Buttonclick leftdown + leftup
SetCursorPos Pt.x, Pt.y ' Alte Mausposition wiederherstellen
End With
Fehler:
End Sub
_________
viele Grüße
Karl-Heinz
viele Grüße
Karl-Heinz