Sibainu Relax Room

愛犬の柴犬とともに過ごす部屋

アフィリエイトの挿入コードを作成するアプリをエクセルで作成2

何事にも耐えなければならないことがあるさ、俺はシャンプーが嫌いだけど耐えるぞという顔している柴犬です。

概要

前回、関数「GetClipboardData」が動かないとありましたが、原因が分かりました。

あまりのイージーミスで唖然としてしてしまいました。

その解決は次の「標準モジュール M_Clipboard の見直し」の中で書いています。大分時間を浪費しました。

ここで今回の Excel での Project の説明をします。

次の画像は プロジェクト エクスプローラー です。

このブックの名前は AffiForm.xlsm とします。

メインフォームの名前は AffiForm （これまで作成したきたフォームです。）

カレンダーフォームの名前は 日付

標準モジュールの名前は M_Clipboard

クラスモジュールの名前は clsCmdWeek

としています。

標準モジュール M_Clipboard の見直し

修正したのは、関数「GetClipboardData」の戻り値の型を Long からLongPtr に変更しただけです。これで関数「GetClipboard」もきちんと動くようになりました。

Private Declare PtrSafe Function GetClipboardData _
        Lib "user32.dll" (ByVal wFormat As Long) As LongPtr

この結果を私は次のように解釈しました。

GetClipboardData は本来 LongPtr型のデータを返すが、ExcelアプリはLong型データ量を指定すればそのデータを受けるようです。結果データ不足が発生します。

Long型の変数にInt型のデータを代入できるように、LongPtr型にLong型のデータを代入できるので型の不一致エラーは発生しないようです。

LongPtr型に変更して受ける iStrPtr の値を見ると桁違いの全く違った値でした。

GlobalLock、GlobalSize は指定したハンドルが無効な場合、またはオブジェクトが破棄された場合なので、戻り値は 0 を返す。

Public Function GetClipboard() As String
    Dim iStrPtr As LongPtr
    Dim iLen As Long
    Dim iLock As LongPtr
    Dim sUniText As String
    Dim res As Long

    Const CF_UNICODETEXT As Long = 13&

    res = OpenClipboard(0&)

    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
        'iStrPtr がLongPtr型で、GetClipboardDataの戻り値がLong型の場合
        '小さいキャパを大きいキャパで受けるのでエラーにならないようです。
        iStrPtr = GetClipboardData(CF_UNICODETEXT)

copy

Option Explicit
'
'-----------------------------------------------------------------
#If VBA7 And Win64 Then

    Private Declare PtrSafe Function OpenClipboard _
        Lib "user32.dll" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function EmptyClipboard _
        Lib "user32.dll" () As Long
    Private Declare PtrSafe Function CloseClipboard _
        Lib "user32.dll" () As Long
    Private Declare PtrSafe Function IsClipboardFormatAvailable _
        Lib "user32.dll" (ByVal wFormat As Long) As Long
    '戻り値の型を    Long → LongPtr
    Private Declare PtrSafe Function GetClipboardData _
        Lib "user32.dll" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function SetClipboardData _
        Lib "user32.dll" (ByVal wFormat As Long, _
                          ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function GlobalAlloc _
        Lib "kernel32.dll" (ByVal wFlags As Long, _
                            ByVal dwBytes As Long) As LongPtr
    Private Declare PtrSafe Function GlobalLock _
        Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock _
        Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function GlobalSize _
        Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function lstrcpy _
        Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As LongPtr, _
                                             ByVal lpString2 As LongPtr) As Long

#Else

メインフォーム AffiForm の機能の追加

最終的フォームの書式で、コードに関係するそれぞれのコントロールの名前を付してあります。

赤色は Label、青色は CommandButton、緑色は TextBox です。

ラベルURLをクリックするとクリップボードを貼り付ける

標準モジュールの関数「GetClipboardData」が使えるようになったので、ラベルの「URL」をクリックすると隣のテキストボックスにクリップボードのデータが張り付くようにしました。

これでクリックするだけで張り付くようになりかなり省力化できました。

ラベルのコントロール名は上から CBPictureURL CBTopURL CBRakutenURL CBAmazonURL CBKindleURL とし、それぞれテキストボックス PictureURL TopURL RakutenURL AmazonURL KindleURL に張り付くように命名しています。

フォームの追加コード

5つの URL と表示したラベルをクリックすると、ラベルのコントロール名から CB を取り去った名称のコントロール名の値にクリップボードの値を代入するということをしています。

copy

'
'-----------------------------------------------------------------
Private Sub CBPictureURL_Click()

    Call setClipboardPaste("CBPictureURL")

