COPY

'-------------------------------------------------------------------
Private WithEvents myLabel  As MSForms.Label
Private myParent            As C_ObjControl
Private myIndex             As Long
'-------------------------------------------------------------------
Private Sub Class_Terminate()
    Set myLabel = Nothing
    Set myParent = Nothing
End Sub
'--------------------------------------------------------------------
Public Property Let Item(ByRef val As MSForms.Label)
    Set myLabel = val
End Property
'--------------------------------------------------------------------
Public Property Get Item() As MSForms.Label
    Set Item = myLabel
End Property
'--------------------------------------------------------------------
Public Property Let Parent(ByRef val As Object)
    Set myParent = val
End Property
'--------------------------------------------------------------------
Public Property Let Index(ByVal val As Long)
    myIndex = val
End Property
'--------------------------------------------------------------------
Public Property Get Index() As Long
    Index = myIndex
End Property
'--------------------------------------------------------------------
Public Property Get Self() As Object
    Set Self = Me
End Property
'--------------------------------------------------------------------
Private Sub myLabel_Click()
    Call myParent.onClick(myIndex)
End Sub
'--------------------------------------------------------------------
Private Sub myLabel_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Cancel = True
    Call myParent.onDblClick(myIndex)
End Sub
'--------------------------------------------------------------------
Private Sub myLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call myParent.onMouseMove(myIndex)
End Sub

COPY

Option Explicit
'*******************************************************************
Private Type Posi
    Top                 As Double
    Left                As Double
End Type
 
Public Event Click(ByVal Index As Long)
Public Event DblClick(ByVal Index As Long)
Public Event MouseMove(ByVal Index As Long)
 
Private Obj()           As C_Label
Private DefPosi()       As Posi
Private myItems         As Object
Private myParent        As Object
 
Private AllRows         As Long
Private AllColumns      As Long
Private AllTop          As Double
Private AllLeft         As Double
Private HIntv           As Double
Private VIntv           As Double
Private LabCount        As Long
Private Size            As Long
Private PHeight         As Double
Private PWidth          As Double
Private offrow          As Double
Private offcol          As Double
'*******************************************************************
 
Public Property Let Parent(ByRef val As Object)
    Set myParent = val
End Property
'--------------------------------------------------------------------
Public Property Get Items() As Object
    Set Items = myItems
End Property
'--------------------------------------------------------------------
Public Property Let Rows(ByVal val As Long)
    AllRows = val
    AllColumns = 0
End Property
'--------------------------------------------------------------------
Public Property Let Columns(ByVal val As Long)
    AllColumns = val
    AllRows = 0
End Property
'--------------------------------------------------------------------
Public Property Let Top(ByVal val As Double)
    AllTop = val
End Property
'--------------------------------------------------------------------
Public Property Let Count(ByVal val As Double)
    LabCount = val
End Property
'--------------------------------------------------------------------
Public Property Let Left(ByVal val As Double)
    AllLeft = val
End Property
'--------------------------------------------------------------------
Public Property Let HoriIntv(ByVal val As Double)
    HIntv = val
End Property
'--------------------------------------------------------------------
Public Property Let VertIntv(ByVal val As Double)
    VIntv = val
End Property
'--------------------------------------------------------------------
Public Property Let Height(ByVal val As Double)
    PHeight = val
End Property
'--------------------------------------------------------------------
Public Property Get Height() As Double
    Height = PHeight
End Property
'--------------------------------------------------------------------
Public Property Let Width(ByVal val As Double)
    PWidth = val
End Property
'--------------------------------------------------------------------
Public Property Get Width() As Double
    Width = PWidth
End Property
'--------------------------------------------------------------------
Public Property Let FontSize(ByVal val As Long)
    Size = val
End Property
'--------------------------------------------------------------------
Private Sub Class_Initialize()
    AllRows = 0
    AllColumns = 0
    AllTop = 0
    AllLeft = 0
    HIntv = 0
    VIntv = 0
    PHeight = 0
    PWidth = 0
    LabCount = 0
    Size = 10
