「カレンダー入力」用フォーム

日付の入力形式の統一や、正しい日付を入力させるにはどうすれば良いでしょう。
カレンダー表示から日付を選択することで日付を入力するものです。   この前のページで「日付入力」のクラスを紹介しましたが、プロパティ操作ができない状態だし、APIだらけなので導入には抵抗があると思います。 「Visual Basic 6.0」時代のものなのでかなり古く、現在には合いません。
昔はOfficeに「カレンダーコントロール」があったのですが、Accessがインストールされていないと動かないし、Office2010からは廃止されたので Microsoftのサポートが現存するバージョンでは利用できないものとなりました。



このページの説明は、既存の「カレンダーコントロール」的なものを探すのではなく「独自に作ってしまえ!」です。
早い話が、自己に「カレンダーコントロール」のような「カレンダー入力フォーム」を組み込めればある程度は解決できます。 独自に作成するのであれば、祝日名の表示やキーボードの矢印キーでの日付移動、「月曜始まり」のカレンダー表示など、機能も高められます。
そのカレンダー部分は作成済みでこのページからダウンロードできるので、あとは機能の実装部分を考えて下さい。



さらに祝日の変更が発生した時にプログラムの修正なく対応できるように「祝日パラメータシート」で祝日の定義ができるようになっています。 「会社休日」として年末年始で祝日に当たらない日を休日表示させることもできるようになっています。
祝日判定部分の説明は「年間カレンダーの作成2」をご覧下さい。
64ビット版対応やスクリーン「はみ出し」対応を行ないました。   このページのサンプルはユーザーフォームの表示位置制御にAPIを使用しております。
Office365やOffice2019では、64ビット版になるという情報があったため、 当サイトでも順次この対応を行ない、動作確認ができたものからページを更新しています。
また、スクリーン下端、右端付近での「カレンダー入力フォーム」では、「カレンダー入力フォーム」がスクリーンからはみ出してしまう現象があったのですが、 これに対する「ある程度」の対応を行ないました。 「ある程度」というのはVBAでは複数ディスプレィ運用時のディスプレィ個々の状態が取得できないので、 全体矩形範囲の取得で「はみ出し」を判断するしかなく、ディスプレィ配置の設定次第では正しく「はみ出し」が判断できない場合があるからです。
本件についてはVBA応用の「ユーザーフォーム表示位置の制御」で説明しています。
シート上、又はテキストボックス上で利用できるものを考えてみました。
  • シート上なら、該当セルをダブルクリックした時点で「カレンダー入力フォーム」が表示されるように利用できます。
    シート上で「カレンダー入力フォーム」させたところ
    (画像をクリックすると、このページのサンプルがダウンロードできます)
    このサンプルでは、シート上の罫線で囲ったセルを日付入力セルとして動作するようにしているので、他のセルをダブルクリックしても「カレンダー入力フォーム」は表示されません。 対象セルをダブルクリックした時だけ、直下に「カレンダー入力フォーム」が表示されて、その「カレンダー入力フォーム」で日付を選択するとその日付がセルに入力されます。
    ※表示されたカレンダーが不要になった場合は[×]をクリックするか、Escキーを押して下さい。

  • マウス移動に連動してステータス領域に日付や祝日名が表示されます。
    シート上で「カレンダー入力フォーム」させたところ
    祝日計算のモジュールを搭載しているので、祝日は赤太字で表示されてマウスカーソルを当てると祝日名も表示されます。

  • 上端の左右にある矢印をクリックして前後の月に移動できますが、それ以外に年月表示部分をクリックすると年月のコンボのプルダウンが現われて選択できます。
    シート上で「カレンダー入力フォーム」させたところ

  • このようにマウス操作では充分な機能になっていると思いますが、これ以外にキーボードでの日付選択ができるようになっています。キー操作で現在日付の青いカーソルを移動させて、Enterキーで決定するという操作です。各キーの機能は以下のようになっています。
    押下キー動作機能
    →、Tab、+、6(テンキー)翌日に移動します。(表示範囲を超えると自動的に翌月に移動します。)
    ←、Shift+Tab、−、4(テンキー)前日に移動します。(表示範囲を超えると自動的に前月に移動します。)
    ↓、2(テンキー)翌週の同曜日に移動します。(表示範囲を超えると自動的に翌月に移動します。)
    ↑、8(テンキー)前週の同曜日に移動します。(表示範囲を超えると自動的に前月に移動します。)
    Home表示月の月初(1日)に移動します。
    End表示月の月末(末日)に移動します。
    PageDown翌月に移動します。
    PageUp前月に移動します。
    F12翌年同月に移動します。
    F11前年同月に移動します。
    Enter日付を決定して元フォームに戻ります
    Escキャンセルして元フォームに戻ります

  • ユーザーフォーム上なら、テキストボックスの右端の▼をクリックした時点で「カレンダー入力フォーム」が表示されるように利用できます。
    ユーザーフォーム上で「カレンダー入力フォーム」させたところ
    ユーザーフォームの場合はカレンダーの表示位置のLeftTopを指定して表示させるようになっており、 この指定を行なわない場合はスクリーン中央に表示されるようになっています。 このLeftTopはユーザーフォーム自身のLeftTopに対して、 そのユーザーフォーム内のテキストボックスまでのLeftTopを加算します。
    但し、グループボックスなどの「コンテナ」の上にテキストボックスが載っている場合は、テキストボックスのLeftTop値は そのグループボックスの起点からの位置なので、ユーザーフォームからの位置の算出にはグループボックスのLeftTopを加算することになります。
    さらに、ユーザーフォームやグループボックスについては外から見たLeftTopと、内側の起点位置にフレーム部分の「ズレ」があり、 特にグループボックスはタイトルの分の高さのズレが大きいといえますが、この分は調整値として動作確認して加算して下さい。
    なお、元フォームの日付項目テキストボックスにカーソルがある場合は、マウスでテキストボックスの右端の▼をクリックしなくても、F4キーで「カレンダー入力フォーム」を表示させることができます。

  • 初期設定を変更することで、このように「月曜始まり」のカレンダー表示に変更することができます。
    シート上で「カレンダー入力フォーム」させたところ
    企業内でのカレンダーは「月曜始まり」で用いることがかなり多いので、通常の「日曜始まり」と切り替えて「月曜始まり」での表示ができるようになっています。 どちらを用いるのかはコード上の定数値の「1」を「2」に替えるだけです。

「マクロは初級」の方にも組み込みやすいように配慮してあります。
今回より「祝日判定処理」についてもソースコードの変更は行なわずに「祝日パラメータ」シートの登録の変更で対応できるようになったので、 実際にワークシートの日付セルからの呼び出しか、ユーザーフォームの日付テキストボックスからの呼び出しか、その呼び出し部分の記述の実装のみマスターしていただければ これらの機能は実現できるようになりました。

その主機能部分で、今回のサンプルから実行環境に移していただく必要があるものは以下の通りです。
ID内容
UF_Calendar5カレンダー表示フォーム(UserForm)
modCalendar5カレンダー表示呼び出しモジュール(Module)
clsUF_Cal5Label1カレンダー表示フォーム上のラベルのイベントクラス@(Class)
clsUF_Cal5Label2カレンダー表示フォーム上のラベルのイベントクラスA(Class)
modAboutCalendar2カレンダー算出呼び出しモジュール(Module)
clsAboutCalendar2祝日を含めたカレンダー算出本体クラス(Class)
祝日パラメータ「祝日パラメータ」ワークシート(Worksheet)

祝日の処理を含めて、これらのソースコードを変更する必要はありません。 「カレンダー入力フォーム」を呼び出す記述は、サンプルの中では「Sheet1」と「UserForm1」の中にあり、 それぞれ「modCalendar5」の中の以下のプロシージャを呼び出しています。
プロシージャ内容
ShowCalendarFromTextBox2ユーザーフォームのテキストボックス(MsForms.TextBox)から表示させる
[引数]
@対象テキストボックス(Object)
Aカレンダーフォームの表示位置:横(Long)    ※Option
Bカレンダーフォームの表示位置:縦(Long)    ※Option
CカレンダーフォームのCaption(String)       ※Option、デフォルトは"日付選択"
D値を返す時のFormat(String)                ※Option、デフォルトは"YYYY/MM/DD"
ShowCalendarFromRange2セル(Range)から表示させる(表示位置自動算出)
[引数]
@対象セル(Object)
AカレンダーフォームのCaption(String)       ※Option、デフォルトは"日付選択"


例えば、ワークシート上からは、

'***************************************************************************************************
'   カレンダーフォーム表示テスト                                Sheet1(Class)
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'18/02/21(1.00)新規作成
'18/11/28(1.80)カレンダーフォーム上の各日付ラベルをクラス化(WithEvents)させる対応
'***************************************************************************************************
Option Explicit
'---------------------------------------------------------------------------------------------------
' シート上の日付セルアドレス(今回サンプルの例)
Private Const g_cnsDateCellAdress = "$A$1,$A$9,$D$13,$B$17,$G$18,$E$21,$C$25,$H$27:$I$28,$F$30"

'***************************************************************************************************
'* 処理名 :Worksheet_BeforeDoubleClick
'* 機能  :ワークシートダブルクリッククリックイベント
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(既定)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2018年02月21日
'* 作成者 :井上 治
'* 更新日 :2018年11月28日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    '-----------------------------------------------------------------------------------------------
    ' カレンダー表示対象セルか判定
    If Intersect(Target, Range(g_cnsDateCellAdress)) Is Nothing Then Exit Sub
    '-----------------------------------------------------------------------------------------------
    ' カレンダーフォームを起動する
    Call modCalendar5.ShowCalendarFromRange2(Target)
    ' ダブルクリック動作をキャンセル
    Cancel = True