End Sub
'
'-----------------------------------------------------------------
Private Sub CBTopURL_Click()

    Call setClipboardPaste("CBTopURL")

End Sub
'
'-----------------------------------------------------------------
Private Sub CBRakutenURL_Click()

    Call setClipboardPaste("CBRakutenURL")

End Sub
'
'-----------------------------------------------------------------
Private Sub CBAmazonURL_Click()

    Call setClipboardPaste("CBAmazonURL")

End Sub
'
'-----------------------------------------------------------------
Private Sub CBKindleURL_Click()

    Call setClipboardPaste("CBKindleURL")

End Sub
'
'-----------------------------------------------------------------
Private Sub setClipboardPaste(laName As String)

    Me(Replace(laName, "CB", "")).Value = GetClipboard

End Sub

作成日をダブルクリックするとフォーム 日付 が開く

テキストボックス MakeDate をダブルクリックすると下の画像のようにカレンダーが開き希望する日付をクリックするとその日にちがテキストボックス MakeDate に挿入されます。

MakeDate の横に新たにテキストボックス「DateZiyu」を作りました。「現在」と文字が入っています。

フォーム AffiForm の追加コード

テキストボックス「MakeDate」をダブルクリックするとフォーム「日付」が開くコードです。

copy

'
'-----------------------------------------------------------------
Private Sub MakeDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim UF As UserForm

    CalendarDate = Me.MakeDate.Value

    日付.Show
    
    For Each UF In UserForms
        If TypeOf UF Is 日付 Then
            If 日付.Value = 0 Then
                Me.MakeDate.Value = ""
            Else
                Me.MakeDate.Value = Format(日付.Value, "yyyy年m月d日")
            End If
            Unload 日付
        End If
    Next UF

End Sub

フォーム AffiForm の変更コード

copy

'
'-----------------------------------------------------------------
Private Sub クリップボード_Click()

    myText = ""

    Call makemyText

    Call setPicturURL

    Call setTopURL

    Call setRakutenURL

    Call setAmazonURL

    If myText <> "" Then

        myText = Replace(myText, "#DetailText#", Me.DetailText.Value)
　      'テキストボックス DateZiyu を追加したので変更します。
        myText = Replace(myText, "#MakeDate#", Me.MakeDate & Me.DateZiyu.Value)

        Call SetClipboard(myText)
        
        'これはできませんでした。
        'With New DataObject
        '    .SetText myText
        '    .PutInClipboard
        'End With
    Else
        MsgBox "データを作成できませんでした。"
    End If
    
End Sub

標準モジュール M_Clipboard に追加

標準モジュールに次のグローバル変数を追加します。

この変数に、テキストボックス「MakeDate」をダブルクリックしたときの「MakeDate」の値を格納して、カレンダーフォーム「日付」がその値を取得してその日付を明示します。

Public CalendarDate         As String

copy

Option Explicit

'追加はこの行のみ
Public CalendarDate         As String
'
'--------------------------------------------------------------------------------
#If VBA7 And Win64 Then

フォーム 日付

VBエディターで見るフォーム

コントロールの名前

赤文字のコントロールは Label、青色は CommandButton、緑色は TextBox です。

フォーム 日付 のコード

copy

Option Explicit

Private cmdWeekBtn(1 To 42)     As clsCmdWeek

Const SHIFT_MASK = 1
Private mOldDate As Date
Private Const adhcFirstDayOfWeek = vbSunday
Private Const adhcColorSunday = vbRed
Private Const adhcColorSaturday = vbBlue
Private Const adhcColorWeekday = vbBlack

Private Const adhcDayStr    As String = "d"
Private Const adhcMonthStr  As String = "m"
Private Const adhcYearStr   As String = "yyyy"
Private Const adhcWeekStr   As String = "ww"

Private Enum DirectionType
    dtMoveForward = 0
    dtMoveBackward = -1
End Enum

Private mdtmStartDate       As Date
Private mintFirstDay        As Integer
Private mastrDays(1 To 7)   As String
Private mintStartDOW        As Integer
Private lblTop(1 To 7)      As Integer

Private mintYearToday       As Integer
Private mintMonthToday      As Integer
Private mintDayToday        As Integer

Private mintYear            As Integer
Private mintMonth           As Integer
Private mintDay             As Integer

Private mvarMonthLen        As Variant
Private mstrSelected        As String

Public Property Get Value() As Date

    Value = DateSerial(mintYear, mintMonth, mintDay)
     
End Property

