目安箱 IV

目安箱投稿のルールはこちらをごらんください。
ご意見は電子メールで承っています。
「目安箱」は質問禁止です。技術的な質問はそれぞれの質問箱へどうぞ。

迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
129 / 263 ←次へ | 前へ→

【146】カレンダーコントロールみたなような・・・。
Excel  Jaka  - 06/5/22(月) 12:55 -

引用なし
パスワード
   2003年以降からしか考えてないけど、カレンダーコントロールみたいな感じ?

フォーム(UserForm1)
クラス(Class1)
標準モジュール

を作って、各モジュールに下記コードをコピペ。
その後、フォームをShowすればいいです。(フォームShowのコードは自分で書いてください。)
フォーム上のコントロールは、自動で作ってくれます。

全部いっしょに書き込もうとすると10000文字制限に引っかたので、標準モジュールのコードは、この下に書きます。
ここは、フォームとクラスだけ。


フォームモジュール

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 = "MS Pゴシック"
        .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

5,288 hits

【37】不特定な祝日を求めるエクセル関数とマクロ関数。 Jaka 03/10/28(火) 11:29 Excel[未読]
【38】文中間違い訂正。 Jaka 03/10/29(水) 12:14 Excel[未読]
【59】[管理者削除] [未読]
【88】一応、全部?の祝日です。 Jaka 05/2/28(月) 11:27 Excel[未読]
【89】Re:一応、全部?の祝日です。 ponpon 05/3/6(日) 20:53 Excel[未読]
【138】祝日表作成時の振替休日について Jaka 06/2/21(火) 13:50 Excel[未読]
【146】カレンダーコントロールみたなような・・・。 Jaka 06/5/22(月) 12:55 Excel[未読]
【147】標準モジュールのコード Jaka 06/5/22(月) 12:56 Excel[未読]
【173】7×7マスのカレンダー Jaka 06/12/26(火) 10:16 Excel[未読]
【182】祝祭日も入れてみた。 Jaka 07/1/9(火) 9:53 Excel[未読]
【187】↑の注意点。 Jaka 07/1/31(水) 10:46 Excel[未読]
【220】修正点 Jaka 07/12/5(水) 12:44 Excel[未読]
【221】祝日表をまとめてみた。 Jaka 07/12/6(木) 9:45 Excel[未読]
【227】Re:祝日表をまとめてみた。 VBWASURETA 08/1/24(木) 9:57 全般[未読]
【267】表に位置について。 Jaka 11/2/14(月) 16:59 Excel[未読]

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
129 / 263 ←次へ | 前へ→
ページ:  ┃  記事番号:   
0
(SS)C-BOARD v3.8 is Free