End Sub

'----------------------------------------<< End of Source >>----------------------------------------
このように、「Worksheet_BeforeDoubleClick」イベントから呼び出すことで、該当セルの選択時に「カレンダー入力フォーム」が表示されますが、 先に対象セルかの「ふるい」を掛けており、Intersectメソッドでは今回呼び出したセルと日付入力セルとして登録されているセルに交点がないと以降の処理がされないように判定しています。
シートモジュールの上部にある定数「g_cnsDateCellAdress」の値を変更する程度で実際導入するワークブックにも応用できると思います。

ユーザーフォームの場合は、

'***************************************************************************************************
'   カレンダーフォーム4(日付入力部品)   ※テスト用フォーム      UserForm1(UserForm)
'
'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'18/02/21(1.00)新規作成
'***************************************************************************************************
Option Explicit
'---------------------------------------------------------------------------------------------------
Private Const g_cnsAddLeft As Long = 3                          ' Left調整値
Private Const g_cnsAddTop As Long = 19                          ' Top調整値
Private Const g_cnsAddLeft2 As Long = 4                         ' Left調整値(フレーム用)
Private Const g_cnsAddTop2 As Long = 25                         ' Top調整値(フレーム用)
' ※これらの調整値はWindows10時点の画面で適当に見繕った値です。
'  二重にフレームが重なった等の場合は別途調整が必要です。

'***************************************************************************************************
' ■■■ フォームイベント ■■■
'***************************************************************************************************
'* 処理名 :TextBox1_DropButtonClick
'* 機能  :フォーム上のテキストボックスイベント(DropButtonClick)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2018年02月21日
'* 作成者 :井上 治
'* 更新日 :2018年02月21日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub TextBox1_DropButtonClick()
    '-----------------------------------------------------------------------------------------------
    Dim lngLeft As Long                                             ' 位置(横方向)
    Dim lngTop As Long                                              ' 位置(縦方向)
    ' フォーム+テキストボックスのLeft,Top値から位置を判定
    lngLeft = Me.Left + TextBox1.Left + g_cnsAddLeft
    lngTop = Me.Top + TextBox1.Top + TextBox1.Height + g_cnsAddTop
    '-----------------------------------------------------------------------------------------------
    ' カレンダーフォームを起動する
    Call modCalendar5.ShowCalendarFromTextBox2(TextBox1, lngLeft, lngTop)
End Sub

'***************************************************************************************************
'* 処理名 :TextBox2_DropButtonClick
'* 機能  :フレーム上のテキストボックスイベント(DropButtonClick)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2018年02月21日
'* 作成者 :井上 治
'* 更新日 :2018年02月21日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub TextBox2_DropButtonClick()
    '-----------------------------------------------------------------------------------------------
    Dim lngLeft As Long                                             ' 位置(横方向)
    Dim lngTop As Long                                              ' 位置(縦方向)
    ' フォーム+フレーム+テキストボックスのLeft,Top値から位置を判定
    lngLeft = Me.Left + Frame1.Left + TextBox2.Left + g_cnsAddLeft2
    lngTop = Me.Top + Frame1.Top + TextBox2.Top + TextBox2.Height + g_cnsAddTop2
    '-----------------------------------------------------------------------------------------------
    ' カレンダーフォームを起動する
    Call modCalendar5.ShowCalendarFromTextBox2(TextBox2, lngLeft, lngTop)
End Sub

'***************************************************************************************************
'* 処理名 :UserForm_Initialize
'* 機能  :ユーザーフォームの初期化
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数  :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2018年02月21日
'* 作成者 :井上 治
'* 更新日 :2018年02月21日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub UserForm_Initialize()
    '-----------------------------------------------------------------------------------------------
    ' テキストボックスに▼ボタンを表示させる
    TextBox1.ShowDropButtonWhen = fmShowDropButtonWhenAlways
    TextBox2.ShowDropButtonWhen = fmShowDropButtonWhenAlways
    ' デフォルト日付の表示(今日)
    TextBox1.Text = Format(Date, "yyyy/MM/dd")
    TextBox2.Text = Format(Date, "yyyy/MM/dd")
End Sub

'----------------------------------------<< End of Source >>----------------------------------------
サンプルではこのようになっていますが、最低限の利用方法では該当するテキストボックスを引数にして「ShowCalendarFromTextBox2」を呼び出すだけです。
このサンプルでは欲張って、「カレンダー入力フォーム」をテキストボックスの直下に表示させるようにしていますが、 これらの指定を省略すれば「カレンダー入力フォーム」はスクリーンの中央に表示されるだけです。
但し、テキストボックスはデフォルトでは、右端の「▼」は表示されないので、フォームの初期化イベント(UserForm_Initialize)で、ShowDropButtonWhenfmShowDropButtonWhenAlwaysにしておく必要があります。 このプロパティはデザイン時にはプロパティボックスには表示されないので、このサンプルのように記述して下さい。
表示位置については、実際にはスクリーン上の位置として「カレンダー入力フォーム」の上端(Top)と左端(Left)を指定するのですが、 テキストボックスのこれらのプロパティは「親」となる要素の左上隅をゼロとした値でしかないので、その「親」がスクリーン上のどこに位置するかも判断しなければなりません。 しかも、テキストボックスがフレーム上にある場合は「親」となる要素はフレームとなり、そのフレームがフォーム上のどこにあるのかが追加されます。 ここでは触れませんが、フレームが2重になっているようなケースもあるでしょう。
さらにやっかいなのは、ウィンドウの境界「枠」と「タイトルバー」「ツールバー」です。TopLeftのプロパティはこれらを除いた内側の左上を起点とした位置情報なので、 ただ加算しても正しい位置にはなりません。
そこで、サンプルではウィンドウの境界「枠」については実測した「適当そうな値」を定数として加算させることにしてあります。

