VBA:作成したカレンダーフォームを複数のフォームで使用したい

Question

前提・実現したいこと

ユーザーフォームとクラスモジュールを使用して、フォーム上で使用できるカレンダーを作成しました。
カレンダーの日付をクリックすると、指定したテキストボックスにその日付が記入できる仕組みです。
一つのフォームでの呼び出しでは問題なく動作するのですが、その実行コードを残したまま、他のフォームにてカレンダーを起動するとエラーが出てしまいます。
カレンダーの呼び出しを行うフォームが3つあるので、3か所どこから呼び出しても正常に動作してくれるのが理想です。

このエラーが発生する原因と対処法を教えていただきたいです。
よろしくお願いいたします。

発生している問題・エラーメッセージ

実行時エラー'-2147024809(80070057)
指定されたオブジェクトは見つかりません。

カレンダーフォーム(frmCalendar)のコード

コントロールは、コンボボックス２つ（cmbYear, cmbMonth）、スピンボタン１つ（spinbutton1）です。

Option Explicit

Private arrayClass() As New clsCalendar
Public entryControl As String
Public ParentForm As UserForm

Private Function CheckParam() As Boolean
    'コンボボックスの値が指定されていなければ、False
    If cmbYear.Value = "" Then
        CheckParam = False
        Exit Function
    End If
    If cmbMonth.Value = "" Then
        CheckParam = False
        Exit Function
    End If
    CheckParam = True
End Function

Private Sub cmbMonth_Change()
    If CheckParam() Then
        makeCalendar cmbYear.Value, cmbMonth.Value
    End If
End Sub

Private Sub cmbYear_Change()
    If CheckParam() Then
        makeCalendar cmbYear.Value, cmbMonth.Value
    End If
End Sub

Private Sub SpinButton1_Change()

End Sub

Private Sub SpinButton1_SpinDown()
    If cmbMonth.Value = 1 Then
        cmbMonth.Value = 12
        cmbYear.Value = cmbYear.Value - 1
    Else
        cmbMonth.Value = cmbMonth.Value - 1
    End If
End Sub

Private Sub SpinButton1_SpinUp()
    If cmbMonth.Value = 12 Then
        cmbMonth.Value = 1
        cmbYear.Value = cmbYear.Value + 1
    Else
        cmbMonth.Value = cmbMonth.Value + 1
    End If
End Sub


Private Sub UserForm_Initialize()
    Dim lbl As MSForms.Label
    Dim i As Integer, j As Integer, c As Integer
    Dim weekdays() As Variant
    '曜日の設定
    weekdays() = Array("日", "月", "火", "水", "木", "金", "土")
    For i = 1 To 7
        Set lbl = Me.Controls.Add("Forms.Label.1", , True)
        With lbl
            .Caption = weekdays(i - 1)
            .Width = 15
            .Height = 15
            .Left = 5 + (.Width + 2) * (i - 1)
            .Top = 20
            .BorderColor = &H666666
            .BorderStyle = fmBorderStyleSingle
            .Font.Size = 11
        End With
    Next
    c = 1
    For i = 1 To 6  '縦方向
        For j = 1 To 7    '横方向
            Set lbl = Me.Controls.Add("Forms.Label.1", , True)
            With lbl
                .Width = 15
                .Height = 15
                .Left = 5 + (j - 1) * (.Width + 2)
                .Top = 20 + i * (.Height + 2)
                .BorderColor = &H666666
                .BorderStyle = fmBorderStyleSingle
                .Font.Size = 11
                .TextAlign = fmTextAlignRight
                .Name = "D" & c
                ReDim Preserve arrayClass(c)
                arrayClass(c).NewCalendar lbl, Me
                c = c + 1
            End With
        Next
    Next
    '3年前から３年後までの西暦をコンボボックスに追加
    For i = Year(Date) - 3 To Year(Date) + 3
        cmbYear.AddItem i
    Next
    '月をコンボボックスに追加
    For i = 1 To 12
        cmbMonth.AddItem i
    Next
    'コンボボックスに値を代入すると、Changeイベントが発生する
    '現在の西暦と月を表示しておく
    cmbYear.Value = Year(Date)
    cmbMonth.Value = Month(Date)
    'Public変数に呼び出し元のデータを格納
    Set ParentForm = frmCRecordSearch
