VBA Date Picker

I often work within the suffocating constraints of VBA (in my case, a derivative called WinWrap), and the control set is fairly limited.

I often poke around in the Windows API looking for better ways to do things, and today I put together some old code and set up a routine to display a date picker control on a dialog – and was almost surprised when it worked.

The trick is to use CreateWindowEx to create the date control, and SendMessage to set and read the value, with the rest just being VBA/API plumbing.

Note that the code below expects pixel coordinates for the control position instead of the funky values used by WinWrap.

Here’s the complete source:

Option Explicit
Private Type SYSTEMTIME
   wYear As Integer
   wMonth As Integer
   wDayOfWeek As Integer
   wDay As Integer
   wHour As Integer
   wMinute As Integer
   wSecond As Integer
   wMilliseconds As Integer
End Type

Declare Function CreateWindowEx Lib "user32" 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, _
      lpParam As Any) As Long

Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As SYSTEMTIME) As Long

Private Const DTM_GETSYSTEMTIME As Long = &H1001
Private Const DTM_SETSYSTEMTIME As Long = &H1002
Private Const DATETIMEPICK_CLASS = "SysDateTimePick32"
Private Const WS_BORDER As Long = &H800000
Private Const WS_CHILD As Long = 1073741824
Private Const WS_VISIBLE As Long = 268435456

Private hWndDatePicker As Long

Sub Main
   Begin Dialog UserDialog 160,77,.evMain ' %GRID:10,7,1,1
      OKButton 40,42,90,21
   End Dialog
   Dim dlg As UserDialog
   Dialog dlg
End Sub

Rem See DialogFunc help topic for more information.
Private Function evMain(DlgItem$, Action%, SuppValue?) As Boolean
   Select Case Action%
   Case 1 ' Dialog box initialization
      hWndDatePicker = CreateDateControl SuppValue&, 10, 10, 100, 25
      SetDateControl hWndDatePicker, #12/25/2012#
    Case 2 ' Value changing or button pressed
      Dim pickedDate As Date
      pickedDate = ReadDateControl(hWndDatePicker)
      MsgBox "You selected: " + CStr(pickedDate)
       DestroyWindow hWndDatePicker
      Rem evMain = True ' Prevent button press from closing the dialog box
   Case 3 ' TextBox or ComboBox text changed
   Case 4 ' Focus changed
   Case 5 ' Idle
      Rem Wait .1 : evMain = True ' Continue getting idle actions
   Case 6 ' Function key
   End Select
End Function

Sub SetDateControl(ControlHWnd As Long, AValue As Date)
   Dim wMsg As Long
   Dim wParam As Long
   Dim lParam As SYSTEMTIME
   Dim result As Long

   wMsg = DTM_SETSYSTEMTIME
   wParam = 0
   With lParam
      .wYear = Year(AValue)
      .wMonth = Month(AValue)
      .wDay = Day(AValue)
      .wHour = Hour(AValue)
      .wMinute = Minute(AValue)
      .wSecond = Second(AValue)
      .wMilliseconds = 0      'not supported in Date type
   End With

   SendMessage(hWndDatePicker, wMsg, wParam, lParam)
End Sub

Function ReadDateControl(ControlHWnd As Long) As Date
   Dim wMsg As Long
   Dim wParam As Long
   Dim lParam As SYSTEMTIME
   Dim result As Long

   wMsg = DTM_GETSYSTEMTIME
   wParam = 0
   SendMessage(hWndDatePicker, wMsg, wParam, lParam)
   With lParam
      result = CDate(CStr(.wMonth) + "/" + CStr(.wDay) + "/" + CStr(.wYear))
   End With
   ReadDateControl = result
End Function

Function CreateDateControl(DlgHWnd As Long, AX As Long, AY As Long, ADX As Long, ADY As Long) As Long
   Dim dwExStyle As Long
   Dim lpClassName As String
    Dim lpWindowName As String
    Dim dwStyle As Long
    Dim x As Long
    Dim y As Long
    Dim nWidth As Long
    Dim nHeight As Long
    Dim hWndParent As Long
    Dim hMenu As Long
    Dim hInstance As Long
    Dim lpParam As Long

   dwExStyle = 0
   lpClassName = DATETIMEPICK_CLASS
   lpWindowName = ""
   dwStyle = WS_BORDER Or WS_CHILD Or WS_VISIBLE
   hWndParent = DlgHWnd
   hMenu = vbNull
   hInstance = MainFormHandle
   lpParam = vbNull
   CreateDateControl = CreateWindowEx(dwExStyle, lpClassName, lpWindowName, dwStyle, AX, AY, ADX, ADY, hWndParent, hMenu, hInstance, lpParam)
End Function