「カレンダー入力フォーム」側のコードも説明しておきます。
  • ここから下のコードはほとんどの場合改変なく利用できるので、特に理解しなくても構いません。
    今回の「カレンダー入力フォーム」は選択元セルもしくはユーザーフォーム上の選択元テキストボックスに日付を返すように作成しているため、 日付を選択するかキャンセルしないと元のシート(又はユーザーフォーム)には戻れない「モーダルフォーム」を使っています。 一部の要望では、「カレンダー入力フォーム」を表示させたまま別のセルを選択し直すなどの意見がありますが、「日付を返す先」の特定の問題と、ユーザーフォームと兼用(モーダルフォームの上にモードレスフォームを表示することができないというUserFormの仕様)していることもあって、この仕様は変更できません。

    組み込むモジュールは上記で説明しましたが、まず「modCalendar5」を紹介します。
    
    '***************************************************************************************************
    '   カレンダーフォーム5(日付入力部品)   ※呼び出しプロシージャ    modCalendar5(Module)
    '
    '   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
    '***************************************************************************************************
    '変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
    '18/02/21(1.00)新規作成
    '18/11/28(1.80)カレンダーフォーム上の各日付ラベルをクラス化(WithEvents)させる対応
    '19/10/20(1.90)64ビットWindows対応
    '19/12/08(1.95)複数スクリーン対応、スクリーン下端・右端からのはみ出し対応
    '***************************************************************************************************
    Option Explicit
    '===================================================================================================
    Private Const g_cnsDateFormat = "YYYY/MM/DD"                    ' デフォルトの日付Format
    Private Const g_cnsCaption = "日付選択"                         ' デフォルトのCaption
    '---------------------------------------------------------------------------------------------------
    ' フォーム位置制御関連
    Private Const LOGPIXELSX As Long = 88
    Private Const LOGPIXELSY As Long = 90
    Private Const SM_CYSCREEN As Long = 1
    Private Const SM_XVIRTUALSCREEN As Long = 76
    Private Const SM_YVIRTUALSCREEN As Long = 77
    Private Const SM_CXVIRTUALSCREEN As Long = 78
    Private Const SM_CYVIRTUALSCREEN As Long = 79
    Private Const SPI_GETWORKAREA As Long = 48
    '---------------------------------------------------------------------------------------------------
    ' GetWindowRect用ユーザー定義
    Private Type g_typRect
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    ' 64ビット版判定
    #If VBA7 Then
    ' ■GetDC(API)
    Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
    ' ■ReleaseDC(API)
    Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" _
        (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    ' ■GetDeviceCaps(API)
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" _
        (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    ' ■GetSystemMetrics(API)
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
    ' ■SystemParametersInfo(API)
    Private Declare PtrSafe Function SystemParametersInfo Lib "user32.dll" _
        Alias "SystemParametersInfoA" ( _
        ByVal uAction As Long, _
        ByVal uParam As Long, _
        ByRef lpvParam As g_typRect, _
        ByVal fuWinIni As Long) As Long
    #Else
    ' ■GetDC(API)
    Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
    ' ■ReleaseDC(API)
    Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    ' ■GetDeviceCaps(API)
    Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    ' ■GetSystemMetrics(API)
    Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
    ' ■SystemParametersInfo(API)
    Private Declare Function SystemParametersInfo Lib "user32.dll" _
        Alias "SystemParametersInfoA" ( _
        ByVal uAction As Long, _
        ByVal uParam As Long, _
        ByRef lpvParam As g_typRect, _
        ByVal fuWinIni As Long) As Long
    #End If
    
    '***************************************************************************************************
    '* 処理名 :ShowCalendarFromTextBox2
    '* 機能  :ユーザーフォームのテキストボックス(MsForms.TextBox)から表示させる
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :Arg1 = テキストボックス(Object)
    '*      Arg2 = カレンダーフォームの表示位置:横(Long)  ※Option
    '*      Arg3 = カレンダーフォームの表示位置:縦(Long)  ※Option
    '*      Arg4 = カレンダーフォームのCaption(String)     ※Option、デフォルトは"日付選択"
    '*      Arg5 = 値を返す時のFormat(String)              ※Option、デフォルトは"YYYY/MM/DD"
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年02月21日
    '* 作成者 :井上 治
    '* 更新日 :2019年12月08日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Public Sub ShowCalendarFromTextBox2(ByRef objTextBox As MSForms.TextBox, _
                                        Optional ByVal lngLeft As Long = 0, _
                                        Optional ByVal lngTop As Long = 0, _
                                        Optional ByVal strCaption As String = g_cnsCaption, _
                                        Optional ByVal strFormat As String = g_cnsDateFormat)
        '-----------------------------------------------------------------------------------------------
        Dim lngFormWidth As Long                                        ' カレンダーフォームの幅
        Dim lngFormHeight As Long                                       ' カレンダーフォームの高さ
        Dim lngScreenRight As Long                                      ' スクリーン右端位置
        Dim lngScreenBottom As Long                                     ' スクリーン下端位置
        Dim lngDPIX As Long                                             ' Dots Per Inch(水平)
        Dim lngDPIY As Long                                             ' Dots Per Inch(垂直)
        Dim lngPPI As Long                                              ' Pixels Per Inch
        '-----------------------------------------------------------------------------------------------
        ' カレンダーフォームの大きさ取得
        lngFormWidth = UF_Calendar5.Width
        lngFormHeight = UF_Calendar5.Height
        ' ※以下はExcel2003以前では動作しない
        lngDPIX = FP_GetDPIX
        lngDPIY = FP_GetDPIY
        lngPPI = FP_GetPPI
        '-----------------------------------------------------------------------------------------------
        ' スクリーンサイズ位置の取得
        Call GP_GetScreenPos(0, 0, lngScreenRight, lngScreenBottom)
        '-----------------------------------------------------------------------------------------------
        ' カレンダーフォームがスクリーンからはみ出すか(横)
        If (lngLeft + lngFormWidth) * (lngDPIX / lngPPI) > lngScreenRight Then
            ' スクリーン右端に移動(+3は誤差?)
            lngLeft = lngScreenRight * (lngPPI / lngDPIX) - lngFormWidth + 3
        End If
        ' カレンダーフォームがスクリーンからはみ出すか(縦)
        If (lngTop + lngFormHeight) * (lngDPIY / lngPPI) > lngScreenBottom Then
            ' セル上端に移動(+3は誤差?)
            lngTop = lngTop - (objTextBox.Height + lngFormHeight) + 3
        End If
        '-----------------------------------------------------------------------------------------------
        ' カレンダーフォーム
        With UF_Calendar5
            .prpTitle = strCaption                              ' タイトル
            .prpEntMode = 1                                     ' 入力モード(0=セル、1=TextBox)
            Set .prpTextBox = objTextBox                        ' 対象TextBox
            .prpDateFormat = strFormat                          ' 日付フォーマット
            ' フォーム表示位置の確認
            If ((lngLeft <> 0) Or (lngTop <> 0)) Then
                ' 指定がある場合はマニュアル指定
                .StartUpPosition = 0
                .Left = lngLeft
                .Top = lngTop
            Else
                ' 指定がない場合はスクリーンの中央
                .StartUpPosition = 2
            End If
            ' カレンダーフォームを表示
            .Show
        End With
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :ShowCalendarFromRange2
    '* 機能  :セル(Range)から表示させる
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :Arg1 = セル(Object) ※単一セル又は結合した日付用セル
    '*      Arg2 = カレンダーフォームのCaption(String)     ※Option、デフォルトは"日付選択"
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年02月21日
    '* 作成者 :井上 治
    '* 更新日 :2019年12月08日
    '* 更新者 :井上 治
    '* 機能説明:当該セルの下にカレンダーフォームが表示される
    '* 注意事項:
    '***************************************************************************************************
    Public Sub ShowCalendarFromRange2(ByRef objRange As Range, _
                                      Optional ByVal strCaption As String = g_cnsCaption)
        '-----------------------------------------------------------------------------------------------
        Dim lngLeft As Long                                             ' 横位置
        Dim lngTop As Long                                              ' 縦位置
        ' 非結合のセル範囲を選択している時は処理しない
        If objRange.Count > 1 Then
            ' 単一結合セルはOK とする
            If objRange.Address <> objRange.Cells(1).MergeArea.Address Then Exit Sub
        End If
        '-----------------------------------------------------------------------------------------------
        ' ユーザーフォーム表示位置取得
        Call FP_GetFormPosition(objRange, UF_Calendar5.Width, UF_Calendar5.Height, lngLeft, lngTop)
        '-----------------------------------------------------------------------------------------------
        ' カレンダーフォーム
        With UF_Calendar5
            .prpTitle = strCaption                              ' タイトル
            .prpEntMode = 0                                     ' 入力モード(0=セル、1=TextBox)
            Set .prpRange = objRange                            ' 対象セル
            ' フォーム表示位置の確認
            If ((lngLeft <> 0) Or (lngTop <> 0)) Then
                ' 指定がある場合はマニュアル指定
                .StartUpPosition = 0
                .Left = lngLeft
                .Top = lngTop
            Else
                ' 指定がない場合はスクリーンの中央
                .StartUpPosition = 2
            End If
            ' カレンダーフォームを表示
            .Show
        End With
    End Sub
    
    '***************************************************************************************************
    ' ■■■ サブ処理 ■■■
    '***************************************************************************************************
    '* 処理名 :FP_GetFormPosition
    '* 機能  :ユーザーフォーム表示位置取得
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :処理成否(Boolean)
    '* 引数  :Arg1 = 対象セル(Object)
    '*      Arg2 = ユーザーフォームの幅(Long)
    '*      Arg3 = ユーザーフォームの高さ(Long)
    '*      Arg4 = スクリーン上の横位置(Long)          ※Ref参照
    '*      Arg5 = スクリーン上の縦位置(Long)          ※Ref参照
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年02月21日
    '* 作成者 :井上 治
    '* 更新日 :2019年12月08日
    '* 更新者 :井上 治
    '* 機能説明:セルの真下にフォームを表示させる位置を取得
    '* 注意事項:取得できない時は横位置、縦位置ともゼロとなる
    '***************************************************************************************************
    Private Function FP_GetFormPosition(ByRef objRange As Range, _
                                        ByVal lngFormWidth As Long, _
                                        ByVal lngFormHeight As Long, _
                                        ByRef lngFormLeft As Long, _
                                        ByRef lngFormTop As Long) As Boolean
        '-----------------------------------------------------------------------------------------------
        Dim objTarget As Range                                          ' 対象セル(先頭セル)
        Dim objAW As Window                                             ' ActiveWindow
        Dim lngPaneIx As Long                                           ' PaneIndex(0〜4)
        Dim lngIx As Long                                               ' ループ用INDEX(Work)
        Dim lngR1C1Left As Long                                         ' 起点セル左端位置
        Dim lngR1C1Top As Long                                          ' 起点セル上端位置
        Dim lngTargetLeft As Long                                       ' 対象セル左端位置
        Dim lngTargetTop As Long                                        ' 対象セル上端位置
        Dim lngScreenRight As Long                                      ' スクリーン右端位置
        Dim lngScreenBottom As Long                                     ' スクリーン下端位置
        Dim lngDPIX As Long                                             ' Dots Per Inch(水平)
        Dim lngDPIY As Long                                             ' Dots Per Inch(垂直)
        Dim lngPPI As Long                                              ' Pixels Per Inch
        FP_GetFormPosition = False
        lngFormLeft = 0
        lngFormTop = 0
        lngPaneIx = 0
        Set objTarget = objRange.Cells(1).MergeArea
        Set objAW = ActiveWindow
        '-----------------------------------------------------------------------------------------------
        ' ウィンドウ分割無しか
        If Not objAW.FreezePanes And Not objAW.Split Then
            ' 表示域外は無視
            If Intersect(objAW.VisibleRange, objTarget) Is Nothing Then Exit Function
        Else            ' 分割あり
            ' ウィンドウ枠固定か
            If objAW.FreezePanes Then
                ' どのウィンドウに属するか判定
                For lngIx = 1 To objAW.Panes.Count
                    ' 発見?
                    If Not Intersect(objAW.Panes(lngIx).VisibleRange, objTarget) Is Nothing Then
                        lngPaneIx = lngIx
                        Exit For
                    End If
                Next lngIx
                ' 見つからないか
                If lngPaneIx = 0 Then Exit Function
            Else
                ' ウィンドウ分割はアクティブペインのみ判定
                If Not Intersect(objAW.ActivePane.VisibleRange, objTarget) Is Nothing Then
                    lngPaneIx = objAW.ActivePane.Index
                Else
                    Exit Function
                End If
            End If
        End If
        '-----------------------------------------------------------------------------------------------
        ' ※以下はExcel2003以前では動作しない
        lngDPIX = FP_GetDPIX
        lngDPIY = FP_GetDPIY
        lngPPI = FP_GetPPI
        ' ウィンドウ分割無しか
        If lngPaneIx = 0 Then
            lngR1C1Left = objAW.PointsToScreenPixelsX(0)
            lngR1C1Top = objAW.PointsToScreenPixelsY(0)
        Else
            lngR1C1Left = objAW.Panes(lngPaneIx).PointsToScreenPixelsX(0)
            lngR1C1Top = objAW.Panes(lngPaneIx).PointsToScreenPixelsY(0)
        End If
        lngTargetLeft = ((objTarget.Left * (lngDPIX / lngPPI)) * (objAW.Zoom / 100)) + lngR1C1Left
        lngTargetTop = (((objTarget.Top + objTarget.Height) * (lngDPIY / lngPPI)) * (objAW.Zoom / 100)) + lngR1C1Top
        lngFormLeft = lngTargetLeft * (lngPPI / lngDPIX)
        lngFormTop = lngTargetTop * (lngPPI / lngDPIY)
        '-----------------------------------------------------------------------------------------------
        ' スクリーンサイズ位置の取得
        Call GP_GetScreenPos(0, 0, lngScreenRight, lngScreenBottom)
        '-----------------------------------------------------------------------------------------------
        ' ユーザーフォームがスクリーンからはみ出すか(横)
        If (lngFormLeft + lngFormWidth) * (lngDPIX / lngPPI) > lngScreenRight Then
            ' スクリーン右端に移動(+3は誤差?)
            lngFormLeft = lngScreenRight * (lngPPI / lngDPIX) - lngFormWidth + 3
        End If
        ' ユーザーフォームがスクリーンからはみ出すか(縦、タスクバー分は正しく取得できていない)
        If (lngFormTop + lngFormHeight) * (lngDPIY / lngPPI) > lngScreenBottom Then
            ' セル上端に移動
            lngFormTop = lngFormTop - (objRange.Height + lngFormHeight)
        End If
        FP_GetFormPosition = True
    End Function
    
    '***************************************************************************************************
    '* 処理名 :FP_GetPPI
    '* 機能  :PPI(Pixels Per Inch)取得
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :PPI値(Long)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年02月21日
    '* 作成者 :井上 治
    '* 更新日 :2018年02月21日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Function FP_GetPPI() As Long
        '-----------------------------------------------------------------------------------------------
        FP_GetPPI = Application.InchesToPoints(1)
    End Function
    
    '***************************************************************************************************
    '* 処理名 :FP_GetDPIX
    '* 機能  :DPI(Dots Per Inch)取得(水平方向)
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :DPI値(Long)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年02月21日
    '* 作成者 :井上 治
    '* 更新日 :2018年02月21日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Function FP_GetDPIX() As Long
        '-----------------------------------------------------------------------------------------------
        FP_GetDPIX = FP_GetDPI(LOGPIXELSX)
    End Function
    
    '***************************************************************************************************
    '* 処理名 :FP_GetDPIY
    '* 機能  :DPI(Dots Per Inch)取得(垂直方向)
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :DPI値(Long)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年02月21日
    '* 作成者 :井上 治
    '* 更新日 :2018年02月21日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Function FP_GetDPIY() As Long
        '-----------------------------------------------------------------------------------------------
        FP_GetDPIY = FP_GetDPI(LOGPIXELSY)
    End Function
    
    '***************************************************************************************************
    '* 処理名 :FP_GetDPI
    '* 機能  :DPI(Dots Per Inch)取得(API)
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :DPI値(Long)
    '* 引数  :Arg1 = nFlag(Long)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年02月21日
    '* 作成者 :井上 治
    '* 更新日 :2019年10月20日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Function FP_GetDPI(ByVal nFlag As Long) As Long
        '-----------------------------------------------------------------------------------------------
    #If VBA7 Then
        Dim lngHdc As LongPtr                                           ' ウィンドウハンドルのDC
    #Else
        Dim lngHdc As Long                                              ' ウィンドウハンドルのDC
    #End If
        lngHdc = GetDC(Application.hwnd)
        FP_GetDPI = GetDeviceCaps(lngHdc, nFlag)
        Call ReleaseDC(&H0, lngHdc)
    End Function
    
    '***************************************************************************************************
    '* 処理名 :GP_GetScreenPos
    '* 機能  :スクリーン位置の取得
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :Arg1 = スクリーン左端位置(Long)              ※Ref参照
    '*      Arg2 = スクリーン上端位置(Long)              ※Ref参照
    '*      Arg3 = スクリーン右端位置(Long)              ※Ref参照
    '*      Arg4 = スクリーン下端位置(Long)              ※Ref参照
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2019年12月08日
    '* 作成者 :井上 治
    '* 更新日 :2019年12月08日
    '* 更新者 :井上 治
    '* 機能説明:複数スクリーン全体四隅の位置を取得
    '* 注意事項:
    '***************************************************************************************************
    Private Sub GP_GetScreenPos(ByRef lngScreenLeft As Long, _
                                ByRef lngScreenTop As Long, _
                                ByRef lngScreenRight As Long, _
                                ByRef lngScreenBottom As Long)
        '-----------------------------------------------------------------------------------------------
        Dim lngWidth As Long                                            ' スクリーンの幅
        Dim lngHeight As Long                                           ' スクリーンの高さ@
        Dim lngHeight2 As Long                                          ' スクリーンの高さA
        Dim lngHeight3 As Long                                          ' スクリーンの高さB
        Dim objRect As g_typRect                                        ' Rect
        ' スクリーンの左端、上端、幅、高さの取得(複数スクリーン対応)
        lngScreenLeft = GetSystemMetrics(SM_XVIRTUALSCREEN)         ' 左端
        lngScreenTop = GetSystemMetrics(SM_YVIRTUALSCREEN)          ' 上端
        lngWidth = GetSystemMetrics(SM_CXVIRTUALSCREEN)             ' 幅(仮想スクリーン域)
        lngHeight = GetSystemMetrics(SM_CYVIRTUALSCREEN)            ' 高さ(仮想スクリーン域)
        lngHeight2 = GetSystemMetrics(SM_CYSCREEN)                  ' 高さ(メインスクリーンのみ)
        ' タスクバーを除くスクリーンの大きさ取得(メインスクリーンのみ)
        Call SystemParametersInfo(SPI_GETWORKAREA, 0, objRect, 0)
        lngHeight3 = objRect.Bottom - objRect.Top                   ' 高さ(メインのタスクバー以外の分)
        ' タスクバーがメインスクリーンの下端にあるものとし、この高さを差し引く
        lngHeight = lngHeight - (lngHeight2 - lngHeight3)
        ' 右端の算出
        lngScreenRight = lngWidth - lngScreenLeft
        ' 下端の算出
        lngScreenBottom = lngHeight - lngScreenTop
    End Sub
    
    '----------------------------------------<< End of Source >>----------------------------------------
    
    上で説明している公開プロシージャ上の2つだけですが、セルからカレンダー入力フォームの表示位置を算出する内部プロシージャや、 スクリーンからの「はみ出し」の検出・補正する記述が加わったので長くなりました。
    これらは利用者が理解する必要がないものですが、Office2007以降限定の関数を使用しているため、Office2003以前では利用できません。

  • 次は、実際のカレンダーのユーザーフォームのコードです。
    カレンダーの日付部分は7曜日×6週=42個と「昨日」「今日」「明日」の計45個の「ラベル」を中心としたものですが、この45個やその他の「ラベル」については以前はユーザーフォームのコード上にズラズラとイベントコードを書いていたのですが、この「UF_Calendar5」から2つのイベントクラス「clsUF_Cal5Label1」「clsUF_Cal5Label2」に分離させたため、このユーザーフォームのコード上からは日付「ラベル」のClickMouseMoveイベントの記述はなくなりました。(イベントクラスは後述)
    2つのイベントクラス「clsUF_Cal5Label1」「clsUF_Cal5Label2」についてはモジュールレベルの変数で宣言しており、「UserForm_Initialize」の最初の方で初期化させています。

    最初の方の定数は意味があって、「g_cnsStartYobi」はカレンダーの起算曜日の指定です。デフォルトは「1」となっていますが、これを「2」に替えると左端が月曜日となって表示されるようになります。他の曜日には対応しておらず「2」以外は全て日曜日始まりです。
    その下の「g_cnsYearFrom」「g_cnsYearToAdd」がカレンダーの操作で表示させる年範囲の規定です。開始年は祝日法が施行された「1947年」としています。これ以上以前の年に変更すると祝日は正しく表示されません。 終了年の方はシステム日付の年に対する「年の増分」で指定するように指定しています。翌々年以降は祝日については正しいとは限りません。
    
    '***************************************************************************************************
    '   カレンダーフォーム5(日付入力部品)    ※ユーザーフォーム(改D)   UF_Calendar5(UserForm)
    '
    '   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
    '***************************************************************************************************
    '   ※祝日法改正時は「祝日パラメータ」シートで行なう
    '***************************************************************************************************
    '変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
    '18/02/20(4.30)祝日判定関連を「modAboutCalendar2」に移行する対応
    '18/02/20(4.30)親フォームとの受け渡しをプロパティに変更
    '18/02/21(4.31)カレンダー初週の表示不具合修正(1日が表示されない件)、モードレス表示対応
    '18/02/21(4.31)結果日付を返さずに本フォーム内でセル(又はTextBox)に日付を書き込むように仕様変更
    '18/02/22(4.32)結合セルから値を取り出す時の不具合対応
    '18/09/23(1.70)カレンダー関連機能のクラス化対応
    '18/11/26(1.71)カレンダーフォーム表示幅調整(Windows10対応)
    '18/11/28(1.80)カレンダーフォーム上の各日付ラベルをクラス化(WithEvents)させる対応
    '***************************************************************************************************
    Option Explicit
    '---------------------------------------------------------------------------------------------------
    ' [起算曜日] ※カレンダーを月曜開始(曜日左端)にする場合は「2」に変更して下さい。
    Private Const g_cnsStartYobi = 1                            ' 1=日曜日,2=月曜日(他は不可)
    '---------------------------------------------------------------------------------------------------
    ' [年の表示限度(From/To)]
    Private Const g_cnsYearFrom = 1947                          ' 祝日法施行
    Private Const g_cnsYearToAdd = 3                            ' システム日の年+n年までの指定
    '---------------------------------------------------------------------------------------------------
    ' フォーム上の色指定等の定数
    Private Const cnsBC_Select = &HFFCC33                       ' 選択日付の背景色
    Private Const cnsBC_Other = &HE0E0E0                        ' 当月以外の背景色
    Private Const cnsBC_Sunday = &HFFDDFF                       ' 日曜の背景色
    Private Const cnsBC_Saturday = &HDDFFDD                     ' 土曜の背景色
    Private Const cnsBC_Month = &HFFFFFF                        ' 当月土日以外の背景色
    Private Const cnsFC_Hori = &HFF                             ' 祝日の文字色
    Private Const cnsFC_Normal = &HC00000                       ' 祝日以外の文字色
    Private Const cnsDefaultGuide = "矢印キーで操作できます。"
    Private Const g_cnsDateFormat = "YYYY/MM/DD"                ' デフォルトの日付Format
    '---------------------------------------------------------------------------------------------------
    ' 呼び元との受け渡し変数
    Private g_FormDate1 As Date                                 ' 現在日付
    Private g_intEntMode As Integer                             ' 入力モード(0=セル、1=TextBox)
    Private g_objRange As Range                                 ' 対象セル
    Private g_objTextBox As MSForms.TextBox                     ' 対象TextBox
    Private g_strDateFormat As String                           ' 日付フォーマット(TextBox時)
    '---------------------------------------------------------------------------------------------------
    ' フォーム表示中に保持するモジュール変数
    Private g_tblYobi As Variant                                ' 曜日テーブル
    Private g_tblDateLabel(44) As New clsUF_Cal5Label1          ' 日付ラベルイベントクラステーブル
    Private g_tblFixLabel(11) As New clsUF_Cal5Label2           ' 固定ラベルイベントクラステーブル
    Private g_intCurYear As Integer                             ' 現在表示年
    Private g_intCurMonth As Integer                            ' 現在表示月
    Private g_CurPos As Long                                    ' 現在日付位置
    Private g_CurPosF As Long                                   ' 当月月初日位置
    Private g_CurPosT As Long                                   ' 当月月末日位置
    Private g_swBatch As Boolean                                ' イベント抑制SW
    Private g_VisibleYear As Boolean                            ' Conboの年表示スイッチ
    Private g_VisibleMonth As Boolean                           ' Comboの月表示スイッチ
    
    '***************************************************************************************************
    ' ■フォーム上のイベント
    '***************************************************************************************************
    '* 処理名 :CBO_MONTH_Change
    '* 機能  :「月」コンボの操作イベント
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2010年01月13日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub CBO_MONTH_Change()
        '-----------------------------------------------------------------------------------------------
        Dim intMonth As Integer
        If g_swBatch Then Exit Sub
        intMonth = CInt(CBO_MONTH.Text)
        g_FormDate1 = DateSerial(g_intCurYear, intMonth, 1)
        ' 年月コンボの非表示化
        Call GP_EraseYearMonth
        ' カレンダー作成
        Call GP_MakeCalendar
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :CBO_YEAR_Change
    '* 機能  :「年」コンボの操作イベント
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2010年01月13日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub CBO_YEAR_Change()
        '-----------------------------------------------------------------------------------------------
        Dim intYear As Integer
        If g_swBatch Then Exit Sub
        intYear = CInt(CBO_YEAR.Text)
        g_FormDate1 = DateSerial(intYear, g_intCurMonth, 1)
        ' 年月コンボの非表示化
        Call GP_EraseYearMonth
        ' カレンダー作成
        Call GP_MakeCalendar
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :LBL_PREV_Click
    '* 機能  :「←(前月)」Clickイベント
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2010年01月13日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub LBL_PREV_Click()
        '-----------------------------------------------------------------------------------------------
        ' 年月コンボの非表示化
        Call GP_EraseYearMonth
        ' 前月月初日を設定
        g_FormDate1 = DateSerial(g_intCurYear, g_intCurMonth - 1, 1)
        ' カレンダー作成
        Call GP_MakeCalendar
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :LBL_NEXT_Click
    '* 機能  :「→(翌月)」Clickイベント
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2010年01月13日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub LBL_NEXT_Click()
        '-----------------------------------------------------------------------------------------------
        ' 年月コンボの非表示化
        Call GP_EraseYearMonth
        ' 翌月月初日を設定
        g_FormDate1 = DateSerial(g_intCurYear, g_intCurMonth + 1, 1)
        ' カレンダー作成
        Call GP_MakeCalendar
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :LBL_MONTH_Click
    '* 機能  :「月」Clickイベント
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2010年01月13日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub LBL_MONTH_Click()
        '-----------------------------------------------------------------------------------------------
        Dim intMonth As Integer
        Dim IX As Long, CUR As Long
        ' 年コンボが表示されていたら消去
        Call GP_EraseYear
        ' 月コンボの表示
        g_swBatch = True
        With CBO_MONTH
            .Clear
            For intMonth = 1 To 12
                .AddItem Format(intMonth, "00")
                If intMonth = g_intCurMonth Then CUR = IX
                IX = IX + 1
            Next intMonth
            .ListIndex = CUR
            .Visible = True
            g_VisibleMonth = True
        End With
        g_swBatch = False
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :LBL_YEAR_Click
    '* 機能  :「年」Clickイベント
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2010年01月13日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub LBL_YEAR_Click()
        '-----------------------------------------------------------------------------------------------
        Dim intYear As Integer, intYearSTR As Integer, intYearEND As Integer
        Dim IX As Long, CUR As Long
        ' 月コンボが表示されていたら消去
        Call GP_EraseMonth
        ' 年コンボの表示
        g_swBatch = True
        With CBO_YEAR
            .Clear
            intYearSTR = g_intCurYear - 10
            If intYearSTR < g_cnsYearFrom Then intYearSTR = g_cnsYearFrom
            intYearEND = g_intCurYear + 10
            intYear = Year(Date) + g_cnsYearToAdd
            If intYearEND > intYear Then intYearEND = intYear
            For intYear = intYearSTR To intYearEND
                .AddItem CStr(intYear)
                If intYear = g_intCurYear Then CUR = IX
                IX = IX + 1
            Next intYear
            .ListIndex = CUR
            .Visible = True
            g_VisibleYear = True
        End With
        g_swBatch = False
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :UserForm_Activate
    '* 機能  :フォーム表示(繰り返し表示の場合はHideのみのためInitializeは起きない)
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2018年02月22日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub UserForm_Activate()
        '-----------------------------------------------------------------------------------------------
        ' コンボは非表示
        CBO_YEAR.Visible = False
        CBO_MONTH.Visible = False
        g_VisibleYear = False
        g_VisibleMonth = False
        g_FormDate1 = 0
        '-----------------------------------------------------------------------------------------------
        ' 入力モード(0=セル、1=TextBox)
        If g_intEntMode = 1 Then
            ' 1=TextBox
            ' 元となる日付をテキストボックスから取得
            If IsDate(Trim(g_objTextBox.Text)) Then
                g_FormDate1 = CDate(Trim(g_objTextBox.Text))
            End If
        Else
            ' 0=セル
            ' 元となる日付をセルから取得
            On Error Resume Next
            If IsDate(Trim(g_objRange.Cells(1).Value)) Then
                g_FormDate1 = CDate(Trim(g_objRange.Cells(1).Value))
            End If
            On Error GoTo 0
        End If
        ' 受け取れない場合は当日をセット
        If g_FormDate1 = 0 Then g_FormDate1 = Date
        '-----------------------------------------------------------------------------------------------
        ' カレンダー作成
        Call GP_MakeCalendar
        LBL_GUIDE.Caption = cnsDefaultGuide             ' ガイド表示
        ' 表示位置をマニュアルに変更
        If Me.StartUpPosition <> 0 Then Me.StartUpPosition = 0
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :UserForm_Deactivate
    '* 機能  :フォーム非アクティブ状態
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年02月21日
    '* 作成者 :井上 治
    '* 更新日 :2018年02月21日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:UserForm上からの利用の対応のためモードレスにできないことからこのイベントは発生しない
    '***************************************************************************************************
    Private Sub UserForm_Deactivate()
        '-----------------------------------------------------------------------------------------------
        Me.Hide
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :UserForm_Initialize
    '* 機能  :フォーム初期化(繰り返し表示の場合はHideのみのためInitializeは起きない)
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2018年11月28日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub UserForm_Initialize()
        '-----------------------------------------------------------------------------------------------
        Dim lngIx As Long                                               ' テーブルINDEX
        Dim lngIx2 As Long                                              ' テーブルINDEX
        Dim lngIxC As Long                                              ' カレンダーテーブルINDEX
        Dim dteDate As Date                                             ' 日付WORK
        Dim tblTodayNm As Variant                                       ' 昨日、今日、明日の名称
        Dim tblCalendar() As g_typAboutCalendar2                        ' カレンダーテーブル
        '-----------------------------------------------------------------------------------------------
        ' 各日付ラベルイベントクラスの初期化
        For lngIx = 0 To 44
            Call g_tblDateLabel(lngIx).NewClass(Me.Controls("LBL_" & Format((lngIx + 1), "00")), lngIx)
        Next lngIx
        ' 各固定ラベルイベントクラスの初期化
        Call g_tblFixLabel(0).NewClass(LBL_SUN, cnsDefaultGuide)        ' 日
        Call g_tblFixLabel(1).NewClass(LBL_MON, cnsDefaultGuide)        ' 月
        Call g_tblFixLabel(2).NewClass(LBL_TUE, cnsDefaultGuide)        ' 火
        Call g_tblFixLabel(3).NewClass(LBL_WED, cnsDefaultGuide)        ' 水
        Call g_tblFixLabel(4).NewClass(LBL_THU, cnsDefaultGuide)        ' 木
        Call g_tblFixLabel(5).NewClass(LBL_FRI, cnsDefaultGuide)        ' 金
        Call g_tblFixLabel(6).NewClass(LBL_SAT, cnsDefaultGuide)        ' 土
        Call g_tblFixLabel(7).NewClass(LBL_PREV, "前月に戻ります(PageUp)") ' ←
        Call g_tblFixLabel(8).NewClass(LBL_NEXT, "翌月に進みます(PageDown)") ' →
        Call g_tblFixLabel(9).NewClass(LBL_YM, "年か月を選択します。")  ' 年月
        Call g_tblFixLabel(10).NewClass(LBL_YEAR, "年が選択できます。") ' 年
        Call g_tblFixLabel(11).NewClass(LBL_MONTH, "月が選択できます。") ' 月
        '-----------------------------------------------------------------------------------------------
        ' 起算曜日による曜日見出しの位置修正
        If g_cnsStartYobi = 2 Then
            ' 月曜起算
            LBL_MON.Left = 3
            LBL_MON.Width = 16.75
            LBL_TUE.Left = 20.5
            LBL_WED.Left = 38
            LBL_WED.Width = 17
            LBL_THU.Left = 55.5
            LBL_THU.Width = 16.75
            LBL_FRI.Left = 73
            LBL_SAT.Left = 90.5
            LBL_SUN.Left = 108
            LBL_SUN.Width = 17
        Else
            ' 日曜起算
            LBL_SUN.Left = 3
            LBL_SUN.Width = 16.75
            LBL_MON.Left = 20.5
            LBL_TUE.Left = 38
            LBL_TUE.Width = 17
            LBL_WED.Left = 55.5
            LBL_WED.Width = 16.75
            LBL_THU.Left = 73
            LBL_FRI.Left = 90.5
            LBL_SAT.Left = 108
            LBL_SAT.Width = 17
        End If
        g_tblYobi = Array("(日)", "(月)", "(火)", "(水)", "(木)", "(金)", "(土)")
        '-----------------------------------------------------------------------------------------------
        ' 昨日、今日、明日の処理
        dteDate = Date              ' 今日
        ' カレンダーテーブル作成(当月+前後の3ヶ月用)
        If Not modAboutCalendar2.FP_GetCalendarTable3(Year(dteDate), _
                                                      Month(dteDate), _
                                                      tblCalendar) Then Exit Sub
        ' 昨日に戻す
        dteDate = dteDate - 1
        lngIxC = 0
        ' カレンダー上の昨日の位置を判定
        Do While lngIxC <= UBound(tblCalendar)
            ' 日付発見は抜ける
            If tblCalendar(lngIxC).Hiduke = dteDate Then Exit Do
            ' 次の日へ
            lngIxC = lngIxC + 1
        Loop
        tblTodayNm = Array("[昨日]", "[今日]", "[明日]")
        lngIx2 = 0
        ' 昨日、今日、明日のセット
        For lngIx = 42 To 44
            dteDate = tblCalendar(lngIxC).Hiduke
            ' 日付コントロール情報テーブルのセット
            With g_tblDateLabel(lngIx)
                .Hiduke = dteDate
                .Yobi = tblCalendar(lngIxC).Yobi
                .Syuku = tblCalendar(lngIxC).Syuku
                .StsGuide = tblTodayNm(lngIx2) & Format(dteDate, g_cnsDateFormat) & g_tblYobi(.Yobi)
                ' 祝日か
                If .Syuku <> 0 Then
                    .StsGuide = .StsGuide & " " & tblCalendar(lngIxC).SyukuNm
                End If
            End With
            ' カレンダーテーブル位置を翌日に移動
            lngIxC = lngIxC + 1
            lngIx2 = lngIx2 + 1
        Next lngIx
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :UserForm_KeyDown
    '* 機能  :フォーム上キーボード処理
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(既定)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2010年01月13日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                                 ByVal Shift As Integer)
        '-----------------------------------------------------------------------------------------------
        ' KeyCode(Shift併用)による制御
        Select Case KeyCode
            Case vbKeyReturn, vbKeyExecute, vbKeySeparator  ' Enter(決定)
                Call GP_ClickCalendar(g_CurPos)
            Case vbKeyCancel, vbKeyEscape                   ' Cancel, Esc(終了)
                Me.Hide
            Case vbKeyPageDown                              ' PageDown(次月)
                Call LBL_NEXT_Click
            Case vbKeyPageUp                                ' KeyPageUp(前月)
                Call LBL_PREV_Click
            Case vbKeyRight, vbKeyNumpad6, vbKeyAdd         ' →(翌日)
                Call GP_MoveDay(1)
            Case vbKeyLeft, vbKeyNumpad4, vbKeySubtract     ' ←(前日)
                Call GP_MoveDay(-1)
            Case vbKeyUp, vbKeyNumpad8                      ' ↑(7日後)
                Call GP_MoveDay(-7)
            Case vbKeyDown, vbKeyNumpad2                    ' ↓(7日前)
                Call GP_MoveDay(7)
            Case vbKeyHome                                  ' Home(月初)
                Call GP_MoveDay(g_CurPosF - g_CurPos)
            Case vbKeyEnd                                   ' End(月末)
                Call GP_MoveDay(g_CurPosT - g_CurPos)
            Case vbKeyTab                                   ' Tab(Shiftによる)
                If Shift = 1 Then
                    Call GP_MoveDay(-1)                     ' 前日
                Else
                    Call GP_MoveDay(1)                      ' 翌日
                End If
            Case vbKeyF11                                   ' F11(前年)
                g_FormDate1 = DateSerial(g_intCurYear - 1, g_intCurMonth, 1)
                ' 年月コンボの非表示化
                Call GP_EraseYearMonth
                ' カレンダー作成
                Call GP_MakeCalendar
            Case vbKeyF12                                   ' F11(翌年)
                g_FormDate1 = DateSerial(g_intCurYear + 1, g_intCurMonth, 1)
                ' 年月コンボの非表示化
                Call GP_EraseYearMonth
                ' カレンダー作成
                Call GP_MakeCalendar
        End Select
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :UserForm_MouseMove
    '* 機能  :フォーム上マウス移動
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(既定)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2010年01月13日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub UserForm_MouseMove(ByVal Button As Integer, _
                                   ByVal Shift As Integer, _
                                   ByVal X As Single, ByVal Y As Single)
        '-----------------------------------------------------------------------------------------------
        Me.LBL_GUIDE.Caption = cnsDefaultGuide
    End Sub
    
    '***************************************************************************************************
    ' ■共通サブ処理(Private)
    '***************************************************************************************************
    '* 処理名 :GP_MakeCalendar
    '* 機能  :カレンダー表示
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2018年11月28日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub GP_MakeCalendar()
        '-----------------------------------------------------------------------------------------------
        Dim dteDate As Date                                             ' 日付WORK
        Dim intYobi As Integer                                          ' 曜日位置INDEX
        Dim intYear As Integer                                          ' 指定年
        Dim lngCurStrIx As Long                                         ' 当月開始INDEX
        Dim lngCurEndIx As Long                                         ' 当月終了INDEX
        Dim lngIx As Long                                               ' フォーム上位置INDEX
        Dim lngIx2 As Long                                              ' テーブルINDEX(Work)
        Dim lngIxC As Long                                              ' カレンダーINDEX
        Dim lngIxCMax As Long                                           ' カレンダーINDEX上限
        Dim lngCurPos As Long                                           ' 選択日の位置
        Dim tblCalendar() As g_typAboutCalendar2                        ' カレンダーテーブル
        '-----------------------------------------------------------------------------------------------
        intYear = Year(g_FormDate1)                                 ' 指定年
        ' 指定年月が利用可能かチェック
        If ((intYear < g_cnsYearFrom) Or _
            (intYear > (Year(Date) + g_cnsYearToAdd))) Then
            MsgBox "祝日計算範囲を超えています。", vbExclamation, Me.Caption
            g_FormDate1 = g_tblDateLabel(g_CurPos).Hiduke
        End If
        g_intCurYear = Year(g_FormDate1)                            ' 指定年
        g_intCurMonth = Month(g_FormDate1)                          ' 指定月
        LBL_YM.Caption = g_intCurYear & "年" & Format(g_intCurMonth, "00") & "月"
        '-----------------------------------------------------------------------------------------------
        ' カレンダーテーブル作成(当月+前後の3ヶ月用)
        Call modAboutCalendar2.GP_GetCalendarTable3(g_intCurYear, _
                                                    g_intCurMonth, _
                                                    tblCalendar, _
                                                    lngCurStrIx, _
                                                    lngCurEndIx)
        lngIxCMax = UBound(tblCalendar)
        ' カレンダーテーブル先頭位置
        lngIxC = lngCurStrIx
        ' 指定日付から一旦、前週の最終日(日曜日)に戻す
        lngIxC = lngIxC - tblCalendar(lngCurStrIx).Yobi
        ' 月曜始まり時の調整
        If g_cnsStartYobi = 2 Then
            lngIxC = lngIxC + 1
            ' 2日始まりになってしまう時は1週戻す
            If lngIxC > lngCurStrIx Then lngIxC = lngIxC - 7
        End If
        intYobi = 0
        lngCurPos = -1
        '-----------------------------------------------------------------------------------------------
        ' フォーム上の日付セット(7曜×6週=42件固定⇒0始まり)
        For lngIx = 0 To 41
            ' 当位置の日付、曜日を算出
            intYobi = intYobi + 1
            If intYobi > 7 Then intYobi = 1
            dteDate = tblCalendar(lngIxC).Hiduke
            ' 現在選択日か
            If dteDate = g_FormDate1 Then
                lngCurPos = lngIx
            End If
            ' 日付コントロール情報テーブルのセット
            With g_tblDateLabel(lngIx)
                .Hiduke = dteDate
                .Yobi = tblCalendar(lngIxC).Yobi
                .Syuku = tblCalendar(lngIxC).Syuku
                .StsGuide = Format(dteDate, g_cnsDateFormat) & g_tblYobi(.Yobi)
                ' 祝日か
                If .Syuku <> 0 Then
                    .StsGuide = .StsGuide & " " & tblCalendar(lngIxC).SyukuNm
                End If
            End With
            ' 月初日、月末日の位置を取得
            If lngIxC = lngCurStrIx Then
                ' 当月初日
                g_CurPosF = lngIx
            ElseIf lngIxC = lngCurEndIx Then
                ' 当月末日
                g_CurPosT = lngIx
            End If
            ' ラベルコントロールを配列化した変数
            g_tblDateLabel(lngIx).Label.Caption = Day(dteDate)
            ' 文字色、背景色のセット
            Call GP_SetForeColor(lngIx, g_FormDate1)
            ' カレンダーテーブル位置を翌日に移動
            lngIxC = lngIxC + 1
        Next lngIx
        LBL_GUIDE.Caption = g_tblDateLabel(g_CurPos).StsGuide   ' ガイド表示
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :GP_MoveDay
    '* 機能  :カレンダー上の選択位置移動
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :Arg1 = 移動量(Long)                ※マイナスあり
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2018年11月28日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub GP_MoveDay(lngMove As Long)
        '-----------------------------------------------------------------------------------------------
        Dim lngPos As Long                                              ' テーブル位置INDEX
        Dim dteDate As Date                                             ' 日付Work
        ' 年月コンボの非表示化
        Call GP_EraseYearMonth
        ' 移動後の位置,日付を算出
        lngPos = g_CurPos + lngMove                                 ' 移動後位置
        dteDate = g_FormDate1 + lngMove                             ' 移動後日付
        ' コントロールテーブル外か
        If ((lngPos < 0) Or (lngPos > 41)) Then
            ' 前月又は翌月に移動
            g_FormDate1 = dteDate
            Call GP_MakeCalendar
            Exit Sub
        End If
        '-----------------------------------------------------------------------------------------------
        ' 以前の位置の日付ラベルの背景色を元に戻す
        Call GP_SetForeColor(g_CurPos, dteDate)
        '-----------------------------------------------------------------------------------------------
        ' 現在日付(退避)を更新
        g_FormDate1 = dteDate
        g_CurPos = lngPos
        ' 今回の位置の日付ラベルの背景色を選択状態に変更
        Call GP_SetForeColor(g_CurPos, g_FormDate1)
        LBL_GUIDE.Caption = g_tblDateLabel(g_CurPos).StsGuide   ' ガイド表示
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :GP_SetForeColor
    '* 機能  :文字色、背景色のセット
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :Arg1 = 現在日付位置INDEX(Long)
    '*      Arg2 = 選択日付(Date)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年02月20日
    '* 作成者 :井上 治
    '* 更新日 :2018年11月28日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:位置INDEXはラベルコントロール配列上の位置
    '***************************************************************************************************
    Private Sub GP_SetForeColor(ByVal lngPos As Long, ByVal dteCurDate As Date)
        '-----------------------------------------------------------------------------------------------
        Dim dteDate As Date                                             ' 日付Work
        Dim lngYear As Long                                             ' 現在年
        Dim lngMonth As Long                                            ' 現在月
        With g_tblDateLabel(lngPos)
            dteDate = .Hiduke
            lngYear = Year(dteDate)
            lngMonth = Month(dteDate)
            ' 月度、曜日によりラベルの書式をセット
            .Label.Font.Bold = False
            .Label.ForeColor = cnsFC_Normal
            ' 現在選択日か
            If dteDate = dteCurDate Then
                ' 初期選択日付
                .Label.BackColor = cnsBC_Select
                g_CurPos = lngPos
            ElseIf ((lngYear = g_intCurYear) And (lngMonth = g_intCurMonth)) Then   ' 当月内か
                ' 当月
                Select Case .Yobi
                    Case 0                  ' 日曜日
                        .Label.BackColor = cnsBC_Sunday
                    Case 6                  ' 土曜日
                        .Label.BackColor = cnsBC_Saturday
                    Case Else
                        .Label.BackColor = cnsBC_Month
                End Select
            Else
                ' 当月以外
                .Label.BackColor = cnsBC_Other
            End If
            ' 祝日(含振替休日)の判定
            If .Syuku <> 0 Then
                ' 文字色を赤とする
                .Label.ForeColor = cnsFC_Hori
                ' 当月は太字
                If ((lngYear = g_intCurYear) And (lngMonth = g_intCurMonth)) Then .Label.Font.Bold = True
            End If
        End With
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :GP_ShowGuide
    '* 機能  :ステータスガイド表示
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :Arg1 = 現在日付位置INDEX(Long)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年02月20日
    '* 作成者 :井上 治
    '* 更新日 :2018年11月28日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:位置INDEXはラベルコントロール配列上の位置
    '***************************************************************************************************
    Friend Sub GP_ShowGuide(ByVal lngPos As Long)
        '-----------------------------------------------------------------------------------------------
        LBL_GUIDE.Caption = g_tblDateLabel(lngPos).StsGuide
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :GP_ClickCalendar
    '* 機能  :カレンダークリック
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :Arg1 = 日付コントロール情報テーブルINDEX(Long)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2018年11月28日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Friend Sub GP_ClickCalendar(ByVal lngPos As Long)
        '-----------------------------------------------------------------------------------------------
        g_FormDate1 = g_tblDateLabel(lngPos).Hiduke
        ' 年月コンボの非表示化
        Call GP_EraseYearMonth
        ' 入力モード(0=セル、1=TextBox)
        If g_intEntMode = 1 Then
            ' 1=TextBox
            g_objTextBox.Text = Format(g_FormDate1, g_strDateFormat)
        Else
            ' 0=セル
            g_objRange.Value = g_FormDate1
        End If
        Me.Hide
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :GP_EraseYearMonth
    '* 機能  :「年」「月」コンボの非表示化
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2010年01月13日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub GP_EraseYearMonth()
        '-----------------------------------------------------------------------------------------------
        Call GP_EraseYear
        Call GP_EraseMonth
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :GP_EraseYear
    '* 機能  :「年」コンボの非表示化
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2010年01月13日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub GP_EraseYear()
        '-----------------------------------------------------------------------------------------------
        If g_VisibleYear Then
            CBO_YEAR.Visible = False
            g_VisibleYear = False
        End If
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :GP_EraseMonth
    '* 機能  :「月」コンボの非表示化
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2010年01月13日
    '* 作成者 :井上 治
    '* 更新日 :2010年01月13日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub GP_EraseMonth()
        '-----------------------------------------------------------------------------------------------
        If g_VisibleMonth Then
            CBO_MONTH.Visible = False
            g_VisibleMonth = False
        End If
    End Sub
    
    '***************************************************************************************************
    ' ■■■ プロパティ ■■■
    '***************************************************************************************************
    ' タイトル
    '---------------------------------------------------------------------------------------------------
    Friend Property Let prpTitle(ByVal strTitle As String)
        Me.Caption = strTitle
    End Property
    
    '===================================================================================================
    ' 入力モード(1=セル、2=TextBox)
    '---------------------------------------------------------------------------------------------------
    Friend Property Let prpEntMode(ByVal intValue As Integer)
        g_intEntMode = intValue
    End Property
    
    '===================================================================================================
    ' 対象セル(Object)
    '---------------------------------------------------------------------------------------------------
    Friend Property Set prpRange(ByRef objValue As Range)
        Set g_objRange = objValue
    End Property
    
    '===================================================================================================
    ' 対象TextBox(Object)
    '---------------------------------------------------------------------------------------------------
    Friend Property Set prpTextBox(ByRef objValue As MSForms.TextBox)
        Set g_objTextBox = objValue
    End Property
    
    '===================================================================================================
    ' 日付フォーマット(TextBox時)
    '---------------------------------------------------------------------------------------------------
    Friend Property Let prpDateFormat(ByVal strFormat As String)
        g_strDateFormat = strFormat
    End Property
    
    '------------------------------------------<< End of Source >>--------------------------------------
    
    キーボード操作のイベントは「UserForm_KeyDown」でまとめて受け取っているのが分かると思います。 このような処理方法を実現するには、「ラベル」などフォーカスを受けないコントロールだけで構成する必要があります。 テキストボックスやコマンドボタンなどを配置してしまうと、自動タブでそのテキストボックスやコマンドボタンにフォーカスが移ってしまい、ユーザーフォームレベルではキー操作のイベントが受け取れません。 今回のカレンダーは、年月をクリックした時だけコンボボックスが表示されますが、通常は非表示であって、それ以外は全て「ラベル」です。 ユーザーフォーム上のどのコントロールもフォーカスを受け取らない状態であれば、キー操作のイベントがフォーム自身のイベントで受け取ることができます。

    矢印キーでの「表示カーソル」の移動についての処理が結構簡素なのが分かると思います。 フォーム上は7曜日×6週=42個の「二次元表記」なのですが、内部処理では「昨日」「今日」「明日」を含めた単なる45個の配列で処理しています。 現在の位置INDEXを押さえておいて、「→」なら「+1」、「←」なら「-1」、「↑」なら「-7」、「↓」なら「+7」の位置に移動させるだけです。 移動先が「0」〜「41」の42個の範囲を超える場合は前後の月を表示し直すようにサブ処理側でコントロールさせています。

    「年」「月」のコンボボックスの表示の区別は、もともと上段の年月表示のラベルはひとつしかないのですが、この「年」「月」の表示位置の上に「透明なラベル(LBL_YEAR,LBL_MONTH)」を配して起動させています。 コンボボックス自体は、その上で年月の選択が行なわれたり、他のラベルがクリックされた場合は直ちに消去させてキーボードイベントがフォームで受け取れるようにさせています。

  • 次は、ユーザーフォーム上に配置されたラベルのイベントクラスのコードです。
    まずは日付部分の7曜日×6週=42個と「昨日」「今日」「明日」の計45個の「ラベル」で動作するクラスです。
    
    '***************************************************************************************************
    '   カレンダーフォーム5用日付ラベル                                 clsUF_Cal5Label1(Class)
    '
    '   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
    '***************************************************************************************************
    '変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
    '18/11/28(1.80)新規作成
    '***************************************************************************************************
    Option Explicit
    '===================================================================================================
    Public WithEvents Label As MSForms.Label                        ' 日付ラベル
    Private g_lngIndex As Long                                      ' 位置INDEX(0〜44)
    Private g_dteHiduke As Date                                     ' 日付
    Private g_lngYobi As Long                                       ' 曜日
    Private g_lngSyuku As Long                                      ' 祝日フラグ
    Private g_strGuide As String                                    ' ステータスガイド
    
    '***************************************************************************************************
    '   ■■■ 初期化 ■■■
    '***************************************************************************************************
    '* 処理名 :NewClass
    '* 機能  :クラス初期化
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :Arg1 = ラベル(Object)
    '*      Arg2 = 位置INDEX(Long)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年11月28日
    '* 作成者 :井上 治
    '* 更新日 :2018年11月28日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Public Sub NewClass(ByVal objLabel As MSForms.Label, ByVal lngIx As Long)
        '-----------------------------------------------------------------------------------------------
        Set Label = objLabel
        g_lngIndex = lngIx
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :Label_Click
    '* 機能  :ラベルのクリックイベント
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年11月28日
    '* 作成者 :井上 治
    '* 更新日 :2018年11月28日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub Label_Click()
        '-----------------------------------------------------------------------------------------------
        Call UF_Calendar5.GP_ClickCalendar(g_lngIndex)
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :Label_MouseMove
    '* 機能  :ラベルのMouseMoveイベント
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年11月28日
    '* 作成者 :井上 治
    '* 更新日 :2018年11月28日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub Label_MouseMove(ByVal Button As Integer, _
                                ByVal Shift As Integer, _
                                ByVal X As Single, _
                                ByVal Y As Single)
        '-----------------------------------------------------------------------------------------------
        Call UF_Calendar5.GP_ShowGuide(g_lngIndex)
    End Sub
    
    '***************************************************************************************************
    '   ■■■ プロパティ ■■■
    '***************************************************************************************************
    ' 日付(Date)
    '---------------------------------------------------------------------------------------------------
    Public Property Let Hiduke(ByVal dteDate As Date)
        g_dteHiduke = dteDate
    End Property
    Public Property Get Hiduke() As Date
        Hiduke = g_dteHiduke
    End Property
    
    '===================================================================================================
    ' 曜日(Long)
    '---------------------------------------------------------------------------------------------------
    Public Property Let Yobi(ByVal lngYobi As Long)
        g_lngYobi = lngYobi
    End Property
    Public Property Get Yobi() As Long
        Yobi = g_lngYobi
    End Property
    
    '===================================================================================================
    ' 祝日フラグ(Long)
    '---------------------------------------------------------------------------------------------------
    Public Property Let Syuku(ByVal lngSyuku As Long)
        g_lngSyuku = lngSyuku
    End Property
    Public Property Get Syuku() As Long
        Syuku = g_lngSyuku
    End Property
    
    '===================================================================================================
    ' ステータスガイド(String)
    '---------------------------------------------------------------------------------------------------
    Public Property Let StsGuide(ByVal strGuide As String)
        g_strGuide = strGuide
    End Property
    Public Property Get StsGuide() As String
        StsGuide = g_strGuide
    End Property
    
    '------------------------------------------<< End of Source >>--------------------------------------
    
    大したコードではありませんが、このクラスがユーザーフォームの初期化時に45個生成されます。
    それぞれがClickMouseMoveのイベントを持ち、日付、曜日、祝日、ステータスガイド文字列のプロパティを持っています。 Clickイベントでは選択されたラベルのインデックス情報をカレンダーのユーザーフォームに通知して選択日付を決定する動作を行ない、 MouseMoveイベントではマウスが載った位置の日付情報をカレンダーのユーザーフォームのステータスバーに表示させる役目をします。
    フォントや背景色の変更があるため、クラスにセットされるラベルはPublicスコープに設定させています。

  • 次は、日付以外のラベルのイベントクラスのコードです。
    「←」「→」「年」「月」の他、各曜日の見出し等の計12個のラベルのクラスが生成されます。
    
    '***************************************************************************************************
    '   カレンダーフォーム5用固定ラベル(MouseMoveイベントのみ)          clsUF_Cal5Label2(Class)
    '
    '   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
    '***************************************************************************************************
    '変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
    '18/11/30(1.80)新規作成
    '***************************************************************************************************
    Option Explicit
    '===================================================================================================
    Public WithEvents Label As MSForms.Label                        ' 日付ラベル
    Private g_strGuide As String                                    ' ステータスガイド
    
    '***************************************************************************************************
    '   ■■■ 初期化 ■■■
    '***************************************************************************************************
    '* 処理名 :NewClass
    '* 機能  :クラス初期化
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :Arg1 = ラベル(Object)
    '*      Arg2 = ステータスガイド(String)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年11月30日
    '* 作成者 :井上 治
    '* 更新日 :2018年11月30日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Public Sub NewClass(ByVal objLabel As MSForms.Label, ByVal strGuide As String)
        '-----------------------------------------------------------------------------------------------
        Set Label = objLabel
        g_strGuide = strGuide
    End Sub
    
    '***************************************************************************************************
    '* 処理名 :Label_MouseMove
    '* 機能  :ラベルのMouseMoveイベント
    '---------------------------------------------------------------------------------------------------
    '* 返り値 :(なし)
    '* 引数  :(なし)
    '---------------------------------------------------------------------------------------------------
    '* 作成日 :2018年11月30日
    '* 作成者 :井上 治
    '* 更新日 :2018年11月30日
    '* 更新者 :井上 治
    '* 機能説明:
    '* 注意事項:
    '***************************************************************************************************
    Private Sub Label_MouseMove(ByVal Button As Integer, _
                                ByVal Shift As Integer, _
                                ByVal X As Single, _
                                ByVal Y As Single)
        '-----------------------------------------------------------------------------------------------
        UF_Calendar5.LBL_GUIDE.Caption = g_strGuide
    End Sub
    
    '------------------------------------------<< End of Source >>--------------------------------------
    
    このクラスが担当するのはMouseMoveイベントでのユーザーフォームのステータスバーに表示させる機能のみです。 表示させる文字列もユーザーフォームの初期化時点で決定されてしまい、以降変更はされません。
    Clickイベントの動作は各ラベルで全く異なるため、このクラス内には実装させずにユーザーフォーム側で実装させています。

