The original code was found here;

http://www.visual-statement.com/vb/

By:	Ben Baird


Standard Module


Option Explicit

Public 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

Public Type NMHDR
     hwndFrom As Long
     idfrom As Long
     code As Long
End Type

Public Type NMDATETIMECHANGE
     hdr As NMHDR
     gd As Long
     sysTime As SYSTEMTIME
End Type

'All common controls need this call to
'be initialized so they can be used.
Public Declare Function InitCommonControlsEx Lib "Comctl32.dll" _
     (iccex As tagInitCommonControlsEx) As Boolean
Public Type tagInitCommonControlsEx
     lngSize As Long
     lngICC As Long
End Type
'DateTimePicker-specific declarations
Public Const ICC_DATE_CLASSES = &H100&
Public Enum DateTimePickerStyles
    DTS_SHORTDATEFORMAT = &H0 'use the short date format (app must
                              'forward WM_WININICHANGE messages)
    DTS_LONGDATEFORMAT = &H4  'use the long date format (app must
                              'forward WM_WININICHANGE messages)
    DTS_TIMEFORMAT = &H9
End Enum

Public Const DATETIMEPICK_CLASSA = "SysDateTimePick32"

Public Const H_MAX As Long = &HFFFF + 1
Public Const DTN_FIRST = (H_MAX - 760&)
Public Const DTN_DATETIMECHANGE = (DTN_FIRST + 1)

Public Const DTM_FIRST = &H1000
Public Const DTM_GETSYSTEMTIME = (DTM_FIRST + 1)
Public Const DTM_SETSYSTEMTIME = (DTM_FIRST + 2)

'Non control-specific functions we'll need
'for our project.
Public 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
Public Declare Function DestroyWindow Lib "user32" _
     (ByVal hWnd As Long) As Long
Public Declare Function ShowWindow Lib "user32" _
     (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function MoveWindow Lib "user32" _
     (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, _
     ByVal nWidth As Long, ByVal nHeight As Long, _
     ByVal bRepaint As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias _
     "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
     ByVal wParam As Long, lParam As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias _
     "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)

Public Declare Function GetWindowLong Lib "user32" Alias _
     "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias _
     "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, _
     ByVal dwNewLong As Any) As Long
Public Const GWL_WNDPROC = -4
Public Declare Function CallWindowProc Lib "user32" Alias _
     "CallWindowProcA" (ByVal wndrpcPrev As Long, ByVal hWnd As Long, _
     ByVal uMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Const SW_SHOWNORMAL = 1
Public Const WS_VISIBLE = &H10000000
Public Const WS_CHILD = &H40000000

Public Const WM_SIZE = &H5
Public Const WM_NOTIFY = &H4E


Public Function CalCtlProc(ByVal hWnd As Long, _
ByVal uMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
     CalCtlProc = frmTest.WindowProc(hWnd, uMsg, wParam, lParam)
End Function
'--end block--'
   

   Form frmTest.frm  



For this example you will need:
- A CommandButton named cmdToday
- A CheckBox named chkUpDown
- Three OptionButtons named optLongDate, optShortDate, and optTime

Once you have placed these controls, the only
thing left to do is add this code:

Option Explicit 

Private m_NextProc As Long

Private DTPickHwnd As Long
Private m_Date As Date

Private m_DTStyle As DateTimePickerStyles
Private m_DTUpDown As Boolean


Private Sub Form_Load()
     DTPickHwnd = 0

     Dim iccex As tagInitCommonControlsEx
     With iccex
     .lngSize = LenB(iccex)
     .lngICC = ICC_DATE_CLASSES
     End With
     Call InitCommonControlsEx(iccex)

     'Set these before creating to have them
     'take effect.
     m_Date = Now
     m_DTStyle = DTS_LONGDATEFORMAT
     m_DTUpDown = False

     Create
     SubClass
End Sub

Private Sub ChangeDate()
     Dim rtn As Long
     Dim sysTme As SYSTEMTIME

     With sysTme
     .wYear = Year(m_Date)
     .wMonth = Month(m_Date)
     .wDay = Day(m_Date)
     .wHour = Hour(m_Date)
     .wMinute = Minute(m_Date)
     .wSecond = Second(m_Date)
     End With
     rtn = SendMessage(DTPickHwnd, DTM_SETSYSTEMTIME, 0&, sysTme)
End Sub

Private Sub Create()
     Dim Dts As Long

     If DTPickHwnd <> 0 Then
          Call DestroyWindow(DTPickHwnd)
     End If

     Dts = m_DTStyle
     If m_DTUpDown Then
          Dts = (Dts Or &H1)
     End If

     DTPickHwnd = CreateWindowEx(0, DATETIMEPICK_CLASSA, _
          "", WS_CHILD Or WS_VISIBLE Or Dts, _
          0, 0, 0, 0, Me.hWnd, _
          0, App.hInstance, 0)

     Call ShowWindow(DTPickHwnd, SW_SHOWNORMAL)
     Call MoveWindow(DTPickHwnd, 8, cmdToday.Top \ Screen.TwipsPerPixelY, _
          225, 25, True)
     Call ChangeDate
End Sub

Private Sub Date_Change(newDate As Date)
     Me.Caption = Format$(newDate, _
          "Long Time") & "  " & Format(newDate, _
          "Long Date")
End Sub

Private Sub SubClass()
     UnSubClass
     m_NextProc = SetWindowLong(Me.hWnd, _
          GWL_WNDPROC, AddressOf CalCtlProc)
End Sub

Private Sub UnSubClass()
     If m_NextProc Then
          SetWindowLong Me.hWnd, GWL_WNDPROC, m_NextProc
          m_NextProc = 0
     End If
End Sub

Friend Function WindowProc(ByVal hWnd As Long, _
ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
     Dim hdrX As NMDATETIMECHANGE
     On Error Resume Next
     Select Case uMsg
     Case WM_NOTIFY
          CopyMemory hdrX, ByVal lParam, Len(hdrX)
          If hdrX.hdr.code = DTN_DATETIMECHANGE Then
               With hdrX.sysTime
               m_Date = DateSerial(.wYear, .wMonth, .wDay) + _
                    TimeSerial(.wHour, .wMinute, .wSecond)
               End With
               Date_Change m_Date
          End If
     End Select
     WindowProc = CallWindowProc(m_NextProc, hWnd, _
          uMsg, wParam, ByVal lParam)
End Function

Private Sub cmdToday_Click()
     m_Date = Now
     ChangeDate
End Sub

Private Sub chkUpDown_Click()
     m_DTUpDown = -chkUpDown.Value
     UnSubClass
     Create
     SubClass
End Sub

Private Sub optLongDate_Click()
     m_DTStyle = DTS_LONGDATEFORMAT
     UnSubClass
     Create
     SubClass
End Sub

Private Sub optShortDate_Click()
     m_DTStyle = DTS_SHORTDATEFORMAT
     UnSubClass
     Create
     SubClass
End Sub

Private Sub optTime_Click()
     m_DTStyle = DTS_TIMEFORMAT
     UnSubClass
     Create
     SubClass
End Sub

Private Sub Form_Unload(Cancel As Integer)
     UnSubClass
     If DTPickHwnd <> 0 Then
          Call DestroyWindow(DTPickHwnd)
     End If
     DTPickHwnd = 0
End Sub
'--end block--'
   

 Finishing Up 
  
Save, then run the project. There should be a
DateTimePicker control on your form, right where
the illustration on this page shows it to be. When
you choose a date from the control, the form
receives a notification message and changes its
caption to the date that was picked. 

