VB - Dropdown the calendar of a date time picker control using code

[RobDog888]

Using APIs you can dropdown a combo box, but I couldn't find any
code on showing the calendar on a date time picker. So I wrote
this small piece of code. Just pass the date time picker you want
to open. The code can be put in a module, but you need to pass
the form name also.

How it works -
I save the mouse position and move it to the date time picker
control and position it so it will be ready to click on the dropdown
arrow button. Then I use the mouse_event API to send the
mouse click. After that I return the mouse to its original position.
The mouse coordinates need to be converted to absolute
coordinates instead of realitive to the form.

The code to save the mouse position and return it back to
the original position can be modified to leave the mouse on the
date time picker control.

The date time picker control can be added to a project by clicking -
Projects > Components > and select Microsoft Windows Common
Controls-2 6.0 (SP4).

ex. usage.
All code behind a form - then behind the form.
Call ClickOnDTP(dtpDueDate)

All code in a module - then behind the form.
Call ClickOnDTP(frmTasks.dtpDueDate)

Let me know what you think.
Enjoy.

Option Explicit
'<07/01/2003 - VB/OUTLOOK GURU>
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, _
ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)

Public Type POINTAPI
    x As Long
    y As Long
End Type

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long

Public Const MOUSEEVENTF_ABSOLUTE = &H8000
Public Const MOUSEEVENTF_MOVE = &H1
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const SM_CXSCREEN = 0 'X Size of screen
Public Const SM_CYSCREEN = 1 'Y Size of Screen

Public Function ClickOnDTP(ByVal dtpCalendar As DTPicker)
'<RR 07/01/2003 VB/OUTLOOK GURU>
    Dim rDTP As RECT
    Dim p As POINTAPI
    Dim oldP As POINTAPI
    Dim oldX As Long
    Dim oldY As Long
    
    dtpCalendar.SetFocus
    Call GetWindowRect(dtpCalendar.hwnd, rDTP)
    Call GetCursorPos(oldP)
    oldX = oldP.x
    oldY = oldP.y
    p.x = (rDTP.Right - 5)
    p.y = ((rDTP.Bottom - rDTP.Top) / 2) + rDTP.Top
    Call ScreenToAbsolute(p)
    Call mouse_event(MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE Or MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, p.x, p.y, 0&, 0&)
    Call SetCursorPos(oldX, oldY)

End Function

Public Sub ScreenToAbsolute(lpPoint As POINTAPI)
'<RR 07/01/2003 - VB/OUTLOOK GURU>
    lpPoint.x = lpPoint.x * (&HFFFF& / GetSystemMetrics(SM_CXSCREEN))
    lpPoint.y = lpPoint.y * (&HFFFF& / GetSystemMetrics(SM_CYSCREEN))
End Sub

[Krool]

It can be done easier

Option Explicit
Private Const VK_DOWN As Long = &H28
Private Const WM_SYSKEYDOWN As Long = &H104

Private Declare Function SendMessage Lib "user32.dll" _
                         Alias "SendMessageA" ( _
                         ByVal hWnd As Long, _
                         ByVal wMsg As Long, _
                         ByVal wParam As Long, _
                         ByVal lParam As Long) As Long
                         
Private Sub Command1_Click()
Call SendMessage(DTPicker1.hWnd, WM_SYSKEYDOWN, VK_DOWN, 0)  
End Sub

[RobDog888]

Nice! Thanks