Hallo Sabina,
das testen des Kalender_DatePicker ist schnell erledigt: Code muss auf 64bit-Umgebung aktualisiert werden, geht also so nicht.
Der StandAlone... geht, war aber nach dem vorigen Beitrag nicht anders zu erwarten.
falls sich jemand für die Umstellung des "Kalender_DatePicker (Material Design-Forum V3)" auf VBA7 interessiert.
API Teil:
Code:
#If VBA7 Then
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "User32.dll" (ByVal hWnd As LongPtr, ByVal crKey As LongPtr, ByVal bAlpha As Byte, ByVal dwFlags As LongPtr) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hWnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal wCmd As Long) As LongPtr
Private Declare PtrSafe Function DwmSetWindowAttribute Lib "dwmapi.dll" (ByVal hWnd As LongPtr, ByVal dwAttribute As Long, ByRef pvAttribute As Long, ByVal cbAttribute As Long) As Long
Private Declare PtrSafe Function DwmExtendFrameIntoClientArea Lib "dwmapi" (ByVal hWnd As LongPtr, ByRef NEWMARGINS As MARGINS) As Long
Private Declare PtrSafe Function ReleaseCapture Lib "user32" () As Long
#Else
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal H_WINDOW As Long, ByVal lngWinIdx As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal H_WINDOW As Long, ByVal lngWinIdx As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal H_WINDOW As Long, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal H_WINDOW As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal H_WINDOW As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal H_WINDOW As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal H_WINDOW As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function DwmSetWindowAttribute Lib "dwmapi" (ByVal hWnd As Long, ByVal attr As Integer, ByRef attrValue As Integer, ByVal attrSize As Integer) As Long
Private Declare Function DwmExtendFrameIntoClientArea Lib "dwmapi" (ByVal hWnd As Long, ByRef NEWMARGINS As MARGINS) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
#End If
und das Activate der Userform:
Code:
Private Sub UserForm_Activate()
#If VBA7 Then
Dim ISTYLE, hWndForm As LongPtr
#Else
Dim ISTYLE, hWndForm As Long
#End If
Dim btrans As Byte
btrans = 128
Dim NEWMARGINS As MARGINS
hWndForm = FindWindow(vbNullString, Me.Caption)
ISTYLE = GetWindowLong(hWndForm, GWL_STYLE)
ISTYLE = ISTYLE And Not WS_CAPTION
SetWindowLong hWndForm, GWL_STYLE, ISTYLE
ISTYLE = GetWindowLong(hWndForm, GWL_EXSTYLE)
ISTYLE = ISTYLE And Not WS_EX_DLGMODALFRAME
SetWindowLong hWndForm, GWL_EXSTYLE, ISTYLE
XWNDFORM = FindWindow("ThunderDFrame", vbNullString)
DwmSetWindowAttribute XWNDFORM, 2, 2, 4
With NEWMARGINS
.rightWidth = 0
.leftWidth = 0
.topHeight = 0.51
.bottomHeight = 0
End With
Me.Width = Me.Width - 11
DwmExtendFrameIntoClientArea XWNDFORM, NEWMARGINS
DrawMenuBar hWndForm
End Sub
Was sich mir nicht erschließt ist der Sinn im MouseMove der Klasse der Labels dieses Abfrageteils: If m_Label.ForeColor <> vbWhite Then
Welchen Grund es dafür auch immer gegeben haben könnte.
Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste
Hinweis auf Angebot
Excel-Inside - lang Keine
Lösung gefunden? Du kannst Dich gerne an
unser erfahrenes Experten-Team
wenden um dein Anliegen zu besprechen. Gerne
erstellen wir auf dieser Basis ein Angebot. Sende deine Anfrage
einfach per
E-Mail an anfrage@excel-inside.de