ダウンロード(「日付入力」のクラス)

VBAが使えるようになると、ユーザーフォームを利用することもあると思います。しかし、ユーザーフォーム上では数値や日付をうまく受け取るコントロールがなく、テキストボックスを使うしかありません。

なんでAPIなの！？「Microsoft Date and Time Picker Control 6.0」を使えばこんな面倒なことは不要だ。
と思っている人もいると思いますが、「Microsoft Date and Time Picker Control 6.0」はVisual Basic 6.0の付属コントロールなので、Visual Basic 6.0がインストールされていない環境でのデザイン利用(2次配布も)はライセンス違反に当たります。
マイクロソフトの見解は「DLLは良いが、OCXはダメ」ということなので、常にプロジェクトを操作できるExcelVBAではマクロの作成元にVisual Basic 6.0がインストールされていても配布利用はできないことになります。
というか、現在ではVisual Basic 6.0自体が入手困難かつインストールできないわけで、古いアプリケーションでもない限り環境ができません。配布先に同じ環境があるなどは全く期待できません。

ここで紹介する方法は、DLLを操作する方法ですからライセンスの問題には抵触しません。但し、コントロール(OCX)を貼り付けて利用するのと違い、プロパティの操作など解明できていないことがたくさんあるので、自由自在に扱えるわけでもありません。

もうひとつの解決策は、ユーザーフォームの持つ機能を組み合わせて使う次ページの「カレンダー入力用フォーム」です。
さらにカレンダー機能を手早く実現できるようにワークシートからの呼び出し専用ですが「カレンダー入力用フォーム：アドイン版」も用意しました。これらは日本の祝日も表示されます。

そこで、「API関連」の「フォーム上でDateTimePickerを利用する。」で説明したDateTimePickerをクラス化してあり、制限はあるものの他にも利用できると思います。

(この画像をクリックすると、ダウンロードができます。)
ダウンロードした圧縮ファイルには、使用する標準モジュール、クラスモジュールとこのページのサンプルのExcelワークブックが収容されています。
このように、ユーザーフォームの日付入力の項目にInternetExplorerの標準コントロールの「DateTimePicker」を利用することができます。
一応、ここでご紹介しますが、いくつか不具合も報告されており、完全なものではありません。利用される場合はご注意下さい。

現在の記述方法では、このクラスを使うユーザーフォームが複数あると正しく動作しません。
グループボックスやタブストリップなどのいわゆる「コンテナ」に載った状態のコントロール(コンボボックス)では正しく動作しません。
初回と2回目以降でフォーカスを受け取った時のコントロールの状態が異なるようです。マウスで操作するのであれば問題ありませんが、キーオペレーションでは、途中でカーソル消失となります。

特にソース上の説明をここではしません(かなり複雑です)が、クラス化できているので他のユーザーフォームにも転用は比較的簡単です。クラスの組み込みだけを説明します。

これはプロジェクトエクスプローラです。※の部分の2つのモジュールが「クラス」とそのクラスで使用するPublic変数を収容した標準モジュール(modDTPickerOnComboBox)です。


'***************************************************************************************************
'   ComboBox上にDateTimePickerを表示させるクラス                modDTPickerOnComboBox(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'03/07/22(2.03)新規作成
'***************************************************************************************************
Option Explicit
Option Base 1       ' ←注
'===================================================================================================
' DateTimePickerが載るTextBoxｵﾌﾞｼﾞｪｸﾄの配列要素数最大値
Public Const g_lngComboBox_Max = 3
' クラスの配列宣言
Public clsDTPCBox(1 To g_lngComboBox_Max) As New clsDTPickerOnComboBox

'***************************************************************************************************
'   ■■■ 公開プロシージャ(Public) ■■■
'***************************************************************************************************
'* 処理名　：GP_DestroyClass_ALL
'* 機能　　：クラスの破棄(全件)
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月22日
'* 作成者　：井上　治
'* 更新日　：2003年07月22日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub GP_DestroyClass_ALL(objForm As UserForm)
    '-----------------------------------------------------------------------------------------------
    Dim IX As Integer
    For IX = 1 To g_lngComboBox_Max
        clsDTPCBox(IX).Destroy
        Set clsDTPCBox(IX) = Nothing
    Next IX
End Sub

'------------------------------------------<< End of Source >>--------------------------------------

この「g_lngComboBox_Max」がクラスのインスタンスを作成する数です。他に利用する場合は、ユーザーフォーム上の日付入力を行なう「台」となるコンボボックスの数に変更して下さい。