Public Property Let Value(ByVal DateValue As Date)

    Call FillInStartValues(DateValue)
     
End Property

'----------------------------------------------------------------
Private Sub Cancel_Click()

    Unload Me
    
End Sub
'
'-----------------------------------------------------------------
Private Sub Delete_Click()

    Me.Value = 0
    Me.Hide
    
End Sub
'
'-----------------------------------------------------------------
Private Sub UserForm_Initialize()
Dim BUF         As Variant
Dim I           As Integer
Dim J           As Integer
 
    buDummy.SetFocus

    For I = 1 To 42
        ' インスタンスの生成
        Set cmdWeekBtn(I) = New clsCmdWeek
        J = (((I - 1) \ 7) + 1) * 10 + (I - 1) Mod 7 + 1
        With cmdWeekBtn(I)
            .Item = Me("lbl" & J)
            .Index = I
            .Caller = Me
        End With
    Next I

    lblTop(1) = lbl11.Top
    For I = 2 To 6
        lblTop(I) = lblTop(I - 1) + lbl11.Height
    Next I

    '--------月の日数の配列　0はダミー値
    mvarMonthLen = Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)

    '--------引数firstdayofweek　最初に来る曜日を日曜日に指定
    '        Left$はLeftより処理速度が早い
    For I = 1 To 7
        mastrDays(I) = Left$(WeekdayName(I, FirstDayOfWeek:=vbSunday), 1)
    Next I

    BUF = Replace(StrConv(CalendarDate, vbNarrow), ".", "/")
    If IsDate(BUF) Then
        BUF = CDate(BUF)
    Else
        BUF = Date
    End If

    '--------年月日の要素を取り出す
    mintDayToday = DatePart(adhcDayStr, BUF)
    mintMonthToday = DatePart(adhcMonthStr, BUF)
    mintYearToday = DatePart(adhcYearStr, BUF)

    '--------日曜日をファーストデイにする
    mintFirstDay = adhcFirstDayOfWeek

    '--------フォームを開くときに渡されたパラメーターを処理する
    '        パラメーターが無ければ今日の日とする
    Call FillInStartValues(BUF)
                                                                                
    '--------カンレダー部の曜日、色描写
    FixUpDisplay

    '--------カンレダー部の日付描写
    DisplayCal
    
End Sub
'フォームを開くときの最初の日付を設定
'-----------------------------------------------------------------
Private Sub FillInStartValues(ByVal myDate As Long)

    mdtmStartDate = myDate

    Call SetUpPublics
    
End Sub
'プロパティValueに代入されたとき実行するプロシージャでもある
'-----------------------------------------------------------------
Private Sub SetUpPublics()

    '--------最初の日付の要素を変数に代入
    '        または、プロパティValueの値を代入
    mintMonth = DatePart(adhcMonthStr, mdtmStartDate)
    mintYear = DatePart(adhcYearStr, mdtmStartDate)
    mintDay = DatePart(adhcDayStr, mdtmStartDate)
    
    Call SetDisplayDate
    
End Sub
'プロパティYear,Monthの値をテキストボックスに表示
'-----------------------------------------------------------------
Private Sub SetDisplayDate()

    txtMonth = Format(DateSerial(mintYear, mintMonth, 1), "m月")
    txtYear = Format(DateSerial(mintYear, mintMonth, 1), "yyyy年")
    
End Sub
'
'-----------------------------------------------------------------
Private Sub FixUpDisplay()
Dim intCol              As Integer
Dim intRow              As Integer
Dim intLogicalDay       As Integer
Dim intDiff             As Integer
Dim lngForeColor        As Long

    For intCol = 1 To 7

        '--------列順番と曜日順番の調整
        intLogicalDay = (((intCol - 1) + (mintFirstDay - 1)) Mod 7) + 1

        Select Case intLogicalDay
        Case 1
            lngForeColor = adhcColorSunday
        Case 7
            lngForeColor = adhcColorSaturday
        Case Else
            lngForeColor = adhcColorWeekday
        End Select

        '--------曜日ラベル
        With Me("lblDay" & intCol)
            .Caption = mastrDays(intLogicalDay)
            .ForeColor = lngForeColor
        End With

    Next intCol

End Sub
'DateCalendarの日付の描写
'-----------------------------------------------------------------
Private Sub DisplayCal()
Static fInHere As Boolean

    If fInHere Then Exit Sub
    
    fInHere = True

    '--------月の1日の週日
    mintStartDOW = FirstDOM(mintMonth, mintYear)

    '--------DateCalendarの日付の描写
    ShowDate mintStartDOW

    fInHere = False

End Sub
'
'-----------------------------------------------------------------
Private Function FirstDOM(intMonth As Integer, intYear As Integer) As Integer

    '--------月の1日が、日曜日を初日とする週の何日目
    FirstDOM = DatePart("w", DateSerial(intYear, intMonth, 1), mintFirstDay)

End Function
'
'-----------------------------------------------------------------
Private Sub ShowDate(intStartDay As Integer)
Dim newSelected             As String

    '--------DateCalendarの日付の描写
    FixDaysInMonth intStartDay

    newSelected = "lbl" & ButtonGrid(mintDay, intStartDay)

    '--------凹みの描写
    HandleIndent newSelected

End Sub
'
'-----------------------------------------------------------------
Private Sub FixDaysInMonth(intStartDay As Integer)
Dim intRow              As Integer
Dim intCol              As Integer
Dim intNumDays          As Integer
Dim intCount            As Integer
Dim strTemp             As String
Dim lngForeColor        As Long

    If mintMonth <> 2 Then
        '--------2月以外の場合
        intNumDays = mvarMonthLen(mintMonth)
    Else
        '--------2月の場合(3月1日の1日前)
        intNumDays = DatePart(adhcDayStr, DateSerial(mintYear, 3, 1) - 1)
    End If

    If mintDay > intNumDays Then
        '--------月、年を更新した場合、1/31⇒2/28等の処理
        mintDay = intNumDays
    End If

    intCount = 0
    For intRow = 1 To 6
        '--------DateCalendarの日付の描写
        For intCol = 1 To 7
            If (intRow = 1) And (intCol < intStartDay) Then
                Me("lbl1" & intCol).Visible = False
            Else
                intCount = intCount + 1
                strTemp = "lbl" & intRow & intCol
                With Me(strTemp)
                    If intCount <= intNumDays Then
                        If Not .Visible Then
                            .Visible = True
                        End If
                        .Caption = intCount
                        Select Case Kyujitu(DateSerial(mintYear, mintMonth, intCount))
                        Case 1
                            lngForeColor = adhcColorSunday
                        Case 7
                            lngForeColor = adhcColorSaturday
                        Case Else
                            lngForeColor = adhcColorWeekday
                        End Select
                        .ForeColor = lngForeColor
                    Else
                        If .Visible Then
                            .Visible = False
                        End If
                    End If
                End With
            End If
        Next intCol
    Next intRow
    
    For intRow = 1 To 6
        For intCol = 1 To 7
            If Not Me.lbl51.Visible And Not Me.lbl61.Visible Then
                strTemp = "lbl" & intRow & intCol
                Me(strTemp).Top = lblTop(intRow) + lbl11.Height
            ElseIf Me.lbl51.Visible And Not Me.lbl61.Visible Then
                strTemp = "lbl" & intRow & intCol
                Me(strTemp).Top = lblTop(intRow) + lbl11.Height * 0.5
            Else
                strTemp = "lbl" & intRow & intCol
                Me(strTemp).Top = lblTop(intRow)
            End If
        Next intCol
    Next intRow
    
End Sub
'
'-----------------------------------------------------------------
Private Function ButtonGrid(wDay As Integer, intStartDay As Integer) As String
Dim Index               As Integer
Dim iGrid               As Integer
    
    Index = wDay + intStartDay - 1
    iGrid = (((Index - 1) \ 7) + 1) * 10 + (Index - 1) Mod 7 + 1
    ButtonGrid = iGrid

End Function
'
'-----------------------------------------------------------------
Private Sub HandleIndent(strNewSelect As String)

    If Len(mstrSelected) > 0 Then
        '--------新しい日にちが選択された場合、前の日にちの凹みを凸に戻す
        If mstrSelected <> strNewSelect Then
            With Me(mstrSelected)
                .SpecialEffect = fmSpecialEffectRaised
                .BackColor = vbButtonFace
            End With
        End If
    End If

    mstrSelected = strNewSelect

    With Me(mstrSelected)
        '--------新しい日にちを凹みにする
        .SpecialEffect = fmSpecialEffectBump
        .BackColor = vbYellow
    End With

    '--------凹みの日にちをフォームの日にちにする
    mintDay = Me(mstrSelected).Caption

End Sub
'日付をクリックした時に実行する関数
'-----------------------------------------------------------------
Private Function HandleSelected(strName As String)

    HandleIndent strName
    
End Function
'日付をダブルクリックした時に実行する関数
'-----------------------------------------------------------------
Private Function SelectDate(strName As String)

    HandleIndent strName
    
    Me.Hide
    
End Function
'
'-----------------------------------------------------------------
Private Sub cmdNextYear_Click()
    
    buDummy.SetFocus
    
    Call NextYear
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdPreviousYear_Click()
    
    buDummy.SetFocus
    
    Call PreviousYear
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdNextMonth_Click()
    
    buDummy.SetFocus
    
    Call NextMonth
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdPreviousMonth_Click()
    
    buDummy.SetFocus
    
    Call PreviousMonth
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdPreviousMonth_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                                     ByVal Shift As Integer)

    HandleKeys KeyCode, Shift
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdNextYear_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                                ByVal Shift As Integer)

    HandleKeys KeyCode, Shift
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdPreviousYear_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                                    ByVal Shift As Integer)

    HandleKeys KeyCode, Shift
    
End Sub
'
'-----------------------------------------------------------------
Private Sub cmdNextMonth_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                                 ByVal Shift As Integer)

    HandleKeys KeyCode, Shift
    
End Sub
'
'-----------------------------------------------------------------
Private Sub buDummy_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
                            ByVal Shift As Integer)

    HandleKeys KeyCode, Shift
    
End Sub
'
'-----------------------------------------------------------------
' Leftarrow 　　　  = Previous Day
' Shift-Leftarrow   = Previous Year
' Rightarrow 　　　 = Next Day
' Shift-Rightarrow  = Next Year
' Uparrow           = Previous week
' Shift-Uparrow 　　= Previous Month
' Dnarrow           = Next Week
' Shift-Dnarrow     = Next Month
' PgUp              = Previous Month
' Shift-PgUp        = Previous Year
' PgDn              = Next Month
' Shift-PgDn        = Next Year
' Home              = Move to Today
' Shift-Home        = Move to today in selected year.
Private Sub HandleKeys(ByRef KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim ShiftDown As Boolean

    ShiftDown = (Shift And SHIFT_MASK)

    Select Case KeyCode.Value
        Case vbKeyEscape
            Unload Me
        Case vbKeyReturn
            Me.Hide
        Case vbKeyHome
            If ShiftDown Then
                Call MoveToToday(False)
            Else
                Call MoveToToday(True)
            End If
        Case vbKeyPageUp
            If ShiftDown Then
                Call PreviousYear
            Else
                Call PreviousMonth
            End If
        Case vbKeyPageDown
            If ShiftDown Then
                Call NextYear
            Else
                Call NextMonth
            End If
        Case vbKeyRight
            If ShiftDown Then
                Call NextYear
            Else
                Call NextDay
            End If
        Case vbKeyLeft
            If ShiftDown Then
                Call PreviousYear
            Else
                Call PreviousDay
            End If
        Case vbKeyUp
            If ShiftDown Then
                Call PreviousMonth
            Else
                Call PreviousWeek
            End If
        Case vbKeyDown
            If ShiftDown Then
                Call NextMonth
            Else
                Call NextWeek
            End If
    End Select

    KeyCode.Value = 0
    
End Sub
'
'-----------------------------------------------------------------
Public Sub Today()

    Call MoveToToday(True)
    
End Sub
'
'-----------------------------------------------------------------
Public Sub NextDay()

    ChangeDate adhcDayStr, dtMoveForward
    
End Sub
'
'-----------------------------------------------------------------
Public Sub NextMonth()

    ChangeDate adhcMonthStr, dtMoveForward
     
End Sub
'
'-----------------------------------------------------------------
Public Sub NextYear()

    ChangeDate adhcYearStr, dtMoveForward
    
End Sub
'
'-----------------------------------------------------------------
Public Sub NextWeek()

    ChangeDate adhcWeekStr, dtMoveForward
    
End Sub
'
'-----------------------------------------------------------------
Public Sub PreviousDay()

    ChangeDate adhcDayStr, dtMoveBackward
    
End Sub
'
'-----------------------------------------------------------------
Public Sub PreviousMonth()

    ChangeDate adhcMonthStr, dtMoveBackward
    
End Sub
'
'-----------------------------------------------------------------
Public Sub PreviousYear()

    ChangeDate adhcYearStr, dtMoveBackward
    
End Sub
'
'-----------------------------------------------------------------
Public Sub PreviousWeek()

    ChangeDate adhcWeekStr, dtMoveBackward
    
End Sub
'
'-----------------------------------------------------------------
Private Sub ChangeDate(strMoveUnit As String, dt As DirectionType)
Dim intMonth        As Integer
Dim intYear         As Integer
Dim intDay          As Integer
Dim dtmDate         As Date
Dim dtmOldDate      As Date
Dim intInc          As Integer
On Error GoTo ERROR_SHORI

    intYear = mintYear
    intMonth = mintMonth
    intDay = mintDay

    If dt = dtMoveForward Then
        intInc = 1
    Else
        intInc = -1
    End If
    dtmOldDate = DateSerial(intYear, intMonth, intDay)
    '--------年・月・日をインクリメント・デクリメント
    dtmDate = DateAdd(strMoveUnit, intInc, dtmOldDate)

    intMonth = DatePart(adhcMonthStr, dtmDate)
    intYear = DatePart(adhcYearStr, dtmDate)
    intDay = DatePart(adhcDayStr, dtmDate)

    If mintMonth = intMonth And mintYear = intYear Then
        HandleIndent "lbl" & ButtonGrid(intDay, mintStartDOW)
    Else
        mintDay = intDay
        mintMonth = intMonth
        mintYear = intYear

        '--------プロパティYear,Monthの値をテキストボックスに表示
        Call SetDisplayDate

        '--------DateCalendarの日付の描写
        Call DisplayCal
        
    End If

OWARI:
    Exit Sub

ERROR_SHORI:
    Resume OWARI
    
End Sub
'
'-----------------------------------------------------------------
Private Sub MoveToToday(UseCurrentYear As Boolean)

    mintMonth = mintMonthToday
    If UseCurrentYear Then
        mintYear = mintYearToday
    End If
    
    mintDay = mintDayToday

    '--------プロパティYear,Monthの値をテキストボックスに表示
    Call SetDisplayDate

    '--------DateCalendarの日付の描写
    Call DisplayCal
    
End Sub
'ロング値で与えられた日付の休日判定を行ないます。
'-----------------------------------------------------------------
Private Function Kyujitu(lDate As Long) As Integer
Dim myYear          As Integer
Dim ResWeekNum      As Integer
Dim FLG             As Boolean
Dim I               As Integer
Dim J               As Integer
Dim k               As Integer
Dim iCount          As Integer
Dim lDay            As Long
Dim DateBUF         As Long
Dim lKyujitu()      As Long
Dim lKokumin()      As Long
Dim lKanrei()       As Long
Dim lHurikae()      As Long

    myYear = Year(lDate)
    ResWeekNum = Weekday(lDate)

    '----------値の初期化
    ReDim lKyujitu(0)
        lKyujitu(0) = 0
    ReDim lHurikae(0)
        lHurikae(0) = 0
    ReDim lKokumin(0)
        lKokumin(0) = 0
    ReDim lKanrei(0)
        lKanrei(0) = 0

    '----------祝祭日のセット
    If ResWeekNum <> 1 And lDate > DateSerial(1948, 7, 19) Then

        '----------元日
        iCount = 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 1, 1)

        '----------成人の日　１月１５日　→　１月の第２月曜
        If myYear > 1949 And myYear < 2000 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 1, 15)
        ElseIf myYear > 1999 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 1, 8) + _
                               ((9 - Weekday(DateSerial(myYear, 1, 8))) Mod 7)
        End If
        
        iCount = iCount + 1  '----------建国記念の日
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 2, 11)

        '----------天皇誕生日
        If myYear > 2018 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
                lKyujitu(iCount) = DateSerial(myYear, 2, 23)
        End If

        iCount = iCount + 1  '----------春分の日
        ReDim Preserve lKyujitu(iCount)
            'int(19.8277+0.242194*(年-1980)-int((年-1983)/4))
            '----------1851-1899年通用
            'int(20.8357+0.242194*(年-1980)-int((年-1983)/4))
            '----------1900-1979年通用
            'int(20.8431+0.242194*(年-1980)-int((年-1980)/4))
            '----------1980-2099年通用
            'int(21.8510+0.242194*(年-1980)-int((年-1980)/4))
            '----------2100-2150年通用
            
            Select Case myYear
            Case Is < 2100
                DateBUF = Int(20.8431 + 0.242194 * (myYear - 1980) - Int((myYear - 1980) / 4))
            Case Is >= 2100
                DateBUF = Int(20.851 + 0.242194 * (myYear - 1980) - Int((myYear - 1980) / 4))
            End Select
            lKyujitu(iCount) = DateSerial(myYear, 3, DateBUF)

        '----------天皇誕生日→みどりの日→昭和の日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 4, 29)

        '----------憲法記念日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 5, 3)

        '----------みどりの日
        If myYear > 2006 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 5, 4)
        End If

        '----------こどもの日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 5, 5)

        '----------海の日　７月２０日　→　７月の第３月曜日
        If myYear > 1995 And myYear < 2003 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 7, 20)
        ElseIf myYear > 2002 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 7, 15) + _
                               ((9 - Weekday(DateSerial(myYear, 7, 15))) Mod 7)
        End If

        '----------山の日
        If myYear > 2015 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 8, 11)
        End If

        '----------敬老の日　９月１５日　→　９月の第３月曜日
        If myYear > 1965 And myYear < 2003 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 9, 15)
        ElseIf myYear > 2002 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 9, 15) + _
                               ((9 - Weekday(DateSerial(myYear, 9, 15))) Mod 7)
        End If

        '----------秋分の日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            'int(22.2588+0.242194*(年-1980)-int((年-1983)/4))
            '----------1851-1899年通用
            'int(23.2588+0.242194*(年-1980)-int((年-1983)/4))
            '----------1900-1979年通用
            'int(23.2488+0.242194*(年-1980)-int((年-1980)/4))
            '----------1980-2099年通用
            'int(24.2488+0.242194*(年-1980)-int((年-1980)/4))
            '----------2100-2150年通用
            Select Case myYear
            Case Is < 2100
                DateBUF = Int(23.2488 + 0.242194 * (myYear - 1980) - Int((myYear - 1980) / 4))
            Case Is >= 2100
                DateBUF = Int(24.2488 + 0.242194 * (myYear - 1980) - Int((myYear - 1980) / 4))
            End Select
            lKyujitu(iCount) = DateSerial(myYear, 9, DateBUF)

        '----------体育の日　１０月１０日　→　１０月の第二月曜日
        If myYear > 1965 And myYear < 2000 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 10, 10)
        ElseIf myYear > 1999 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 10, 8) + _
                               ((9 - Weekday(DateSerial(myYear, 10, 8))) Mod 7)
        End If

        '----------文化の日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 11, 3)

        '----------勤労感謝の日
        iCount = iCount + 1
        ReDim Preserve lKyujitu(iCount)
            lKyujitu(iCount) = DateSerial(myYear, 11, 23)

        '----------天皇誕生日
        If myYear > 1988 And myYear < 2018 Then
            iCount = iCount + 1
            ReDim Preserve lKyujitu(iCount)
                lKyujitu(iCount) = DateSerial(myYear, 12, 23)
        End If

        '----------祝祭休日の判定
        For I = 1 To UBound(lKyujitu())
            If lKyujitu(I) = lDate Then
                ResWeekNum = 1
            End If
        Next I
    End If

    '----------振り替え休日の判定
    If ResWeekNum <> 1 And myYear > 1972 Then

        '----------値の初期化
        iCount = 0
        FLG = False
        DateBUF = 0
        For lDay = DateSerial(myYear, 1, 1) To DateSerial(myYear, 12, 31)

            If Weekday(lDay) = vbSunday Then
                For I = 1 To UBound(lKyujitu())
                    '----------日曜日で祝日であること
                    If lKyujitu(I) = lDay Then
                        FLG = True
                        DateBUF = lDay
                    End If
                Next I
            End If

            '----------翌日の判定
            If FLG = True And lDay = DateBUF + 1 Then
                    
                FLG = False
                DateBUF = 0
                '----------祝日のチェック
                For I = 1 To UBound(lKyujitu())
                    If lKyujitu(I) = lDay Then
                        '----------祝休日該当
                        FLG = True
                        DateBUF = lDay
                    End If
                Next I

                '----------祝日に該当しない場合、振替日にする
                If FLG = False Then
                    iCount = iCount + 1
                    ReDim Preserve lHurikae(iCount)
                        lHurikae(iCount) = lDay
                        FLG = False
                        DateBUF = 0
                End If
            End If
        Next lDay

        '----------振り替え休日の判定
        If UBound(lHurikae()) > 0 Then
            For I = 1 To UBound(lHurikae())
                If lHurikae(I) = lDate Then
                    ResWeekNum = 1
                End If
            Next I
        End If
    End If

    '----------国民の休日の判定
    If ResWeekNum <> 1 And myYear > 1987 Then
        '----------値の初期化
        iCount = 0
        For I = 1 To UBound(lKyujitu()) - 1
            For J = I + 1 To UBound(lKyujitu())
                '----------挟まれた日が休日かどうかチェックします
                If Abs(lKyujitu(J) - lKyujitu(I)) = 2 Then
                    FLG = False
                    For k = 1 To iCount
                        If lKyujitu(k) = (lKyujitu(I) + lKyujitu(J)) / 2 Then
                            FLG = True
                        End If
                    Next k
                    '----------挟まれた日が休日でない場合その日を追加登録します
                    If FLG = False Then
                        iCount = iCount + 1
                        ReDim Preserve lKokumin(iCount)
                        lKokumin(iCount) = (lKyujitu(I) + lKyujitu(J)) / 2
                    End If
                End If
            Next J
        Next I

        '----------国民の休日の判定
        If UBound(lKokumin()) > 0 Then
            For I = 1 To UBound(lKokumin())
                If lKokumin(I) = lDate Then
                    ResWeekNum = 1
                End If
            Next I
        End If
    End If

    '----------慣例になっている休日の判定
    If ResWeekNum <> 1 Then
        ReDim Preserve lKanrei(3)
            lKanrei(1) = DateSerial(myYear, 1, 2)
            lKanrei(2) = DateSerial(myYear, 1, 3)
            lKanrei(3) = DateSerial(myYear, 12, 31)

        For I = 1 To UBound(lKanrei())
            If lKanrei(I) = lDate Then
                ResWeekNum = 1
            End If
        Next I
    End If

    Erase lHurikae()
    Erase lKyujitu()
    Erase lKokumin()
    Erase lKanrei()
    
    Kyujitu = ResWeekNum

