Форум программистов, компьютерный форум, киберфорум
Наши страницы
VBA
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.89/46: Рейтинг темы: голосов - 46, средняя оценка - 4.89
Night Ranger
Заблокирован
1

Календарь, который понравится всем (готовое решение)

14.01.2015, 10:12. Просмотров 9327. Ответов 40
Метки нет (Все метки)

Сегодня я решил выложить настоящий календарь.
Который реализован только встроенными
объектами и методами и на обычной форме UserForm
и нужна для этого только одна форма, больше ничего
стало быть и запуститься в любой версии Excel



Вот этот простой код для формы:
Кликните здесь для просмотра всего текста
Visual Basic
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
Option Explicit
'---------------------------------------------------------------------------------------
' Решение       : Календарь
' Дата и время  : 14 января 2015  10:04
' Автор         : Night Ranger
'                 Яндекс.Деньги - 410012757639478
'                 [email]Exingsteem@yandex.ru[/email]
'                 [url]http://www.cyberforum.ru/vba/[/url]
' Описание      : Этот пример наглядно демонстрирует, как можно использовать календарь
'                 без подключения его к проекту, для этого нужна только форма
'                 совместимость версий любая
'---------------------------------------------------------------------------------------
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
Dim iNext&, cr As Boolean, i&, j&, jj&, v
 
Public ThisDate As Date
 
Private Sub tb_Click()
    'Здесь могут быть дальнейшие инструкции после выбора даты
    'Например дату можно поместить в активную ячейку
    '----------------------------------------------------------------
    
    '
    '
    '
 
    ActiveCell = FormatDateTime(ThisDate, vbLongDate)
    '----------------------------------------------------------------
    If chbx.Value Then Me.Hide
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_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 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 = Year(ThisDate) - 100 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
    With btn: .Move jstart, iNext + fr.Height + gap, lb.Width, lb.Height: .Caption = "Сегодня": End With
    With chbx: .Move jstart + gap + btn.Width, btn.Top, Width1
        .Caption = "Скрываться после выбора"
        .Value = GetSetting("Ms Office", "Calendar", "chbx", chbx.Value)
    End With
    Me.Height = btn.Top + btn.Height * 3
    Me.Width = chbx.Left + chbx.Width + btn.Height
    Call btn_Click: Filling: lbUpdate
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
                    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


а ниже лист, без посторонних компонентов, только пара листов, и форма
7
Вложения
Тип файла: xls Календарь.xls (50.5 Кб, 297 просмотров)
QA
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
14.01.2015, 10:12
Ответы с готовыми решениями:

Суперфильтр (готовое решение)
Вычитал на одном уважаемом сайте про Excel (и VBA), который упоминать здесь непринято в силу правил...

Обход доски конем (готовое решение)
Может кому из студентов пригодится....

Курсы валют и удобный интерфейс (готовое решение)
Создав календарь, я первым делом решил испытать его в своей деловой работе. Так-что, делюсь...

Готовое решение
Добрый вечер товарищи. Хотелось бы заполучить (любой) проект по базам данных + программа к базе....

Готовое решение из Паскаль на C++
Здравствуйте. Есть задание: В молочных магазинах города Х продается сметана с жирностью 15, 20 и...

40
Night Ranger
Заблокирован
14.01.2015, 10:18  [ТС] 2
Кстати, обратите внимание что в отличии от готовых скомпилированных версий
мой календарь чисто нашинский, тоесть начинается с понедельника а не с воскресения
0
Апострофф
Заблокирован
14.01.2015, 10:35 3
Неплохо!

Но я бы добавил в функционал переход на следующий и предыдущий месяцы по клику на серые (недоступные) сейчас их даты.
И соответственно расположил бы текущий месяц в поле так, чтобы это было возможно даже в случае, если первое число - понедельник (т.е. начать его со второй строки)
0
Миниатюры
Календарь, который понравится всем (готовое решение)  
taras atavin
4199 / 1776 / 211
Регистрация: 24.11.2009
Сообщений: 27,563
14.01.2015, 10:39 4
Цитата Сообщение от Night Ranger Посмотреть сообщение
Кстати, обратите внимание что в отличии от готовых скомпилированных версий
мой календарь чисто нашинский, тоесть начинается с понедельника а не с воскресения
Вот именно. И как же он при этом может нравиться всем?
0
14.01.2015, 10:39
Night Ranger
Заблокирован
14.01.2015, 10:41  [ТС] 5
Цитата Сообщение от Апострофф Посмотреть сообщение
по клику на серые (недоступные)
Я сначало хотел так сделать, но потом решил отказаться от этой идеи,
я практически срисовал поведение известного компонента,
но это качество как-раз мне и не понравилось
но если надо, это легко можно устроить, в принципе, форма реагирует на себя
и на свои координаты, а не на отключенный фрейм c кнопками
0
SoftIce
es geht mir gut
11064 / 4463 / 1130
Регистрация: 27.07.2011
Сообщений: 10,945
Завершенные тесты: 1
14.01.2015, 10:46 6
Ну вот, опять двадцать пять

17 январь, 2 февраль, 1 секунд ....
0
Night Ranger
Заблокирован
14.01.2015, 10:54  [ТС] 7
Цитата Сообщение от SoftIce Посмотреть сообщение
17 январь, 2 февраль, 1 секун
Это уже не я, слова форматируются функцией, но можно и доработать немного
спасибо за замечание
0
Sasha_Smirnov
5494 / 1322 / 144
Регистрация: 08.02.2009
Сообщений: 4,042
Записей в блоге: 29
14.01.2015, 18:53 8
На этот случай есть небольшая иллюстрация: форматирование даты

И даже специальная русскоговорящая функция Format: Как правильно прочитать скрипт?

