Date-Picker auf Anfrage in einem anderen Forum

[PetrolMaxxe]

Hallo Miteinander,

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.

Gruß Uwe