End Function
'
'-----------------------------------------------------------------
Public Sub RaiseClick(ByVal Index As Integer)
Dim iGrid               As Integer

    iGrid = (((Index - 1) \ 7) + 1) * 10 + (Index - 1) Mod 7 + 1
    If Me("lbl" & iGrid).BackColor = vbYellow Then
        Call SelectDate("lbl" & iGrid)
    Else
        Call HandleSelected("lbl" & iGrid)
    End If
    
End Sub
'
'-----------------------------------------------------------------
Public Sub RaiseDblClick(ByVal Index As Integer)
Dim iGrid               As Integer

    iGrid = (((Index - 1) \ 7) + 1) * 10 + (Index - 1) Mod 7 + 1
    Call SelectDate("lbl" & iGrid)

End Sub
'
'-----------------------------------------------------------------
Private Sub UserForm_MouseMove(ByVal Button As Integer, _
                               ByVal Shift As Integer, _
                               ByVal X As Single, _
                               ByVal Y As Single)

    Call CalMousePoint(0)

End Sub
'
'-----------------------------------------------------------------
Public Sub RaiseMouseMove(ByVal Index As Integer)

    Call CalMousePoint(Index)

End Sub
'
'-----------------------------------------------------------------
Private Sub CalMousePoint(ByVal Index As Integer)
Dim I As Integer
Dim J As Integer

    For I = 1 To 6
        For J = 1 To 7
            With Me("lbl" & I & J)
                If (((I - 1) * 7 + J) = Index) Then
                    If (.BackColor = Me.BackColor) Then
                        .BackColor = 16764159
                    End If
                Else
                    If (.BackColor <> Me.BackColor) And _
                       (.SpecialEffect <> fmSpecialEffectBump) Then
                        .BackColor = Me.BackColor
                    End If
                End If
            End With
        Next J
    Next I
    