Она же и здесь: Как по номеру дня в году вывести число и месяц в общепринятой форме (например, 33-й день года — 2 февраля)

Добавлено через 4 минуты
Цитата Сообщение от Gibboustooth Посмотреть сообщение
Формат для 2007 экселя:
Как привести дату к формату: "21" мая 2001 г.
0
Night Ranger
Заблокирован
14.01.2015, 19:05  [ТС] 9
Стоило было уточнить, замечания по поводу форматирования не связанны с работой моего календаря, я в качестве примера положил простейший способ получения длинной даты,
кстати и в системе под часами именно так и пишет 1 январь..

в коде есть буквально следующее:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub tb_Click()
    'Здесь могут быть дальнейшие инструкции после выбора даты
    'Например дату можно поместить в активную ячейку
    '----------------------------------------------------------------
    
    '
    '
    '
 
    ActiveCell = FormatDateTime(ThisDate, vbLongDate)
    '----------------------------------------------------------------
    If chbx.Value Then Me.Hide
End Sub
Добавлено через 2 минуты
а вообще, этот календарь будет работать корректно в любой операционной системе
в английской, русской, японской, чехословацкой и тд..., так-как у них названия будут на
своём региональном языке
0
Sasha_Smirnov
5494 / 1322 / 144
Регистрация: 08.02.2009
Сообщений: 4,042
Записей в блоге: 29
14.01.2015, 19:05 10
Цитата Сообщение от SoftIce Посмотреть сообщение
1 секунд
О, это вообще! Календарь на любой год

Картинка:
1
Night Ranger
Заблокирован
14.01.2015, 19:14  [ТС] 11
Цитата Сообщение от Sasha_Smirnov Посмотреть сообщение
О, это вообще!
Что и требовалось доказать
0
SoftIce
es geht mir gut
11064 / 4463 / 1130
Регистрация: 27.07.2011
Сообщений: 10,945
Завершенные тесты: 1
14.01.2015, 20:42 12
Цитата Сообщение от Night Ranger Посмотреть сообщение
кстати и в системе под часами именно так и пишет 1 январь..
Систему сам собирал в гараже?
0
Миниатюры
Календарь, который понравится всем (готовое решение)  
Alex77755
10945 / 3436 / 591
Регистрация: 13.02.2009
Сообщений: 10,201
14.01.2015, 23:01 13
Мои претензии к календарю:
В ячейку вставляется не дата, а строка, которую в дальнейшем стандартными средствами не обработать.
Если не замахиваться на весь мир, а, допустим, только на русскоязычную часть (заодно удовлетворить Sasha_Smirnov), то можно и выставить правильный формат в ячейке)
Visual Basic
1
2
    ActiveCell = ThisDate
    ActiveCell.NumberFormat = "[$-FC19]d mmmm yyyy г."
3
Миниатюры
Календарь, который понравится всем (готовое решение)  
Night Ranger
Заблокирован
14.01.2015, 23:05  [ТС] 14
Цитата Сообщение от Alex77755 Посмотреть сообщение
то можно и выставить правильный формат в ячейке
Хорошо буду знать, я учел все предложения, с минуты на минуту скину новый релиз
0
Alex77755
14.01.2015, 23:08
  #15

Не по теме:

Для Украины это будет "[$-FC22]d mmmm yyyy г."

0
Night Ranger
Заблокирован
14.01.2015, 23:12  [ТС] 16
Цитата Сообщение от Alex77755 Посмотреть сообщение
Для Украины это будет "[$-FC22]d mmmm yyyy г.
Конечно, куда-же мы без украины, есть предложение:
скинте еще варианты [$-...] если вам о них известно (пожалуйста)
0
Alex77755
10945 / 3436 / 591
Регистрация: 13.02.2009
Сообщений: 10,201
14.01.2015, 23:38 17
Макрос записывает:
Visual Basic
1
2
3
4
5
Sub Макрос1()
' Макрос записан 14.01.2015 (Александр)
    ActiveCell.FormulaR1C1 = "=TODAY()"
    Selection.NumberFormat = "[$-FC22]d mmmm yyyy"" р."";@"
End Sub
2
Night Ranger
Заблокирован
14.01.2015, 23:57  [ТС] 18
Итак новый релиз:

Кликните здесь для просмотра всего текста


Кликните здесь для просмотра всего текста

Visual Basic
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]http://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
0
Миниатюры
Календарь, который понравится всем (готовое решение)  
Вложения
Тип файла: xls Календарь v2.xls (79.5 Кб, 101 просмотров)
Sasha_Smirnov
5494 / 1322 / 144
Регистрация: 08.02.2009
Сообщений: 4,042
Записей в блоге: 29
15.01.2015, 01:48 19
Цвета неба и солца не передались, но пишет что надо.

А я ещё кое-что улучшил: теперь нужную ячейку (куда пишем дату) щёлкаем при открытой форме!
1
Night Ranger
Заблокирован
15.01.2015, 01:51  [ТС] 20
Ну да, усовершенствовать теперь можно сколько угодно
а цвета неба и солнца, это моя рабочая тема оформления, в стиле уолта диснея
0
15.01.2015, 01:51
Answers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
15.01.2015, 01:51

Готовое решение по сборке ПК
Здравствуйте. Хочу сам собрать компьютер. Прочел пару десятков тем на эту тему, но многое так и...

форум на php - готовое решение
Добрый день! Подскажите пожалуйста готовое решение php форума, что-нибудь типа...

Скачка клипов - готовое решение
Собственно от делать нех. Написал гомнокод. по скачке (новинок) клипов с ru.tv Авось кому...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
20
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2019, vBulletin Solutions, Inc.
Рейтинг@Mail.ru