このような機能は特に「配布の問題」にご注意下さい。
「便利な機能だから社内の皆さんに利用していただけるようにしよう」という発想はすばらしいのですが、 Excelワークブックの場合は社内あちこちに配布してしまうと「機能変更」が発生した場合の更新が大変なことになります。
これらの機能を盛り込んだExcelワークブックを社内各署に配布してしまうと、各現場でその「コピー」も作成されるわけで、 どこまで「機能変更」の対応ができたか、どれだけ残っているのかなどがおそらく「不明」になってしまうということに着目した上で配布方法を検討して下さい。

このページで紹介している機能には祝日判定の機能が含まれており、旧来のソースコードで祝日判定する方法でも、「祝日パラメータ」シートで判定する方法であっても、後から祝日法が変わった場合に変更が必要になります。 配布先にこの変更をどのようにして反映させるのかを最初から検討した上で更新可能な方法を確立して配布するようにして下さい。
また、配布先のどのExcelワークブックがどの改変バージョンになっているのかが判定できるようにすることも必要です。

お勧めなのは、各現場で今回のカレンダー関連ワークブック「コピー」を作らせない方法です。
今回のような「カレンダー周り」の機能は社内全域から参照可能な共有フォルダにアドインとして配置して、各現場に配布するワークブックのマクロからアドイン参照するように仕掛けられれば、 中央の社内全域から参照可能な共有フォルダにあるカレンダーアドインだけをメンテすれば、各現場に配布したワークブックからも開いた時に最新のカレンダーアドインを参照するような構造にすることができると思います。

また、ここで具体例は紹介できませんが「祝日パラメータ」をワークシートとせずに全社から参照可能なデータベーステーブルに保持させて、そこから参照するという方法も考えられます。 もちろん、そのデータベーステーブルを参照できるネットワーク環境下での利用に限られますが。

「祝日パラメータ」シートだけのワークブックを社内全域から参照可能な共有フォルダに配置するという方法もあるのですが、動作レスポンスの問題が若干残ります。

ダウンロードはこちら。
←Calendar5.zip
      (159KB)
「祝日パラメータシート」は使いたくない!
シート構成が変更できないなど「祝日パラメータシート」は使いたくないというご意見もいただきました。 内容は「年間カレンダー作成(祝日パラメータシートを使わない方法)で説明していますが、本機能に反映させたものも用意しました。

ダウンロードはこちら。
←Calendar5R.zip
      (146KB)