End Sub
'--------------------------------------------------------------------
Private Sub Class_Terminate()
    Dim I               As Long
 
    For I = 1 To UBound(Obj)
        Set Obj(I) = Nothing
    Next I
    
    Set myParent = Nothing
    Set myItems = Nothing
    
End Sub
'--------------------------------------------------------------------
Public Sub onClick(ByVal Index As Long)
    RaiseEvent Click(Index)
End Sub
'--------------------------------------------------------------------
Public Sub onDblClick(ByVal Index As Long)
    RaiseEvent DblClick(Index)
End Sub
'--------------------------------------------------------------------
Public Sub onMouseMove(ByVal Index As Long)
    RaiseEvent MouseMove(Index)
End Sub
'--------------------------------------------------------------------
Public Sub Init(ByRef Dic As Object)
    Dim Ctrl            As Control
    Dim I               As Long
    Dim Key             As Variant
    
    If Dic.Count > 0 Then
        LabCount = Dic.Count
    End If
    
    If LabCount = 0 Then
        Exit Sub
    End If
    
    Set myItems = New Collection
    ReDim Obj(1 To Dic.Count)
    ReDim DefPosi(1 To Dic.Count)
 
    With myParent
        
        I = 1
        
        '-----
        For Each Key In Dic.keys
            '-----コントロールの追加
            Set Ctrl = .Controls.Add("Forms.Label.1", Dic(Key))
            
            '-----コントロールの整形
            With Ctrl
                .Visible = True
                '.Enabled = False
                .Caption = Dic(Key)
            
                If AllRows > 0 Then
                    .Top = AllTop + ((I - 1) Mod AllRows) * (PHeight + VIntv)
                    .Left = AllLeft + ((I - 1) \ AllRows) * (PWidth + HIntv)
                End If
            
                If AllColumns > 0 Then
                    .Top = AllTop + ((I - 1) \ AllColumns) * (PHeight + VIntv)
                    .Left = AllLeft + ((I - 1) Mod AllColumns) * (PWidth + HIntv)
                    
                End If
 
                .Font.Size = Size
                .Height = PHeight
                .Width = PWidth
                .SpecialEffect = fmSpecialEffectRaised
 
                DefPosi(I).Top = .Top
                DefPosi(I).Left = .Left
 
            End With
 
            '-----コントロールのイベントクラスの作成
            Set Obj(I) = New C_Label
            With Obj(I)
                .Item = Ctrl
                .Index = Key
                .Parent = Me
            End With
            
            myItems.Add Obj(I)
            
            I = I + 1
            
        Next Key
        
    End With
 
End Sub
 
'*******************************************************************
Public Sub OffSet(ByVal offtop As Double, _
                  ByVal offleft As Double)
    Dim I               As Long
    
    For I = 1 To UBound(Obj)
        With Obj(I).Item
            .Top = DefPosi(I).Top + offtop
            .Left = DefPosi(I).Left + offleft
        End With
    Next I
 
End Sub

COPY

Option Compare Database
 
Private Sub buクリア_Click()
    
    Call CtrlClear
    
End Sub
 
Private Sub bu移動_Click()
 
    Me.SUB1.SetFocus
    DoCmd.GoToRecord , , acNewRec
    Me.SUB1.Form.SelHeight = 1
    
    Call CtrlClear
        
    Me.ID.Value = "新規"
        
End Sub
 
Private Sub bu検索_Click()
    Dim whereSQL            As String
    
    For Each Ctrl In Me.Controls
        If TypeName(Ctrl) = "TextBox" Then
            If Ctrl.Value <> "" Then
                If whereSQL = "" Then
                    whereSQL = " A.[" & Ctrl.Name & "] Like '*" & Ctrl & "*'"
                Else
                    whereSQL = whereSQL & " AND A.[" & Ctrl.Name & "] Like '*" & Ctrl & "*'"
                End If
            End If
        End If
    Next Ctrl
 
    Me.SUB1.Form.RecordSource = "SELECT * FROM 連絡先 AS A WHERE" & whereSQL & ";"
 
End Sub
 
