AW: Shape langsam vergrößern
19.12.2021 09:29:09
volti
Hallo Jens,
hier mal der Code für ein Beispiel zur Verbreiterung von Shapes bei Mouseover. Ist auch kommentiert.....
Habe ich auch in der anliegenden Datei eingebaut.
Bitte unbedingt beachten, dass über Code in "DieseArbeitsmappe" und in dem Tabellenmodul das Mousehooking auch wieder ausgeschaltet werden muss.
Mouseoverbeispiel
Code:
[Cc][+][-]
Option Explicit
Public Const bNoMouseHooking = False ' Zum Bearbeiten des VBA-Codes auf True setzen
Private Type POINTAPI
X As Long
Y As Long
End Type
Dim Pt As POINTAPI
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Dim R As RECT
Private Declare PtrSafe Function SetWindowsHookExA Lib "user32" ( _
ByVal idHook As Long, ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As LongPtr, ByVal nCode As Long, _
ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" ( _
ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function ScreenToClient Lib "user32" ( _
ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Dim hHook As LongPtr
Dim oActShp As Object
Const WM_MOUSEMOVE = &H200
Const WM_LBUTTONDOWN = &H201
Const HC_ACTION = &H0
Const WH_MOUSE_LL = 14
Const ciZuklapp As Integer = 20 ' Startbreite <<<anpassen>>
Const ciAufklapp As Integer = 100 ' Aufklappbreite <<<anpassen>>
Sub MausAus()
' Beendet den Mousehook
UnhookWindowsHookEx hHook: hHook = 0
End Sub
Sub MausAn()
' Baut den Mousehook auf
If bNoMouseHooking = True Then Call MausAus: Exit Sub
If hHook = 0 Then
hHook = SetWindowsHookExA(WH_MOUSE_LL, AddressOf MouseProc, _
Application.HinstancePtr, 0)
End If
End Sub
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, _
lParam As LongPtr) As LongPtr
Dim oCurObj As Object
If nCode = HC_ACTION Then
GetCursorPos Pt
Select Case wParam
Case WM_LBUTTONDOWN ' Abschalten über Caption-Kreuz
ScreenToClient Application.hwnd, Pt ' Punkt auf Bildschirm umrechnen
GetWindowRect Application.hwnd, R ' Kreuz-Rechteck holen
If Pt.X < R.Right And Pt.X > (R.Right - 68) And _
Pt.Y > R.Top And Pt.Y < R.Top + 50 Then
Call MausAus ' Mouseover abschalten
End If
Case WM_MOUSEMOVE
On Error Resume Next
Set oCurObj = ActiveWindow.RangeFromPoint(Pt.X, Pt.Y)
If Err <> 0 Then Exit Function ' Fehler => raus
Select Case TypeName(oCurObj)
Case "Nothing" ' Außerhalb des Tabellenbereichs
Case "Range" ' Maus im Rangebereich
If Not oActShp Is Nothing Then
oActShp.Width = ciZuklapp
Set oActShp = Nothing
Application.Cursor = xlDefault ' Cursor zurükcsetzen
End If
Case "OLEObject" ' Nicht zu verarbeitende Objekte
Case Else ' Maus über einem Shape
If oCurObj.Name Like "Balken*" Then
If oActShp Is Nothing Then
oCurObj.Width = ciAufklapp
Application.Cursor = xlNorthwestArrow
ElseIf oActShp.Name <> oCurObj.Name Then
oCurObj.Width = ciAufklapp
oActShp.Width = ciZuklapp
Application.Cursor = xlDefault ' Cursor zurücksetzen
End If
Set oActShp = oCurObj
End If
End Select
End Select
Exit Function
End If
' Mousevent an nächsten Prozess weiterreichen
MouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function
_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz