Из TextBox в DTPicker, некорректное закрытие

[GSerg]

Вставляем это в форму.

Код: Выделить всё

Option Explicit

Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (ByRef TLPINITCOMMONCONTROLSEX As tagINITCOMMONCONTROLSEX) As Long

Private Const WS_CHILD As Long = &H40000000
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_BORDER As Long = &H800000

Private Type tagINITCOMMONCONTROLSEX
  dwSize As Long
  dwICC As Long
End Type

Private Sub Form_Load()
  Dim ic As tagINITCOMMONCONTROLSEX
 
  ic.dwSize = Len(ic)
  ic.dwICC = 256 'ICC_DATE_CLASSES
  InitCommonControlsEx ic
 
  Me.Width = Me.ScaleX(400, vbPixels, vbTwips)
  Me.Height = Me.ScaleY(300, vbPixels, vbTwips)
  Me.ScaleMode = vbPixels
 
  CreateWindowEx 0, "SysDateTimePick32", vbNullString, WS_CHILD Or WS_VISIBLE, 10, 10, 150, 20, Me.hWnd, 0, 0, ByVal 0&
  CreateWindowEx 0, "EDIT", "API TextBox", WS_CHILD Or WS_VISIBLE Or WS_BORDER, 10, 40, 150, 20, Me.hWnd, 0, 0, ByVal 0&
 
  With Me.Controls.Add("VB.TextBox", "txtTest")
    .Move 200, 10, 150, 20
    .Text = "VB TextBox"
    .Visible = True
  End With
End Sub

Поставьте фокус на API TextBox. А теперь кликните по стрелке DTPicker'а. Всё нормально.

Теперь поставьте фокус на VB TextBox. Кликните по стрелке DTPicker'а. Стрелка нажмётся, но окно не откроется. Вернее, оно откроется, но тут же закроется. Кликните ещё раз по стрелке. Рано или поздно окно начнёт появляться нормально.

При переходе на DTPicker с других элементов, таких как ComboBox, эффекта не наблюдается, хотя ComboBox содержит в себе тот же TextBox.
В определённых сложных случаях (MDI-интерфейс, на форме фреймы и гриды) эффект становится неприемлемо ужасным, календарь зарывается всегда, сколько ни кликай.

Кто-нибудь знает, почему это происходит и как от этого избавиться?

[A.A.Z.]

Не пробовал, но может поставить обработку событий SysDateTimePick32 и в момент нажатия переводить фокус на что-то другое, а затем обратно?

[GSerg]

Ууууу, что я только не делал...

[A.A.Z.]

И что, все равно то же самое?

[GSerg]

Да, неисповедимы пути Microsoft...

Месяц пытался понять, почему всё происходит так, как происходит. Тёмыча в аське доставал. Плюнул, переделал свой проект на CommCtl.ocx-овский DTPicker.

Потом чё-то стукнуло в голову, сделал так.

Код: Выделить всё

  Private Function ISubclass_Callback(ByVal hWnd As Long, uMsg As Long, wParam As Long, lParam As Long, ByVal PrevProc As Long) As Long
    Dim t As Long, p As POINT, r As RECT
    Static PrevDate As Date
   
    Const WM_NOTIFY As Long = &H4E&
    Const WM_MOUSEACTIVATE As Long = &H21&
    Const WM_LBUTTONDOWN As Long = &H201&

    Const MA_ACTIVATE As Long = 1
    Const MA_ACTIVATEANDEAT As Long = 2
   
    Const SM_CXVSCROLL As Long = 2
   
    Select Case hWnd
    Case h
      If uMsg = WM_MOUSEACTIVATE Then
        If Not UserControl.Parent.ActiveControl Is Me Then
          UserControl.SetFocus
         
          GetCursorPos p
          ScreenToClient h, p
         
          GetClientRect h, r
         
          If p.x >= r.Right - GetSystemMetrics(SM_CXVSCROLL) Then
            'Кликнули по стрелке
            ISubclass_Callback = MA_ACTIVATEANDEAT
            PostMessage h, WM_LBUTTONDOWN, 0, ByVal p.x Or (p.y * &H10000)
          Else
            'Кликнули по полю
            ISubclass_Callback = MA_ACTIVATE
          End If
        End If
      Else
        ISubclass_Callback = SubClasser.CallWindowProc(PrevProc, hWnd, uMsg, wParam, lParam)
      End If
    Case UserControl.hWnd
      If uMsg = WM_NOTIFY Then
        GetMem4 lParam + 8, VarPtr(t)
       
        Select Case t
        Case DTN_DATETIMECHANGE
          If Me.Value <> PrevDate Then
            PrevDate = Me.Value
            RaiseEvent Change
          End If
          ISubclass_Callback = 0
        Case DTN_DROPDOWN
          RaiseEvent DropDown
          ISubclass_Callback = 0
        Case DTN_CLOSEUP
          RaiseEvent CloseUp
          ISubclass_Callback = 0
        Case Else
          ISubclass_Callback = SubClasser.CallWindowProc(PrevProc, hWnd, uMsg, wParam, lParam)
        End Select
      Else
        ISubclass_Callback = SubClasser.CallWindowProc(PrevProc, hWnd, uMsg, wParam, lParam)
      End If
    Case Else
      ISubclass_Callback = SubClasser.CallWindowProc(PrevProc, hWnd, uMsg, wParam, lParam)
    End Select
   
  End Function

Работает.

Кто будет писать свой DTPicker - учтите этот момент. Из-за того, что TextBox плохо отдаёт фокус, приходится так вот извращаться