Private Sub bu更新_Click()
    Dim tableSQL            As String
    Dim valueSQL            As String
    Dim mySQL               As String
    Dim Ctrl                As Access.Control
    Dim I                   As Long
 
    If Nz(Me.ID, "") = "" Then
        Exit Sub
    End If
 
    If Me.ID = "新規" Then
        Call ADDNEW
        Exit Sub
        
        '追加
        For Each Ctrl In Me.Controls
            If TypeName(Ctrl) = "TextBox" Then
                
                Select Case Ctrl.Name
                Case "ID", "添付ファイル"
                Case Else
                    If tableSQL = "" Then
                        tableSQL = Ctrl.Name
                        valueSQL = "'" & Ctrl.Value & "'"
                    Else
                        tableSQL = tableSQL & ", " & Ctrl.Name
                        valueSQL = valueSQL & ", '" & Ctrl.Value & "'"
                    End If
                End Select
                
            End If
        Next Ctrl
 
        mySQL = "INSERT INTO 連絡先(" & tableSQL & ") VALUES(" & valueSQL & ");"
        DoCmd.RunSQL mySQL
 
        Me.SUB1.Requery
        Me.ID.Value = DMax("ID", "連絡先")
 
    Else
        Call UPDATE
        Exit Sub
        
        '更新
        For Each Ctrl In Me.Controls
            If TypeName(Ctrl) = "TextBox" Then
                
                Select Case Ctrl.Name
                Case "ID", "添付ファイル"
                Case Else
                    If tableSQL = "" Then
                        tableSQL = Ctrl.Name & "='" & Ctrl.Value & "'"
                    Else
                        tableSQL = tableSQL & ", " & Ctrl.Name & "='" & Ctrl.Value & "'"
                    End If
                End Select
                
            End If
        Next Ctrl
 
        mySQL = "UPDATE 連絡先 SET " & tableSQL & "WHERE 連絡先.[ID]=" & Me.ID & ";"
        DoCmd.RunSQL mySQL
 
        Me.SUB1.Requery
 
    End If
 
End Sub
 
Private Sub bu閉じる_Click()
 
    DoCmd.Close acForm, Me.Name, acSaveNo
 
End Sub
 
Private Sub Form_Load()
 
    Me.SUB1.SourceObject = "検索SUB"
    Me.SUB1.Form.RecordSource = "SELECT * FROM 連絡先;"
 
End Sub
 
Private Sub CtrlClear()
    Dim Ctrl                As Access.Control
 
    For Each Ctrl In Me.Controls
        If TypeName(Ctrl) = "TextBox" Then
            Ctrl.Value = ""
        End If
    Next Ctrl
 
End Sub
 
Private Sub UPDATE()
    Dim CN                  As ADODB.Connection
    Dim RS                  As New ADODB.Recordset
    Dim Ctrl                As Access.Control
 
    Set CN = CurrentProject.Connection
 
    RS.Open "連絡先", CN, adOpenKeyset, adLockOptimistic, adCmdTableDirect
   
    Let RS.Index = "Ind"
    RS.Seek Me.ID, adSeekFirstEQ
 
    For Each Ctrl In Me.Controls
        Select Case TypeName(Ctrl)
        Case "TextBox"
            Select Case Ctrl.Name
            Case "ID"
            Case Else
                RS.Fields(Ctrl.Name) = Ctrl.Value
            End Select
        Case "Attachment"
        End If
    Next Ctrl
 
    RS.UPDATE
 
    RS.Close
    Set RS = Nothing
    CN.Close
    Set CN = Nothing
 
    Me.SUB1.Requery
 
End Sub
 
Private Sub ADDNEW()
    Dim CN                  As ADODB.Connection
    Dim RS                  As New ADODB.Recordset
    Dim Ctrl                As Access.Control
 
    Set Con = CurrentProject.Connection
    Set Rst = New ADODB.Recordset
 
    Rst.Open "連絡先", Con, adOpenForwardOnly, adLockPessimistic
 
    With Rst
        .ADDNEW
 
        For Each Ctrl In Me.Controls
            Select Case TypeName(Ctrl)
            Case "TextBox"
            Select Case Ctrl.Name
                Case "ID"
                Case Else
                    RS.Fields(Ctrl.Name) = Ctrl.Value
                End Select
            Case "Attachment"
            End If
        Next Ctrl
 
        .UPDATE
    End With
 
    Rst.Close
    Set Rst = Nothing
    Set Con = Nothing
 
    Me.SUB1.Requery
    Me.ID.Value = DMax("ID", "連絡先")
 
End Sub
 
Private Sub クリア2()
    Call ClearControls
End Sub
 
Private Sub 閉じる2()
    DoCmd.Close acForm, "住所録", acSaveNo
End Sub
 
Sub ClearControls()
    Dim Ctl As Control
 
    For Each Ctl In Me.Controls
        If Ctl.ControlType = acTextBox Then
            Ctl = Null
        End If
    Next Ctl
End Sub
Private Sub cmd追加2()
'[追加]ボタンクリック時
 
  'フォームのレコードセットの編集を開始
  Me.Recordset.Edit
 
  '商品写真フィールドのレコードセットに対する操作
  With Me.Recordset!商品写真.Value
    .ADDNEW
      !FileData.LoadFromFile "c:\Picture\img17.jpg"
    .UPDATE
    .Close
  End With
 
  '添付ファイルコントロールの表示を更新
  Me!商品写真.Requery
 
End Sub

COPY

Option Compare Database
 
Private Sub Form_Click()
    Dim Ctrl                As Access.Control
 
    If Me.SelHeight > 0 Then
        For Each Ctrl In Me.Controls
            Select Case TypeName(Ctrl)
            Case "TextBox"
                If Ctrl.Name = "ID" Then
                    If Nz(Ctrl.Value, "") = "" Then
                        'Me.Parent.Controls(Ctrl.Name).Value = DMax(Ctrl.Name, "連絡先") + 1
                        Me.Parent.Controls(Ctrl.Name).Value = "新規"
                    Else
                        Me.Parent.Controls(Ctrl.Name).Value = Ctrl.Value
                    End If
                Else
                    Me.Parent.Controls(Ctrl.Name).Value = Ctrl.Value
                End If
            End Select
        Next Ctrl
    End If
 
End Sub

COPY

'----------------------------------------------------------------
'カレンダー
'令和３年５月６日
'----------------------------------------------------------------
Option Compare Database
Option Explicit
 
Private WithEvents myControls As C_Controls
 
Private Const SHIFT_MASK    As Long = 1
 
Private Const FirstYobi As Long = vbSunday
 
Private HoldDate            As Long
Private HoldYear            As Long
Private HoldMonth           As Long
Private HoldDay             As Long
 
Private Enum IncType
    Forward = 1
    Backward = -1
End Enum
 
Private GetYobi             As C_KyuZitu
 
Private Const IntvDay       As String = "d"
Private Const IntvMonth     As String = "m"
Private Const IntvYear      As String = "yyyy"
Private Const IntvWeek      As String = "ww"
 
Private CurYear             As Long
Private CurMonth            As Long
Private CurDay              As Long
 
Private DaysAndWeeks()      As Long
Private Yobi                As Variant
Private SelectDay           As String
 
Public Property Get DateNum() As Long
    If CurYear = 0 Then
        DateNum = 0
    Else
        DateNum = DateSerial(CurYear, CurMonth, CurDay)
    End If
End Property
 
Public Property Get WeekNum() As Long
    GetYobi.SetNumDate = DateSerial(CurYear, CurMonth, CurDay)
    WeekNum = GetYobi.WeekNum
End Property
'----------------------------------------------------------------
'
Private Sub Form_Load()
 
    Dim Ctrl                As Access.Control
    Dim I                   As Long
 
    If Nz(Me.OpenArgs, "") = "" Then
        HoldDate = Date
    Else
        If IsDate(Me.OpenArgs) Then
            HoldDate = DateSerial(DatePart("YYYY", Me.OpenArgs), _
                                DatePart("m", Me.OpenArgs), _
                                DatePart("d", Me.OpenArgs))
        Else
            HoldDate = Date
        End If
    End If
 
    HoldYear = Year(HoldDate)
    HoldMonth = Month(HoldDate)
    HoldDay = Day(HoldDate)
 
    Set GetYobi = New C_KyuZitu
    GetYobi.pYear = HoldYear
 
    CurYear = HoldYear
    CurMonth = HoldMonth
    CurDay = HoldDay
 
    Set myControls = New C_Controls
    With myControls
        Set .Parent = Me
        .Init
    End With
        
    Yobi = Array("日", "月", "火", "水", "木", "金", "土")
    For I = 0 To 6
        Me("Y" & I).Caption = Yobi((FirstYobi - 1 + I) Mod 7)
        Select Case I
        Case 0
            Me("Y" & I).ForeColor = vbRed
        Case 6
            Me("Y" & I).ForeColor = vbBlue
        End Select
    Next I
    
    Call SetCurDisp
    Call DispDraw
 
End Sub
'----------------------------------------------------------------
'
Private Sub Form_Close()
 
End Sub
'----------------------------------------------------------------
'
Private Sub SetCurDisp()
 
    Me.DMONTH.Caption = CurMonth
    Me.DYEAR.Caption = CurYear
    
End Sub
'----------------------------------------------------------------
'
Private Sub DispDraw()
    Dim Ctrl                As Access.Control
    Dim NewSelect           As String
    Dim OneDayYobi          As Long
    Dim OneDaySerial        As Long
    Dim I                   As Long
 
    GetYobi.pYear = CurYear
 
    '選択月の最初の日のシリアル値
    OneDaySerial = DateSerial(CurYear, CurMonth, 1)
 
    '選択月の最初の日の曜日
    OneDayYobi = Weekday(OneDaySerial, FirstYobi)
 
    '配列にシリアル値をセット
    ReDim DaysAndWeeks(0 To 41)
    For I = 0 To UBound(DaysAndWeeks)
        DaysAndWeeks(I) = OneDaySerial - (OneDayYobi - 1) + I
    Next I
 
    'ラベルのキャプションに日にちをセット
    For I = 0 To UBound(DaysAndWeeks)
        Me("Day" & I).Caption = Day(DaysAndWeeks(I))
 
        If Me.DMONTH.Caption <> Month(DaysAndWeeks(I)) Then
            Me("Day" & I).FontSize = 10
        Else
            Me("Day" & I).FontSize = 12
        End If
 
        If Me("Day" & I).ForeColor <> InteriorColor(DaysAndWeeks(I)) Then
            Me("Day" & I).ForeColor = InteriorColor(DaysAndWeeks(I))
        End If
 
        If DaysAndWeeks(I) = DateSerial(CurYear, CurMonth, CurDay) Then
            NewSelect = "Day" & I
        End If
    Next I
 
    Call EffectDraw(NewSelect)
 
End Sub
'----------------------------------------------------------------
'
Private Sub EffectDraw(NewSelect As String)
 
    If Len(SelectDay) > 0 Then
        If SelectDay <> NewSelect Then
            Me(SelectDay).SpecialEffect = acNormal
        End If
    End If
 
    SelectDay = NewSelect
    Me(SelectDay).SpecialEffect = acEffectSunken
 
    Me.Repaint
 
End Sub
'----------------------------------------------------------------
'
Private Function InteriorColor(DrawDate As Long) As Long
 
    GetYobi.SetNumDate = DrawDate
 
    Select Case GetYobi.WeekNum
    Case 1, 10, 11, 12, 13
        InteriorColor = vbRed
    Case 7
        InteriorColor = vbBlue
    Case Else
        InteriorColor = vbBlack
    End Select
 
End Function
'----------------------------------------------------------------
'
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
 
    Call ShiftKeys(KeyCode, Shift)
 