続いてユーザーフォームのコードです。これは複数ある場合はそれぞれに記述する必要があります。


'***************************************************************************************************
'   ComboBox上にDateTimePickerを表示させるクラス                UserForm1(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'03/07/22(2.03)新規作成
'***************************************************************************************************
Option Explicit

'***************************************************************************************************
'   ■■■ フォームイベント(Private) ■■■
'***************************************************************************************************
'* 処理名　：UserForm_Initialize
'* 機能　　：フォーム初期化
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月22日
'* 作成者　：井上　治
'* 更新日　：2003年07月22日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub UserForm_Initialize()
    '-----------------------------------------------------------------------------------------------
    Dim colCmbBox As New Collection
    Dim IX As Integer
    ' DTPickerが載るTextBoxのコレクションを作成
    With colCmbBox
        .Add Item:=ComboBox1
        .Add Item:=ComboBox2
        .Add Item:=ComboBox3
    End With
    ' 各コンボボックスを巡回
    For IX = 1 To g_lngComboBox_Max
        ' クラスインスタンス生成
        Set clsDTPCBox(IX) = New clsDTPickerOnComboBox
        With clsDTPCBox(IX)
            .Cmd = colCmbBox(IX)
            .UserForm = Me
            .Create             ' DTPickerを生成
        End With
    Next IX
End Sub

'***************************************************************************************************
'* 処理名　：UserForm_QueryClose
'* 機能　　：フォーム閉鎖動作
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(既定)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月22日
'* 作成者　：井上　治
'* 更新日　：2003年07月22日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    '-----------------------------------------------------------------------------------------------
    ' クラスインスタンス廃棄(全件)
    Call GP_DestroyClass_ALL(Me)
End Sub

'------------------------------------------<< End of Source >>--------------------------------------

①: ユーザーフォーム上のコンボボックスをコレクションに追加してテーブル化します。
②: クラスのインスタンスをテーブルとして生成します。「clsDTPCBox」は上記標準モジュールにPublic変数で宣言しているものです。
③: 「Cmd」「UserForm」はクラスのプロパティ、「Create」はクラスのメソッドです。「Create」でDateTimePickerが生成されます。
④: ユーザーフォームが終了する段階で、クラスのインスタンスを破棄します。「GP_DestroyClass_ALL」は標準モジュールのPublicなプロシージャです。

※サンプルには記述していませんが、実際の日付は、クラスから「Value」プロパティで設定、取得ができます。
クラスモジュール「clsDTPickerOnComboBox.cls」内のコードです。


'***************************************************************************************************
'   ComboBox上にDateTimePickerを表示させるクラス                clsDTPickerOnComboBox(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'03/07/22(2.03)新規作成
'03/07/23(2.03)親コントロールをTextBoxからComboBoxに変更(形が似ているから)
'19/10/28(2.10)Declare記述の変更(64ビット版Excel対応)
'***************************************************************************************************
Option Explicit
'===================================================================================================
' コントロール初期化の指示子
Private Type tagINITCOMMONCONTROLSEX
    dwSize          As Long
    dwICC           As Long
End Type
' コントロールから引き渡される日付時刻構造体
Private Type SYSTEMTIME
    Year            As Integer
    Month           As Integer
    DayOfWeek       As Integer
    Day             As Integer
    Hour            As Integer
    Minute          As Integer
    Second          As Integer
    Milliseconds    As Integer
End Type
' DTM_GETRANGE DTM_SETRANGE用の宣言
Private Type SYSTEMTIMERANGE
    MinYear         As Integer
    MinMonth        As Integer
    MinDayOfWeek    As Integer
    MinDay          As Integer
    MinHour         As Integer
    MinMinute       As Integer
    MinSecond       As Integer
    MinMilliseconds As Integer
    MaxYear         As Integer
    MaxMonth        As Integer
    MaxDayOfWeek    As Integer
    MaxDay          As Integer
    MaxHour         As Integer
    MaxMinute       As Integer
    MaxSecond       As Integer
    MaxMilliseconds As Integer
