| |
２００３年以降からしか考えてないけど、カレンダーコントロールみたいな感じ？
フォーム（UserForm1）
クラス（Class1）
標準モジュール
を作って、各モジュールに下記コードをコピペ。
その後、フォームをShowすればいいです。（フォームShowのコードは自分で書いてください。）
フォーム上のコントロールは、自動で作ってくれます。
全部いっしょに書き込もうとすると１００００文字制限に引っかたので、標準モジュールのコードは、この下に書きます。
ここは、フォームとクラスだけ。
フォームモジュール
Dim FMCls1() As New Class1
Dim FMCls2() As New Class1
Dim Cmb1 As New Class1
Dim Cmb2 As New Class1
Private Sub UserForm_Activate()
Dim NwN As Date, Nwy As Long, NwM As Long
Dim INDXY As Variant, INDXM As Variant
NwN = Now()
Nwy = Year(NwN)
NwM = Month(NwN)
INDXY = Application.Match(Nwy, Me.Controls("ComboBox1").List, 0)
INDXM = Application.Match(NwM, Me.Controls("ComboBox2").List, 0)
Me.Controls("ComboBox1").ListIndex = INDXY - 1
Me.Controls("TextBox1").Value = 1
Me.Controls("ComboBox2").ListIndex = INDXM - 1
End Sub
Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
For i = 1 To UBound(FMCls1)
Me.Controls("LabelB" & i).SpecialEffect = fmSpecialEffectFlat
Next
End Sub
Private Sub UserForm_Initialize()
Const BHei As Double = 15, BWid As Double = 17
Const BBTp As Double = 15, BBLt As Double = 17
Dim ComboBox1追加 As Control, ComboBox2追加 As Control
Dim LabelTx追加 As Control, LabelB追加 As Control, TextBox1追加 As Control
Dim i As Long, ii As Long, Youbi As Variant, FMCNT As Long
Dim Btop As Double, BLft As Double, CT As Long
Me.Top = 100
Me.Left = 300
Me.Width = 150
Me.Height = 160
Me.Caption = "カレンダー"
Youbi = Array("日", "月", "火", "水", "木", "金", "土")
Set ComboBox1追加 = Me.Controls.Add("Forms.ComboBox.1", "ComboBox1")
Set Cmb1.ComboBox1ChangeEvent = ComboBox1追加
With ComboBox1追加
.Width = 60
.Height = 17
.Top = 3
.Left = 13
.List = Array(2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, _
2011, 2012, 2013, 2014, 2015)
.FontSize = 11
.Font.Bold = True
.Style = fmStyleDropDownList
End With
Set ComboBox2追加 = Me.Controls.Add("Forms.ComboBox.1", "ComboBox2")
Set Cmb1.ComboBox2ChangeEvent = ComboBox2追加
With ComboBox2追加
.Width = 40
.Height = 17
.Top = 3
.Left = 92
.List = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
.FontSize = 11
.Font.Bold = True
.Style = fmStyleDropDownList
.SetFocus
.ListRows = 12
End With
Btop = 30
For i = 1 To 7
BLft = 13
For ii = 1 To 7
CT = CT + 1
Set LabelB追加 = Me.Controls.Add("Forms.Label.1", "LabelB" & CT)
With Me.Controls("LabelB" & CT)
.Width = BWid
.Height = BHei
.Top = Btop
.Left = BLft
.Font.Name = "ＭＳ Ｐゴシック"
.Font.Bold = True
.TextAlign = 2
.SpecialEffect = fmSpecialEffectFlat
If i = 1 Then
.Caption = Youbi(ii - 1)
.FontSize = 10
Else
ReDim Preserve FMCls1(1 To CT)
Set FMCls1(CT).LabelClickEvent = LabelB追加
ReDim Preserve FMCls2(1 To CT)
Set FMCls2(CT).LabelMoveEvent = LabelB追加
.FontSize = 10
End If
If ii = 1 Then
.ForeColor = &HFF&
ElseIf ii = 7 Then
.ForeColor = &HFF0000
End If
End With
BLft = BLft + BBLt
Next
Btop = Btop + BHei
Next
Set TextBox1追加 = Me.Controls.Add("Forms.TextBox.1", "TextBox1")
With TextBox1追加
.Width = 5
.Height = 5
.Top = 0
.Left = 0
.Value = 0
.FontSize = 5
.Visible = False
End With
DoEvents
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
For i = 1 To UBound(FMCls1)
Set FMCls1(i).LabelClickEvent = Nothing
Set FMCls2(i).LabelMoveEvent = Nothing
Next
End Sub
=================================
クラスモジュール（名前は、Class1）
Public WithEvents LabelClickEvent As MSForms.Label
Public WithEvents ComboBox1ChangeEvent As MSForms.ComboBox
Public WithEvents ComboBox2ChangeEvent As MSForms.ComboBox
Public WithEvents LabelMoveEvent As MSForms.Label
Private Sub LabelMoveEvent_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
LabelMoveEvent.SpecialEffect = fmSpecialEffectEtched
For i = 8 To 49
If LabelMoveEvent.Name <> "LabelB" & i Then
UserForm1.Controls("LabelB" & i).SpecialEffect = fmSpecialEffectFlat
End If
Next
DoEvents
End Sub
Private Sub LabelClickEvent_Click()
Dim Conm As String, Nen As Long, Tuki As Long
Conm = LabelClickEvent.Name
With UserForm1
.Controls(Conm).SpecialEffect = fmSpecialEffectSunken
With .Controls("ComboBox1")
If .ListIndex >= 0 Then
Nen = .List(.ListIndex)
End If
End With
With .Controls("ComboBox2")
If .ListIndex >= 0 Then
Tuki = .List(.ListIndex)
End If
End With
MsgBox Format(Nen & "/" & Tuki & "/" & LabelClickEvent.Caption, _
"ggge年m月d日 (aaa)"), , "選択した日付"
.Controls(Conm).SpecialEffect = fmSpecialEffectEtched
End With
End Sub
Private Sub ComboBox1ChangeEvent_Change()
Dim Conm As String, Nen As Long, Tuki As Long, CT As Long
Dim ClendHol As Variant, Clendday As Variant, i As Long
Dim Nengetu As Date, WeekHantei As Variant
Conm = ComboBox1ChangeEvent.Name
With UserForm1
If .Controls("TextBox1").Value <> "1" Then Exit Sub
With .Controls("ComboBox1")
Nen = .List(.ListIndex)
End With
With .Controls("ComboBox2")
Tuki = .List(.ListIndex)
End With
ClendHol = HolidayTBL(Nen, Tuki)
Clendday = ClendTBL(Nen, Tuki)
CT = 0
For i = 1 To 49
If i > 7 Then
CT = CT + 1
With .Controls("LabelB" & i)
.SpecialEffect = fmSpecialEffectFlat
If Clendday(CT) <> "0" Then
.Caption = Clendday(CT)
.Enabled = True
Nengetu = Nen & "/" & Tuki & "/" & Clendday(CT)
WeekHantei = Application.Match(Clendday(CT), ClendHol, 0)
If Weekday(Nengetu) = 1 Or Not IsError(WeekHantei) Then
.ForeColor = &HFF&
ElseIf Weekday(Nengetu) = 7 Then
.ForeColor = &HFF0000
Else
.ForeColor = &H0&
End If
If Nengetu = Format(Now(), "yyyy/m/d") Then
.SpecialEffect = fmSpecialEffectEtched
End If
Else
.Caption = ""
.Enabled = False
End If
End With
End If
Next
End With
Erase ClendHol, Clendday
DoEvents
End Sub
Private Sub ComboBox2ChangeEvent_Change()
Dim Nen As Long, Tuki As Long, i As Long, CT As Long
Dim ClendHol As Variant, Clendday As Variant
Dim Nengetu As String, WeekHantei As Variant
With UserForm1
If .Controls("TextBox1").Value <> "1" Then Exit Sub
With .Controls("ComboBox1")
Nen = .List(.ListIndex)
End With
With .Controls("ComboBox2")
Tuki = .List(.ListIndex)
End With
ClendHol = HolidayTBL(Nen, Tuki)
Clendday = ClendTBL(Nen, Tuki)
CT = 0
For i = 1 To 49
If i > 7 Then
CT = CT + 1
With .Controls("LabelB" & i)
.SpecialEffect = fmSpecialEffectFlat
If Clendday(CT) <> "0" Then
.Caption = Clendday(CT)
.Enabled = True
Nengetu = Nen & "/" & Tuki & "/" & Clendday(CT)
WeekHantei = Application.Match(Clendday(CT), ClendHol, 0)
If Weekday(Nengetu) = 1 Or Not IsError(WeekHantei) Then
.ForeColor = &HFF&
ElseIf Weekday(Nengetu) = 7 Then
.ForeColor = &HFF0000
Else
.ForeColor = &H0&
End If
If Nengetu = Format(Now(), "yyyy/m/d") Then
.SpecialEffect = fmSpecialEffectEtched
End If
Else
.Caption = ""
.Enabled = False
End If
End With
DoEvents
End If
Next
End With
Erase ClendHol, Clendday
DoEvents
End Sub
|
|
Jaka
- 06/5/22(月) 12:55 -
![[未読]](./data/FAQ/image/read_icon.gif){kind=icon}