End Sub
'
'-----------------------------------------------------------------
Private Sub UserForm_Terminate()
Dim I               As Integer

    For I = 1 To 42
        ' インスタンスの破棄
        Set cmdWeekBtn(I) = Nothing
    Next

End Sub

クラスモジュール clsCmdWeek

全コード

copy

Option Explicit

Private WithEvents MyLbl    As MSForms.Label
Private MyIndex             As Integer
Private MyCaller            As Object    
'
'-----------------------------------------------------------------
Public Property Let Item(NewCtrl As MSForms.Label)
    Set MyLbl = NewCtrl
End Property
'
'-----------------------------------------------------------------
Public Property Let Index(NewIndex As Integer)
    MyIndex = NewIndex
End Property
'
'-----------------------------------------------------------------
Public Property Let Caller(NewCaller As Object)
    Set MyCaller = NewCaller
End Property
'
'-----------------------------------------------------------------
Private Sub MyLbl_Click()
    Call MyCaller.RaiseClick(MyIndex)       
End Sub
'
'-----------------------------------------------------------------
Private Sub MyLbl_MouseMove(ByVal Button As Integer, _
                            ByVal Shift As Integer, _
                            ByVal X As Single, _
                            ByVal Y As Single)
    Call MyCaller.RaiseMouseMove(MyIndex)
End Sub
'
'-----------------------------------------------------------------
Private Sub MyLbl_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Call MyCaller.RaiseDblClick(MyIndex)
End Sub