Макрос календаря для excel

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212

Option Explicit
'---------------------------------------------------------------------------------------
' Решение       : Календарь
' Дата и время  : 14 января 2015  23:02
' Автор         : Night Ranger
'                 Яндекс.Деньги - 410012757639478
'                 [email]Exingsteem@yandex.ru[/email]
'                 [url]https://www.cyberforum.ru/vba/[/url]
' Описание      : Этот пример наглядно демонстрирует, как можно использовать календарь
'                 без подключения его к проекту, для этого нужна только форма
'                 совместимость версий любая
'
'                 В этой версии, теперь есть возможность запускать календарь от процедуры
'                 ShowCalendar, и указать там параметры SetDate и UnderRussianStandard
'                 Добавленна кнопка Ok, и форма помнит свою позицию
'---------------------------------------------------------------------------------------
Const jstart = 8, istart = 8 'Стартовые точки
Const gap = 5 'Разрыв
Const twip = 18 'Прямоугольник
Const cc = 6 'Размерность массива
Dim tt(cc, cc) As MSForms.ToggleButton, lb As MSForms.Label
Dim WithEvents fr As MSForms.Frame, WithEvents tb As MSForms.ToggleButton, WithEvents btn As MSForms.CommandButton
Dim WithEvents cbMonth As MSForms.ComboBox, WithEvents cbYear As MSForms.ComboBox
Dim WithEvents chbx As MSForms.CheckBox, WithEvents ok As MSForms.CommandButton
Dim iNext&, cr As Boolean, i&, j&, jj&, v, a$(), tbClick As Boolean, URStandard As Boolean
 
Public ThisDate As Date 'Переменная в которой храниться выбранная дата
 
Private Sub ok_Click()
    'Здесь могут быть дальнейшие инструкции после выбора даты
    'Например дату в удобном формате можно поместить в активную ячейку
    '----------------------------------------------------------------
    
    '
    '
    '
 
    ActiveCell = TextResult
    '----------------------------------------------------------------
    If chbx.Value Then Me.Hide
End Sub
 
Public Sub ShowCalendar( _
    Optional ByVal SetDate As Date, _
    Optional ByVal UnderRussianStandard As Boolean = 1)
    'ShowCalendar -Процедура вызова с параметрами
    'SetDate -Устанавливает возможность показа календаря c этой даты
    'UnderRussianStandard -Устанавливает возможность исправлять: 1 январь на 1 января
    If CDbl(SetDate) Then
        cr = False
        ThisDate = SetDate
        cbMonth.ListIndex = Month(ThisDate) - 1
        cbYear.Text = Year(ThisDate): cr = True: Update
    End If
    URStandard = UnderRussianStandard
    Me.Show
End Sub
 
Private Function TextResult$()
    TextResult = FormatDateTime(ThisDate, vbLongDate)
    If URStandard Then
        TextResult = Format(ThisDate, "[$-FC19]d mmmm yyyy г.")
        
'        a = Split(TextResult)
'        If Right$(a(1), 1) Like "[йЙьЬ]" Then
'            Mid$(a(1), Len(a(1)), 1) = "я"
'        ElseIf Right$(a(1), 1) Like "[Тт]" Then a(1) = a(1) & "а"
'        End If
'        TextResult = Join(a)
    End If
End Function
 
 
 
Private Sub UserForm_Initialize()
    Dim maxWidth&, Width1&, jNext&
    maxWidth = twip * (cc + 1) * 2: Width1 = maxWidth  2: iNext = istart: jNext = jstart
    ThisDate = Date: Me.Caption = "Календарь"
    Set fr = Me.Controls.Add("Forms.Frame.1", "fr")
    Set lb = Me.Controls.Add("Forms.Label.1", "lb")
    Set cbMonth = Me.Controls.Add("Forms.ComboBox.1", "cbMonth")
    Set cbYear = Me.Controls.Add("Forms.ComboBox.1", "cbYear")
    Set btn = Me.Controls.Add("Forms.CommandButton.1", "btn")
    Set ok = Me.Controls.Add("Forms.CommandButton.1", "ok")
    Set chbx = Me.Controls.Add("Forms.CheckBox.1", "chbx")
    
    With lb: .Move jstart, istart, Width1
        .Font.Size = 15: .Font.Bold = 1
        iNext = iNext + .Height + gap
        jNext = jNext + .Width + gap
    End With
    With cbMonth: .Move jNext, istart, (Width1 - gap * 2)  2, lb.Height: .Style = 2
        For i = 1 To 12: .AddItem Format(DateSerial(0, i, 1), "mmmm"): Next
        jNext = jNext + .Width + gap
    End With
    With cbYear: .Move jNext, istart, (Width1 - gap * 2)  2, lb.Height: .Style = 2
        For i = 1899 To Year(ThisDate) + 100
            .AddItem CStr(i)
        Next
    End With
    
    iNext = lb.Top + lb.Height + gap
    
    With fr: .Move jstart, iNext, maxWidth, twip * (cc + 1)
        .Enabled = 0
        .SpecialEffect = 0
    End With
    For i = 0 To cc: For j = 0 To cc
        Set tt(j, i) = fr.Controls.Add("Forms.ToggleButton.1", "tt" & i & j)
        With tt(j, i):  .Move j * twip * 2, i * twip, twip * 2, twip: .Locked = i = 0
        .ForeColor = IIf(j >= 5, vbRed, vbBlue)
        .BackColor = IIf(i, vbButtonFace, vbScrollBars)
    End With: Next j, i
    jNext = jstart
    With ok: .Move jNext, iNext + fr.Height + gap, lb.Width, lb.Height: .Caption = "Ok"
        .AutoSize = 1: jNext = jNext + .Width + gap
    End With
    
    With btn: .Move jNext, iNext + fr.Height + gap, lb.Width, lb.Height: .Caption = "Сегодня"
        .AutoSize = 1: jNext = jNext + .Width + gap
    End With
 
    With chbx: .Move jNext, btn.Top, (jstart + maxWidth) - jNext
        .Caption = "Скрываться после выбора или Ok"
        .Value = GetSetting("Ms Office", "Calendar", "chbx", chbx.Value)
    End With
    
 
    Call btn_Click: Filling: lbUpdate
 
    With Me
        .Height = btn.Top + twip * 3
        .Width = jstart + maxWidth + twip
        If Application.Left > -100 Then
            .StartUpPosition = 0
            .Left = GetSetting("Ms Office", "Calendar", "Left", .Left)
            .Top = GetSetting("Ms Office", "Calendar", "Top", .Top)
            If .Left <= 0 Or .Left > (Application.Left + Application.Width - 100) Or _
            .Top <= 0 Or .Top > (Application.Top + Application.Height - 100) Then
                'Если сохраненная ранее позиция вышла за предел экрана
                .StartUpPosition = 2
            End If
        End If
    End With
 
End Sub
 
Private Sub lbUpdate()
    If cr = False Then Exit Sub
    lb.Caption = Format(ThisDate, "mmmm yyyy")
    If Split(lb.Caption)(0) <> cbMonth.Text Then
        ThisDate = DateSerial(Year(ThisDate), cbMonth.ListIndex + 2, 0)
         lb.Caption = Format(ThisDate, "mmmm yyyy")
    End If
End Sub
 
Private Sub btn_Click()
    cr = False
    ThisDate = Date
    cbMonth.ListIndex = Month(ThisDate) - 1
    cbYear.Text = Year(ThisDate): cr = True: Update
    
End Sub
Private Sub cbMonth_Click()
    If cr = False Then Exit Sub
    ThisDate = DateSerial(Year(ThisDate), cbMonth.ListIndex + 1, Day(ThisDate))
    Update
End Sub
Private Sub cbYear_Click()
     If cr = False Then Exit Sub
    ThisDate = DateSerial(cbYear.Text, Month(ThisDate), Day(ThisDate)): Update
End Sub
 
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    On Error Resume Next: Err.Clear: Set tb = tt((X - jstart)  twip  2, (Y - iNext)  twip)
    If Err = 0 Then
        With tb
            If .Enabled And .Locked = False Then
                For i = 1 To cc: For j = 0 To cc: With tt(j, i)
                    If (.Name = tb.Name) Then
                        ThisDate = DateSerial(cbYear.Text, cbMonth.ListIndex + 1, .Caption)
                        .Value = 1: tbClick = 1: tb_Click: tbClick = 0 'Выбор произведен !
                    Else: .Value = 0
                    End If
    End With: Next j, i: End If: End With: End If
End Sub
 
Private Sub chbx_Click()
    If cr = False Then Exit Sub
    SaveSetting "Ms Office", "Calendar", "chbx", chbx.Value
End Sub
 
Sub Filling()
    For j = 0 To cc  'Понедельники вторники даты и тд
        With tt(j, 0): .Caption = WeekdayName(j + 1, 1, vbMonday): .Font.Bold = 1: End With
    Next: j = 0
    While Weekday(DateSerial(Year(ThisDate), Month(ThisDate), j)) <> 1: j = j - 1: Wend: jj = j
    For i = 1 To cc: For j = 0 To cc: v = DateSerial(Year(ThisDate), Month(ThisDate), jj) + 1
        With tt(j, i): .Caption = Day(v): .Enabled = Month(v) = Month(ThisDate)
            .Value = .Enabled And .Caption = Day(ThisDate)
    End With: jj = jj + 1: Next j, i
End Sub
Private Sub Update(): Call lbUpdate:  Filling: End Sub
Private Sub tb_Click(): If tbClick = False Then Exit Sub Else ok_Click
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    With Me 'Перед закрытием запомнить позицию
        SaveSetting "Ms Office", "Calendar", "Left", .Left
        SaveSetting "Ms Office", "Calendar", "Top", .Top
    End With
End Sub