End Sub

Sub makeCalendar(Nen As Integer, Tsuki As Integer)
    Dim i As Integer, c As Integer
    Dim Weekday_of_firstday As Integer
    Dim LastDay As Integer
    Dim MyDate As Date
    'ラベルの表示をクリア
    For i = 1 To 42
        Controls("D" & i).Caption = ""
    Next
    c = 1
    'その日の曜日を数値として取得
    Weekday_of_firstday = Getweekday1st(Nen, Tsuki)
    LastDay = Day(DateSerial(Nen, Tsuki + 1, 1) - 1) - 1
    For i = Weekday_of_firstday To Weekday_of_firstday + LastDay
        Controls("D" & i).Caption = c
        Controls("D" & i).Tag = CStr(DateSerial(Nen, Tsuki, c))
        Controls("D" & i).ForeColor = vbBlack
        c = c + 1
    Next
    '前月の日付の設定
    MyDate = DateSerial(Nen, Tsuki, 1) - 1
    c = Day(MyDate)
    For i = Weekday_of_firstday - 1 To 1 Step -1
        Controls("D" & i).Caption = c
        Controls("D" & i).Tag = CStr(DateSerial(Year(MyDate), Month(MyDate), c))
        Controls("D" & i).ForeColor = RGB(100, 100, 100)
        c = c - 1
    Next
    '来月の日付の設定
    MyDate = DateSerial(Nen, Tsuki + 1, 1)
    c = 1
    For i = Weekday_of_firstday + LastDay + 1 To 42
        Controls("D" & i).Caption = c
        Controls("D" & i).Tag = CStr(DateSerial(Year(MyDate), Month(MyDate), c))
        Controls("D" & i).ForeColor = RGB(100, 100, 100)
        c = c + 1
    Next
End Sub

Private Function Getweekday1st(Nen As Integer, Tsuki As Integer) As Integer
    '引数の年と月に関して、１日の曜日を数字で取得（日が１、月が２・・・）
    Dim firstDay As Date
    firstDay = DateSerial(Nen, Tsuki, 1)
    Getweekday1st = Weekday(firstDay, vbSunday)
End Function

カレンダーのクラスモジュール(clsCalendar)

Option Explicit

Private WithEvents myLbl As MSForms.Label
Private mForm As UserForm

Public Sub NewCalendar(lbl As MSForms.Label, objForm As UserForm)
    'オブジェクト指向言語ではコントラクタの役割
    Set myLbl = lbl
    Set mForm = objForm
End Sub

Private Sub myLbl_Click()
    'myLblのTagプロパティには、日付が代入されている
    frmCalendar.ParentForm.Controls(frmCalendar.entryControl).Text = myLbl.Tag
    Unload mForm
End Sub

カレンダーの呼び出しコード

コントロールには日付を入れるテキストボックス（yxyDate1, txtDate2）、カレンダーを表示するボタン（btnDispCalendar1, btnDispCalendar2）です。この呼び出しコードを2つ以上のフォームで行おうとするとエラーが発生してしまいます。

Private Sub btnDispCalendar1_Click()
    frmCalendar.entryControl = "txtDate1"
    frmCalendar.Show
End Sub

Private Sub btnDispCalendar2_Click()
    frmCalendar.entryControl = "txtDate2"
    frmCalendar.Show
End Sub

Comments

[imihito]

ParentForm が既定の frmCRecordSearch 固定のようですが、それは意図した動作ですか？（そもそもの動作として、コントロールの名前では無く、オブジェクトそのものを渡した方がスマートな気もします）

[kolobokkule]

