AW: Textfeld Popup bei Klick auf Datenpunkt im Diagram
10.08.2018 11:38:08
Nepumuk
Hallo Sarah,
nein, das ist nicht ganz korrekt (nur gefühlt).
Ändere den gesamten Code im Modul des UserForms so:
Option Explicit
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" ( _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32.dll" Alias "GetWindowLongPtrA" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32.dll" Alias "SetWindowLongPtrA" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32.dll" Alias "GetWindowLongA" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32.dll" Alias "SetWindowLongA" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
#End If
Private Declare PtrSafe Function DrawMenuBar Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function IsThemeActive Lib "uxtheme.dll" () As Long
Private Const GC_CLASSNAMEMSEXCELFORM = "ThunderDFrame"
Private Const GWL_STYLE = -16&
Private Const WS_CAPTION = &HC00000
Private Const SM_CXSCREEN As Long = 0&
Private Const SM_CYSCREEN As Long = 1&
Private Type POINTAPI
X As Long
Y As Long
End Type
Private hWndForm As Long
Private Sub Label1_Click()
Call Unload(Object:=Me)
End Sub
Private Sub UserForm_Activate()
Dim lngptrHwnd As LongPtr, lngptrStyle As LongPtr
lngptrHwnd = FindWindowA(GC_CLASSNAMEMSEXCELFORM, Caption)
lngptrStyle = GetWindowLongPtr(lngptrHwnd, GWL_STYLE)
lngptrStyle = lngptrStyle And Not WS_CAPTION
Call SetWindowLongPtr(lngptrHwnd, GWL_STYLE, lngptrStyle)
Call DrawMenuBar(lngptrHwnd)
If IsThemeActive = 1 Then
Height = Height - 16
Else
Height = Height - 14
End If
End Sub
Private Sub UserForm_Initialize()
Const CONVERSION_FACTOR As Single = 0.75
Dim udtCursorPos As POINTAPI
Call GetCursorPos(udtCursorPos)
If udtCursorPos.X * CONVERSION_FACTOR + Width > _
GetSystemMetrics(SM_CXSCREEN) * CONVERSION_FACTOR Then
Left = udtCursorPos.X * CONVERSION_FACTOR - Width
Else
Left = udtCursorPos.X * CONVERSION_FACTOR
End If
Top = (udtCursorPos.Y - Height) * CONVERSION_FACTOR
End Sub
Und den Code im Modul ersetzt du mit diesem:
Option Explicit
Option Private Module
Public Sub ShowText(ByVal pvstrChartName As String, ByVal pvlngArgument1 As Long, ByVal pvlngArgument2 As Long)
Dim avntChartnameArray As Variant
Dim strChartname As String
Dim objCell As Range
avntChartnameArray = Split(pvstrChartName, " ")
strChartname = avntChartnameArray(UBound(avntChartnameArray) - 1) & " " & avntChartnameArray(UBound(avntChartnameArray))
Set objCell = Worksheets("Texte").Columns(1).Find(What:=strChartname, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not objCell Is Nothing Then
With frmChartText
.Label1.Caption = objCell.Offset(pvlngArgument2, pvlngArgument1 - 1).Text
Call .Show
End With
Else
Call MsgBox("Keine Texte für Diagramm ''" & strChartname & "'' gefunden.", vbExclamation, "Hinweis")
End If
End Sub
Gruß
Nepumuk