End Sub
'----------------------------------------------------------------
'
Private Sub myControls_Click(myCont As Object)
 
    Select Case myCont.Name
    Case "NM"
        Me.buDummy.SetFocus
        Call NextMonth
    Case "NY"
        Me.buDummy.SetFocus
        Call NextYear
    Case "PM"
        Me.buDummy.SetFocus
        Call PreviousMonth
    Case "PY"
        Me.buDummy.SetFocus
        Call PreviousYear
    Case "bu閉じる"
        Me.buDummy.SetFocus
        Call CloseForm(False)
    Case "bu初期"
        Me.buDummy.SetFocus
        CurYear = HoldYear
        CurMonth = HoldMonth
        CurDay = HoldDay
        Call SetCurDisp
        Call DispDraw
    Case "bu削除"
        Me.buDummy.SetFocus
        CurYear = 0
        Call CloseForm(True)
    Case Else
        Select Case True
        Case InStr(myCont.Name, "Day") = 1
            If myCont.SpecialEffect = acEffectSunken Then
                Call CloseForm(True)
            Else
                If CurMonth <> Month(DaysAndWeeks(Mid(myCont.Name, Len("Day") + 1))) Then
                    Call ClickDate(myCont.Name)
                    Call SetCurDisp
                    Call DispDraw
                Else
                    Call EffectDraw(myCont.Name)
                    Call ClickDate(myCont.Name)
                End If
            End If
        End Select
    End Select
 
End Sub
'----------------------------------------------------------------
'
Private Sub myControls_DblClick(myCont As Object, Cancel As Integer)
 
    Select Case True
    Case InStr(myCont.Name, "Day") = 1
        Call EffectDraw(myCont.Name)
        Call ClickDate(myCont.Name)
        Call CloseForm(True)
    End Select
 
End Sub
'----------------------------------------------------------------
'
Private Sub myControls_KeyDown(myCont As Object, KeyCode As Integer, Shift As Integer)
 
    Select Case myCont.Name
    Case "PM", "NM", "PY", "NY", "bu閉じる", "bu初期", "bu削除"
        Call ShiftKeys(KeyCode, Shift)
    Case Else
        Select Case True
        Case InStr(myCont.Name, "Day") = 1
            Call ShiftKeys(KeyCode, Shift)
        End Select
    End Select
 
End Sub
'----------------------------------------------------------------
'
Private Sub ShiftKeys(KeyCode As Integer, Shift As Integer)
    Dim ShiftDown As Boolean
 
    ShiftDown = ((Shift And SHIFT_MASK) > 0)
 
    Select Case KeyCode
    Case vbKeyEscape
        Call CloseForm(Hide:=False)
    Case vbKeyReturn
        Call CloseForm(Hide:=True)
    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 = 0
    
End Sub
'----------------------------------------------------------------
'
Public Sub Today()
    Call MoveToToday(UseCurYear:=True)
End Sub
'----------------------------------------------------------------
'
Public Sub NextDay()
    Call ChangeDate(IntvDay, IncType.Forward)
End Sub
'----------------------------------------------------------------
'
Public Sub NextMonth()
    Call ChangeDate(IntvMonth, IncType.Forward)
End Sub
'----------------------------------------------------------------
'
Public Sub NextYear()
    Call ChangeDate(IntvYear, IncType.Forward)
End Sub
'----------------------------------------------------------------
'
Public Sub NextWeek()
    Call ChangeDate(IntvWeek, IncType.Forward)
End Sub
'----------------------------------------------------------------
'
Public Sub PreviousDay()
    Call ChangeDate(IntvDay, IncType.Backward)
End Sub
'----------------------------------------------------------------
'
Public Sub PreviousMonth()
    Call ChangeDate(IntvMonth, IncType.Backward)
End Sub
'----------------------------------------------------------------
'
Public Sub PreviousYear()
    Call ChangeDate(IntvYear, IncType.Backward)
End Sub
'----------------------------------------------------------------
'
Public Sub PreviousWeek()
    Call ChangeDate(IntvWeek, IncType.Backward)
End Sub
'----------------------------------------------------------------
'
Private Sub MoveToToday(UseCurYear As Boolean)
 
    If UseCurYear Then
        CurYear = HoldYear
    End If
    CurMonth = HoldMonth
    CurDay = HoldDay
 
    Call SetCurDisp
    Call DispDraw
    