すみません、そこの補足を忘れていました。
frmCRecordSearchの部分は、フォームによって変更しています。
オブジェクトで渡した結果、うまく動作するという可能性はありますでしょうか？

Answer 1

カレンダーの呼び出しを行うフォームが3つあるので、3か所どこから呼び出しても正常に動作してくれるのが理想です。

imihitoさんからも指摘がありますが、
Set ParentForm = frmCRecordSearchと対象フォームを固定してしまったら、
呼び出すフォーム毎にカレンダーフォームを作成する必要がありますので、無駄ですよね。

さらに entryControl をオブジェクトとして渡せば、ParentForm変数自体不要です。

クラスモジュール等複雑になっているので、シンプルなモデルでのサンプルコードを提示しておきます。
カレンダーフォームにラベル１つを生成して、それをクリックするとCaptionを対象コントローに代入。

カレンダーフォーム(frmCalendar)のコード

Public entryControl As MSForms.TextBox
Private WithEvents myLbl As MSForms.Label

Private Sub myLbl_Click()
    entryControl.Value = myLbl.Caption
    Unload Me
End Sub

Private Sub UserForm_Initialize()
        Set myLbl = Me.Controls.Add("Forms.Label.1", , True)
        With myLbl
            .Caption = Format(Date, "yyyy/mm/dd")
            .Width = 100
            .Height = 15
            .Left = 20
            .Top = 20
            .BorderColor = &H666666
            .BorderStyle = fmBorderStyleSingle
            .Font.Size = 11
        End With
End Sub

カレンダーの呼び出しコード

Private Sub btnDispCalendar1_Click()
    Set frmCalendar.entryControl = Me.TextDate1
    frmCalendar.Show
End Sub

このように MSForms.TextBox として渡せば、どのフォームから呼び出してもそのテキストボックスに代入されます。また、ワークシート上のテキストボックスでも問題なく代入できます。

別案

自分はこのような時、ユーザーフォームの Property を使って、関数のように使える設計にすることがあります。

カレンダーフォーム(frmCalendar2)のコード

Private ckDate As Date
Private WithEvents myLbl As MSForms.Label

Public Property Get GetDate() As Date
    Me.Show
    GetDate = CDate(ckDate)
    Unload Me
End Property

Private Sub myLbl_Click()
    ckDate = myLbl.Caption
    Me.Hide
End Sub

Private Sub UserForm_Initialize()
        Set myLbl = Me.Controls.Add("Forms.Label.1", , True)
        With myLbl
            .Caption = Format(Date, "yyyy/mm/dd")
            .Width = 100
            .Height = 15
            .Left = 20
            .Top = 20
            .BorderColor = &H666666
            .BorderStyle = fmBorderStyleSingle
            .Font.Size = 11
        End With
End Sub

カレンダーの呼び出しコード

Private Sub btnDispCalendar2_Click()
    Me.TextDate2.Value = frmCalendar2.GetDate()
End Sub

呼び出しが1行ですみますし、代入先は、テキストボックスでもラベルでもシートのセルでもなんでもOKになります。

自分のブログでこのコードの動作原理を解説したトピックを書きましたので参考にしてください。

ユーザーフォームで入力ダイアログを作成する - hatena chips

Comments

[kolobokkule]

回答ありがとうございます。
解答を参考にクラスモジュールの記述を
```
Private Sub myLbl_Click()
'myLblのTagプロパティには、日付が代入されている
frmCalendar.entryControl.Value = myLbl.Tag
Unload mForm
End Sub
```
と書き換え、呼び出しのコードを
```
Private Sub btnDispCalendar1_Click()
Set frmCalendar.entryControl = Me.txtDate1
frmCalendar.Show
End Sub
```
としたところ、理想通りに動作してくれました。
frmCalendar2のほうも試してみたいと思います。
ありがとうございました。

[kolobokkule]

追記ありがとうございます。
ブログのほうも参考にさせていただきます。
まだまだ初心者なので、とても助かりました。