End Type
'---------------------------------------------------------------------------------------------------
Private Const DATETIMEPICK_CLASS = "SysDateTimePick32"
Private Const ICC_DATE_CLASSES = &H100
Private Const DTS_SHORTDATEFORMAT = &H0             ' YYYY/MM/DD
Private Const DTS_LONGDATEFORMAT = &H4              ' YYYY年MM月DD日
'-------------------------------------------------
Private Const GDT_VALID = 0
Private Const GDTR_MIN = &H1
Private Const GDTR_MAX = &H2
'-------------------------------------------------
Private Const DTM_FIRST = &H1000
Private Const DTM_GETSYSTEMTIME = (DTM_FIRST + 1)   ' ｺﾝﾄﾛｰﾙの日付/時刻を取得
Private Const DTM_SETSYSTEMTIME = (DTM_FIRST + 2)   ' ｺﾝﾄﾛｰﾙの日付/時刻をｾｯﾄ
Private Const DTM_GETRANGE = (DTM_FIRST + 3)        ' ｺﾝﾄﾛｰﾙの日付範囲を取得
Private Const DTM_SETRANGE = (DTM_FIRST + 4)        ' ｺﾝﾄﾛｰﾙの日付範囲を設定
Private Const DTM_SETFORMAT = (DTM_FIRST + 5)       ' ｺﾝﾄﾛｰﾙに整形文字列をｾｯﾄ
Private Const DTM_SETMCCOLOR = (DTM_FIRST + 6)      ' ﾄﾞﾛｯﾌﾟｶﾚﾝﾀﾞｰの色を取得
Private Const DTM_GETMCCOLOR = (DTM_FIRST + 7)      ' ﾄﾞﾛｯﾌﾟｶﾚﾝﾀﾞｰの色を設定
Private Const DTM_GETMONTHCAL = (DTM_FIRST + 8)     ' ﾄﾞﾛｯﾌﾟｶﾚﾝﾀﾞｰのｳｨﾝﾄﾞｳﾊﾝﾄﾞﾙを取得
Private Const DTM_SETMCFONT = (DTM_FIRST + 9)       ' ｺﾝﾄﾛｰﾙのﾌｫﾝﾄをｾｯﾄ
Private Const DTM_GETMCFONT = (DTM_FIRST + 10)      ' ｺﾝﾄﾛｰﾙのﾌｫﾝﾄを取得
'-------------------------------------------------
Private Const MCSC_BACKGROUND = 0                   ' 月間背景色を指定
Private Const MCSC_TEXT = 1                         ' 選択日付の色
Private Const MCSC_TITLEBK = 2                      ' ﾀｲﾄﾙﾊﾞｰの背景色
Private Const MCSC_TITLETEXT = 3                    ' ﾀｲﾄﾙﾊﾞｰのﾃｷｽﾄ色
Private Const MCSC_MONTHBK = 4                      ' ｶﾚﾝﾀﾞｰの背景色
Private Const MCSC_TRAILINGTEXT = 5                 ' ｶﾚﾝﾀﾞｰの非選択日付のﾃｷｽﾄ色
'-------------------------------------------------
Private Const LOGPIXELSX = 88                       ' ﾎﾟｲﾝﾄ→ﾋﾟｸｾﾙ変換指定(横)
Private Const LOGPIXELSY = 90                       ' ﾎﾟｲﾝﾄ→ﾋﾟｸｾﾙ変換指定(縦)
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
'===================================================================================================
#If VBA7 Then
' コモンコントロールの初期化API
Private Declare PtrSafe Function InitCommonControlsEx Lib "ComCtl32.dll" _
    (LPINITCOMMONCONTROLSEX As Any) As Long
' ウィンドウハンドル取得API
Private Declare PtrSafe Function FindWindow Lib "USER32.dll" _
    Alias "FindWindowA" _
    (ByVal lpClassName As String, _
     ByVal lpWindowName As String) As LongPtr
' 拡張ウィンドウハンドル取得API
Private Declare PtrSafe Function FindWindowEx Lib "USER32.dll" _
    Alias "FindWindowExA" _
    (ByVal hwndParent As LongPtr, _
     ByVal hwndChildAfter As LongPtr, _
     ByVal lpszClass As String, _
     ByVal lpszWindow As String) As LongPtr
' ポイント→ピクセル変換係数取得API
Private Declare PtrSafe Function GetDeviceCaps Lib "GDI32.dll" _
    (ByVal hDC As LongPtr, _
     ByVal nIndex As Long) As Long