End Sub
'----------------------------------------------------------------
'
Private Sub ChangeDate(IntvStr As String, IT As IncType)
    Dim bufMonth        As Integer
    Dim bufYear         As Integer
    Dim bufDay          As Integer
    Dim NewSelect       As String
    Dim OLDDate         As Long
    Dim NewDate         As Long
    Dim Inc             As Long
    Dim I               As Long
 
    If IT = Forward Then
        Inc = 1
    Else
        Inc = -1
    End If
    OLDDate = DateSerial(CurYear, CurMonth, CurDay)
    NewDate = DateAdd(IntvStr, Inc, OLDDate)
 
    bufMonth = DatePart(IntvMonth, NewDate)
    bufYear = DatePart(IntvYear, NewDate)
    bufDay = DatePart(IntvDay, NewDate)
 
    If CurMonth = bufMonth And _
       CurYear = bufYear Then
        CurDay = bufDay
        For I = 0 To UBound(DaysAndWeeks)
            If DaysAndWeeks(I) = DateSerial(CurYear, CurMonth, CurDay) Then
                NewSelect = "Day" & I
            End If
        Next I
        
        Call EffectDraw(NewSelect)
    Else
        CurDay = bufDay
        CurMonth = bufMonth
        CurYear = bufYear
 
        Call SetCurDisp
        Call DispDraw
    End If
 
End Sub
'----------------------------------------------------------------
'
Private Sub CloseForm(Hide As Boolean)
 
    If ThisFormSub() Then
        Exit Sub
    End If
    
    If Hide Then
        Me.Visible = False
    Else
        DoCmd.CLOSE acForm, Me.Name, acSaveNo
    End If
 
End Sub
'----------------------------------------------------------------
'
Private Function ThisFormSub() As Boolean
    Dim strName                 As String
    On Error Resume Next
 
    strName = Me.Parent.Name
    
    ThisFormSub = (Err.Number = 0)
    
    Err.Clear
    
End Function
'----------------------------------------------------------------
'
Private Sub ClickDate(ClickName As String)
    Dim Num                 As Long
 
    Num = Mid(ClickName, Len("Day") + 1)
    CurYear = Year(DaysAndWeeks(Num))
    CurMonth = Month(DaysAndWeeks(Num))
    CurDay = Day(DaysAndWeeks(Num))
 
End Sub

COPY

Option Explicit
'-------------------------------------------------------------------
 
Private WithEvents myButton  As Access.CommandButton
Private myParent            As C_Controls
Private myIndex             As Long'--------------------------------------------------------------------
'
Public Property Set Item(ByRef Obj As Access.CommandButton)
 
    Set myButton = Obj
 
End Property'--------------------------------------------------------------------
'
Public Property Get Item() As Access.CommandButton
 
    Set Item = myButton
 
End Property'--------------------------------------------------------------------
'
Public Property Set Parent(ByRef Obj As C_Controls)
 
    Set myParent = Obj
 
End Property'--------------------------------------------------------------------
'
Public Property Let Index(ByVal val As Long)
 
    myIndex = val
 
End Property'--------------------------------------------------------------------
'
Public Property Get Index() As Long
 
    Index = myIndex
 
End Property'--------------------------------------------------------------------
'
Public Property Get Self() As Object
 
    Set Self = Me
 
End Property'--------------------------------------------------------------------
'
Public Sub DEL()
 
    Set myButton = Nothing
    Set myParent = Nothing
 
End Sub'--------------------------------------------------------------------
'
Private Sub Class_Terminate()
 
    Set myButton = Nothing
    Set myParent = Nothing
 
End Sub'--------------------------------------------------------------------
'
Private Sub myButton_Click()
 
    Call myParent.onClick(myButton)
 
End Sub'--------------------------------------------------------------------
'
Private Sub myButton_DblClick(Cancel As Integer)
 
    Call myParent.onDblClick(myButton, Cancel)
 
End Sub'--------------------------------------------------------------------
'
Private Sub myButton_KeyDown(KeyCode As Integer, Shift As Integer)
 
    Call myParent.onKeyDown(myButton, KeyCode, Shift)
 