' アプリケーションのインスタンスを取得
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32.dll" _
            Alias "GetWindowLongPtrA" _
            (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32.dll" _
            Alias "GetWindowLongA" _
            (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #End If
' DeskTopWindow取得
Private Declare PtrSafe Function GetDesktopWindow Lib "USER32.dll" () As LongPtr
' デバイスコンテキスト取得
Private Declare PtrSafe Function GetDC Lib "USER32.dll" _
    (ByVal hWnd As LongPtr) As LongPtr
' デバイスコンテキスト解放
Private Declare PtrSafe Function ReleaseDC Lib "USER32.dll" _
    (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
' ウィンドウの作成(今回はDTPickerを作成)
Private Declare PtrSafe 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 LongPtr, _
     ByVal hMenu As LongPtr, _
     ByVal hInstance As LongPtr, _
     ByRef lpParam As Any) As LongPtr
' ウィンドウコントロールの操作
Private Declare PtrSafe Function SendMessage Lib "USER32.dll" _
    Alias "SendMessageA" _
    (ByVal hWnd As LongPtr, _
     ByVal wMsg As Long, _
     ByVal wParam As LongPtr, _
     ByRef lParam As Any) As LongPtr
' ウィンドウの移動､拡縮(現在､未使用)
Private Declare PtrSafe Function MoveWindow Lib "USER32.dll" _
    (ByVal hWnd As LongPtr, _
     ByVal X As Long, _
     ByVal Y As Long, _
     ByVal nWidth As Long, _
     ByVal nHeight As Long, _
     ByVal bRepaint As Long) As Long
' ウィンドウの撤去
Private Declare PtrSafe Function DestroyWindow Lib "USER32.dll" _
    (ByVal hWnd As LongPtr) As Long
' ウィンドウが作成されているかの判定
Private Declare PtrSafe Function IsWindow Lib "USER32.dll" _
    (ByVal hWnd As LongPtr) As Long
' Tabキー等でのフォーカス操作
Private Declare PtrSafe Function SetFocus Lib "USER32.dll" _
    (ByVal hWnd As LongPtr) As Long
#Else
' コモンコントロールの初期化API
Private Declare Function InitCommonControlsEx Lib "ComCtl32.dll" _
    (LPINITCOMMONCONTROLSEX As Any) As Long
' ウィンドウハンドル取得API
Private Declare Function FindWindow Lib "USER32.dll" _
    Alias "FindWindowA" _
    (ByVal lpClassName As String, _
     ByVal lpWindowName As String) As Long
' 拡張ウィンドウハンドル取得API
Private Declare Function FindWindowEx Lib "USER32.dll" _
    Alias "FindWindowExA" _
    (ByVal hwndParent As Long, _
     ByVal hwndChildAfter As Long, _
     ByVal lpszClass As String, _
     ByVal lpszWindow As String) As Long
' ポイント→ピクセル変換係数取得API
Private Declare Function GetDeviceCaps Lib "GDI32.dll" _
    (ByVal hDC As Long, _
     ByVal nIndex As Long) As Long
' アプリケーションのインスタンスを取得
Private Declare Function GetWindowLong Lib "USER32.dll" _
    Alias "GetWindowLongA" _
    (ByVal hWnd As Long, _
     ByVal nIndex As Long) As Long
' DeskTopWindow取得
Private Declare Function GetDesktopWindow Lib "USER32.dll" () As Long
' デバイスコンテキスト取得
Private Declare Function GetDC Lib "USER32.dll" _
    (ByVal hWnd As Long) As Long
' デバイスコンテキスト解放
Private Declare Function ReleaseDC Lib "USER32.dll" _
    (ByVal hWnd As Long, ByVal hDC As Long) As Long
' ウィンドウの作成(今回はDTPickerを作成)
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 SendMessage Lib "USER32.dll" _
    Alias "SendMessageA" _
    (ByVal hWnd As Long, _
     ByVal wMsg As Long, _
     ByVal wParam As Long, _
     ByRef lParam As Any) As Long
' ウィンドウの移動､拡縮(現在､未使用)
Private Declare Function MoveWindow Lib "USER32.dll" _
    (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
' ウィンドウの撤去
Private Declare Function DestroyWindow Lib "USER32.dll" _
    (ByVal hWnd As Long) As Long
' ウィンドウが作成されているかの判定
Private Declare Function IsWindow Lib "USER32.dll" _
    (ByVal hWnd As Long) As Long
' Tabキー等でのフォーカス操作
Private Declare Function SetFocus Lib "USER32.dll" _
    (ByVal hWnd As Long) As Long
#End If
'-------------------------------------------------
' クラスモジュール内で使う変数の宣言(実行中固定)
Private mctlForm  As UserForm                       ' 呼出元UserForm
Private WithEvents mctlComboBox As MSForms.ComboBox ' 呼出元ComboBox
Attribute mctlComboBox.VB_VarHelpID = -1
Private lngPixelsX As Long                          ' ポイント→ピクセル係数(横)
Private lngPixelsY As Long                          ' ポイント→ピクセル係数(縦)
#If VBA7 Then
Private mlnghwndDateTime As LongPtr                 ' DateTimeのウィンドウハンドル
Private lnghWnd_Excel As LongPtr                    ' Excelのウィンドウハンドル
Private lnghWnd_Form As LongPtr                     ' フォームのウィンドウハンドル
#Else
Private mlnghwndDateTime As Long                    ' DateTimeのウィンドウハンドル
Private lnghWnd_Excel As Long                       ' Excelのウィンドウハンドル
Private lnghWnd_Form As Long                        ' フォームのウィンドウハンドル
#End If

'***************************************************************************************************
'   ■■■ 公開プロパティ(Public) ■■■
'***************************************************************************************************
' Cmd(MSForms.ComboBox)
'---------------------------------------------------------------------------------------------------
Public Property Get Cmd() As MSForms.ComboBox
    Set Cmd = mctlComboBox
End Property

Public Property Let Cmd(ctlNewComboBox As MSForms.ComboBox)
    Set mctlComboBox = ctlNewComboBox
End Property

'===================================================================================================
' UserForm(UserForm)
'---------------------------------------------------------------------------------------------------
Public Property Get UserForm() As UserForm
    Set UserForm = mctlForm
End Property

Public Property Let UserForm(ctlNewUserForm As UserForm)
    Set mctlForm = ctlNewUserForm
End Property

'===================================================================================================
' Value(Date)
'---------------------------------------------------------------------------------------------------
Public Property Get Value() As Date
    Dim st As SYSTEMTIME
    Dim lngResult As Long
    lngResult = SendMessage(mlnghwndDateTime, _
        DTM_GETSYSTEMTIME, 0, st)
    With st
        Value = DateSerial(.Year, .Month, .Day)
    End With
End Property

Public Property Let Value(dtmNewValue As Date)
    Dim lngResult As Long
    Dim st As SYSTEMTIME
    ' SYSTEMTIME構造体に引数の日付時間を分解して代入。
    With st
        .Year = Year(dtmNewValue)
        .Month = Month(dtmNewValue)
        .Day = Day(dtmNewValue)
        .DayOfWeek = Weekday(dtmNewValue) - 1  ' APIでは日曜日が0
        .Hour = 0
        .Minute = 0
        .Second = 0
    End With
    lngResult = SendMessage(mlnghwndDateTime, _
        DTM_SETSYSTEMTIME, GDT_VALID, st)
End Property

'***************************************************************************************************
'   ■■■ 公開メソッド(Public) ■■■
'***************************************************************************************************
'* 処理名　：Create
'* 機能　　：カレンダー生成
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月22日
'* 作成者　：井上　治
'* 更新日　：2019年10月28日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub Create()
    '-----------------------------------------------------------------------------------------------
    Dim icce            As tagINITCOMMONCONTROLSEX
    Dim lngResult       As Long
#If VBA7 Then
    Dim lnghInstance    As LongPtr
    Dim lnghWnd_Sub     As LongPtr
#Else
    Dim lnghInstance    As Long
    Dim lnghWnd_Sub     As Long
#End If
    Dim strThunder      As String
    ' Excelのバージョン
    If Val(Application.Version) <= 8 Then
        strThunder = "ThunderXFrame"        ' Excel97
    Else
        strThunder = "ThunderDFrame"        ' Excel2000～
    End If
    ' 既にウィンドウが存在する場合はウィンドウの破棄
    If IsWindow(mlnghwndDateTime) <> 0 Then
        Call DestroyWindow(mlnghwndDateTime)
    End If
    ' INITCOMMONCONTROLSEX構造体に値を代入
    With icce
        .dwICC = ICC_DATE_CLASSES
        .dwSize = Len(icce)
    End With
    ' コモンコントロールを初期化
    lngResult = InitCommonControlsEx(icce)
    ' ユーザーフォームのHWNDの取得
    lnghWnd_Form = FindWindow(strThunder, mctlForm.Caption)
    If lnghWnd_Form = 0 Then Exit Sub
    ' ポイント→ピクセル変換係数算出
    Call GetLogPixelsXY
    ' ウィンドウハンドル取得
    lnghWnd_Excel = FindWindow("XLMAIN", Application.Caption)
#If VBA7 Then
    lnghInstance = GetWindowLongPtr(lnghWnd_Excel, GWL_HINSTANCE)
#Else
    lnghInstance = GetWindowLong(lnghWnd_Excel, GWL_HINSTANCE)
#End If
    ' 透明ウィンドウのHWNDの取得
    lnghWnd_Sub = FindWindowEx(lnghWnd_Form, 0&, vbNullString, vbNullString)
    ' ComboBoxコントロール上にDateTimePickerの作成(DTS_SHORTDATEFORMAT)
    mlnghwndDateTime = CreateWindowEx(0&, DATETIMEPICK_CLASS, vbNullString, _
        WS_CHILD Or WS_VISIBLE Or DTS_SHORTDATEFORMAT, _
        mctlComboBox.Left * lngPixelsX / 72, mctlComboBox.Top * lngPixelsY / 72, _
        mctlComboBox.Width * lngPixelsX / 72, mctlComboBox.Height * lngPixelsY / 72, _
        lnghWnd_Sub, 0&, lnghInstance, vbNullString)    ' Short(yyyy/mm/dd)
End Sub

'***************************************************************************************************
'* 処理名　：GotFocus
'* 機能　　：フォーカスセット
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月22日
'* 作成者　：井上　治
'* 更新日　：2019年10月28日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub GotFocus()
    '-----------------------------------------------------------------------------------------------
    ' ComboBoxにフォーカスが移るタイミングで、DateTimePickerにフォーカスを移す
    Call SetFocus(mlnghwndDateTime)
End Sub

'***************************************************************************************************
'* 処理名　：Destroy
'* 機能　　：ウィンドウ破棄
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月22日
'* 作成者　：井上　治
'* 更新日　：2019年10月28日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub Destroy()
    '-----------------------------------------------------------------------------------------------
    ' ウィンドウ破棄(クラス終了イベント呼び出し)
    Call Class_Terminate
End Sub

'***************************************************************************************************
'   ■■■ イベント(Private) ■■■
'***************************************************************************************************
'* 処理名　：Class_Initialize
'* 機能　　：クラス初期化
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月22日
'* 作成者　：井上　治
'* 更新日　：2019年10月28日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub Class_Initialize()
    '-----------------------------------------------------------------------------------------------
    ' クラスの内の変数の初期値
    mlnghwndDateTime = 0
End Sub

'***************************************************************************************************
'* 処理名　：Class_Terminate
'* 機能　　：クラス終了
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月22日
'* 作成者　：井上　治
'* 更新日　：2019年10月28日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub Class_Terminate()
    '-----------------------------------------------------------------------------------------------
    ' ウィンドウが存在する場合ウィンドウの破棄
    If IsWindow(mlnghwndDateTime) <> 0 Then
        Call DestroyWindow(mlnghwndDateTime)
    End If
End Sub

'***************************************************************************************************
'* 処理名　：mctlComboBox_KeyUp
'* 機能　　：コンボボックスのKeyUpイベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月22日
'* 作成者　：井上　治
'* 更新日　：2019年10月28日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub mctlComboBox_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    '-----------------------------------------------------------------------------------------------
    ' Tabｷｰ時はDateTimePickerにフォーカスを移す
    If KeyCode = 9 Then Call SetFocus(mlnghwndDateTime)
End Sub

'***************************************************************************************************
'   ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名　：GetLogPixelsXY
'* 機能　　：画面精細度のポイント→ピクセル変換係数算出
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2003年07月22日
'* 作成者　：井上　治
'* 更新日　：2019年10月28日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub GetLogPixelsXY()
    '-----------------------------------------------------------------------------------------------
#If VBA7 Then
     Dim lnghwnd As LongPtr
     Dim lngDC As LongPtr
#Else
     Dim lnghwnd As Long
     Dim lngDC As Long
#End If
     'GetDCを使った後は、必ずReleaseDCで元に戻す。
     '画面表示用の専用メモリ(リソース)が消費され、
     '最後はWindowsがハングアップする危険があります。
     lnghwnd = GetDesktopWindow()
     lngDC = GetDC(lnghwnd)
     lngPixelsX = GetDeviceCaps(lngDC, LOGPIXELSX)
     lngPixelsY = GetDeviceCaps(lngDC, LOGPIXELSY)
     ReleaseDC lnghwnd, lngDC
End Sub

'------------------------------------------<< End of Source >>--------------------------------------

←DTPickerClass.zip
(42KB)

※ここで紹介した方法を元にして、フォントの変更などを実現したのが、角田さん(AddinBox)の「API で DTPicker コントロールを利用する」です。