End Sub'--------------------------------------------------------------------
'
Private Sub myButton_MouseMove(Button As Integer, _
                               Shift As Integer, _
                               X As Single, _
                               Y As Single)
 
    Call myParent.onMouseMove(myButton, Button, Shift, X, Y)
 
End Sub

COPY

Option Explicit
'-------------------------------------------------------------------
 
Private WithEvents myCheckBox  As Access.CheckBox
Private myParent            As C_Controls
Private myIndex             As Long'--------------------------------------------------------------------
'
Public Property Set Item(ByRef Obj As Access.CheckBox)
 
    Set myCheckBox = Obj
 
End Property'--------------------------------------------------------------------
'
Public Property Get Item() As Access.CheckBox
 
    Set Item = myCheckBox
 
End Property'--------------------------------------------------------------------
'
Public Property Set Parent(ByRef Obj As C_Controls)
 
    Set myParent = Obj
 
End Property'--------------------------------------------------------------------
'
Public Property Let Index(ByVal val As Long)
 
    myIndex = val
 
End Property'--------------------------------------------------------------------
'
Public Property Get Index() As Long
 
    Index = myIndex
 
End Property'--------------------------------------------------------------------
'
Public Property Get Self() As Object
 
    Set Self = Me
 
End Property'--------------------------------------------------------------------
'
Public Sub DEL()
 
    Set myCheckBox = Nothing
    Set myParent = Nothing
 
End Sub'--------------------------------------------------------------------
'
Private Sub Class_Terminate()
 
    Set myCheckBox = Nothing
    Set myParent = Nothing
 
End Sub'--------------------------------------------------------------------
'
Private Sub myCheckBox_Click()
 
    Call myParent.onClick(myCheckBox)
 
End Sub'--------------------------------------------------------------------
'
Private Sub myCheckBox_DblClick(Cancel As Integer)
 
    Call myParent.onDblClick(myCheckBox, Cancel)
 
End Sub'--------------------------------------------------------------------
'
Private Sub myCheckBox_MouseMove(Button As Integer, _
                                 Shift As Integer, _
                                 X As Single, _
                                 Y As Single)
 
    Call myParent.onMouseMove(myCheckBox, Button, Shift, X, Y)
 
End Sub

COPY

Option Explicit
'-------------------------------------------------------------------
 
Private WithEvents myCheckBox  As Access.CheckBox
Private myParent            As C_Controls
Private myIndex             As Long'--------------------------------------------------------------------
'
Public Property Set Item(ByRef Obj As Access.CheckBox)
 
    Set myCheckBox = Obj
 
End Property'--------------------------------------------------------------------
'
Public Property Get Item() As Access.CheckBox
 
    Set Item = myCheckBox
 
End Property'--------------------------------------------------------------------
'
Public Property Set Parent(ByRef Obj As C_Controls)
 
    Set myParent = Obj
 
End Property'--------------------------------------------------------------------
'
Public Property Let Index(ByVal val As Long)
 
    myIndex = val
 
End Property'--------------------------------------------------------------------
'
Public Property Get Index() As Long
 
    Index = myIndex
 
End Property'--------------------------------------------------------------------
'
Public Property Get Self() As Object
 
    Set Self = Me
 
End Property'--------------------------------------------------------------------
'
Public Sub DEL()
 
    Set myCheckBox = Nothing
    Set myParent = Nothing
 
End Sub'--------------------------------------------------------------------
'
Private Sub Class_Terminate()
 
    Set myCheckBox = Nothing
    Set myParent = Nothing
 
End Sub'--------------------------------------------------------------------
'
Private Sub myCheckBox_Click()
 
    Call myParent.onClick(myCheckBox)
 
End Sub'--------------------------------------------------------------------
'
Private Sub myCheckBox_DblClick(Cancel As Integer)
 
    Call myParent.onDblClick(myCheckBox, Cancel)
 
End Sub'--------------------------------------------------------------------
'
Private Sub myCheckBox_MouseMove(Button As Integer, _
                                 Shift As Integer, _
                                 X As Single, _
                                 Y As Single)
 
    Call myParent.onMouseMove(myCheckBox, Button, Shift, X, Y)
 
End Sub