Доработка кода

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по Excel » Доработка кода (Формулы/Formulas)

Доработка кода

swi040779

Дата: Вторник, 22.02.2022, 16:10 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 17

Репутация: 0 ±

Замечаний: 80% ±

2010

Ребята, подскажите где и что в коде поменять (добавить) чтобы суббота и воскресенье отображались красным?

Option Explicit

Dim StartDayWeek As Integer, CountFebrary As Integer
Dim Silence As Boolean
Dim CountDays As Integer
Dim ctl As Control
Dim Labels(0 To 41) As New DateClass
Dim lblYears(0 To 3) As New DateYearClass

Private Sub cmbMonth_Change()
If Silence Then Exit Sub
Silence = True
Mon = cmbMonth.ListIndex + 1
scbMonth.Value = Mon
Call Refresh(CurrentDay, Mon, CLng(CurrentYear))
Silence = False
Me.Caption = NameDayOfWeek(DayOfWeek(CurrentDay, Mon, CLng(CurrentYear))) & " " & CurrentDay & " " & MonthForDay(Mon) & " " & CurrentYear
End Sub

Private Sub cmbMonth_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyV And Shift = 2 Then KeyCode = 0
If KeyCode = vbKeyDelete Then KeyCode = 0
If KeyCode = vbKeyBack Then KeyCode = 0
End Sub

Private Sub cmbMonth_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = 0
End Sub

Private Sub sbtSelectYear_Change()
If Silence Then Exit Sub
Silence = True
On Error Resume Next
CurrentYear = Str(sbtSelectYear.Value)
tbxYear.Text = CurrentYear
lblYear1.Caption = Mid(CurrentYear, Len(CurrentYear), 1)
lblYear2.Caption = Mid(CurrentYear, Len(CurrentYear) - 1, 1)
lblYear3.Caption = Mid(CurrentYear, Len(CurrentYear) - 2, 1)
lblYear4.Caption = Mid(CurrentYear, Len(CurrentYear) - 3, 1)
Call Refresh(CurrentDay, Mon, CLng(CurrentYear))
Silence = False
Me.Caption = NameDayOfWeek(DayOfWeek(CurrentDay, Mon, CLng(CurrentYear))) & " " & CurrentDay & " " & MonthForDay(Mon) & " " & CurrentYear
End Sub

Private Sub sbtSelectYear_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Silence Then Exit Sub
Silence = True
Call Refresh(CurrentDay, Mon, CLng(CurrentYear))
Silence = False
End Sub

Private Sub scbMonth_Change()
If Silence Then Exit Sub
Silence = True
Mon = scbMonth.Value
cmbMonth.ListIndex = scbMonth.Value - 1
Call Refresh(CurrentDay, Mon, CLng(CurrentYear))
Silence = False
Me.Caption = NameDayOfWeek(DayOfWeek(CurrentDay, Mon, CLng(CurrentYear))) & " " & CurrentDay & " " & MonthForDay(Mon) & " " & CurrentYear
End Sub

Private Sub tbxYear_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Call ChangeYear
End Sub

Private Sub tbxYear_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
End Sub

Private Sub tbxYear_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyV And Shift = 2 Then KeyCode = 0
If KeyCode = vbKeyReturn Then
Call ChangeYear
End If
End Sub

Private Sub UserForm_Initialize()
cmbMonth.List = Split("Январь Февраль Март Апрель Май Июнь Июль Август Сентябрь Октябрь Ноябрь Декабрь")

Dim initDate As Date
initDate = IIf(IsDate(ActiveCell.Value), ActiveCell.Value, Date)
Silence = True
CurrentDay = Day(initDate)
CurrentYear = Trim(Str(Year(initDate)))
Mon = Month(initDate)
cmbMonth.Value = cmbMonth.List(Month(initDate) - 1)
StartDay = CurrentDay
StartMonth = Mon
StartYear = CurrentYear
scbMonth.Value = Mon
sbtSelectYear.Value = CLng(CurrentYear)
lblYear1.Caption = Mid(CurrentYear, Len(CurrentYear), 1)
lblYear2.Caption = Mid(CurrentYear, Len(CurrentYear) - 1, 1)
lblYear3.Caption = Mid(CurrentYear, Len(CurrentYear) - 2, 1)
lblYear4.Caption = Mid(CurrentYear, Len(CurrentYear) - 3, 1)
Call Refresh(CurrentDay, Mon, CLng(CurrentYear))
Silence = False
Me.Caption = NameDayOfWeek(DayOfWeek(CurrentDay, Mon, CLng(CurrentYear))) & " " & CurrentDay & " " & MonthForDay(Mon) & " " & CurrentYear
Me.Left = 350
Me.Top = 250
End Sub

Sub Refresh(Day As Integer, Month As Integer, Year As Long)
Dim CountDaysOfLastMonth As Integer
CurrentDay = Day
CountFebrary = IIf(Visok(Year), 29, 28)
CountDays = Choose(Month, 31, CountFebrary, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
StartDayWeek = DayOfWeek(1, Month, Year)
If Month = 1 Then
CountDaysOfLastMonth = 31
Else
CountDaysOfLastMonth = Choose(Month - 1, 31, CountFebrary, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
End If
For Each ctl In DateForm.Controls
With ctl
If .Tag = "DateButton" Then
If .TabIndex < (StartDayWeek) Then
.Caption = CountDaysOfLastMonth - (StartDayWeek - ctl.TabIndex - 1)
.ForeColor = RGB(175, 175, 175)
.BackColor = Me.BackColor
'.SpecialEffect = fmSpecialEffectRaised
.SpecialEffect = fmSpecialEffectFlat
ElseIf .TabIndex > (StartDayWeek + CountDays - 1) Then
.Caption = .TabIndex - (StartDayWeek + CountDays) + 1
.ForeColor = RGB(175, 175, 175)
.BackColor = Me.BackColor
'.SpecialEffect = fmSpecialEffectRaised
.SpecialEffect = fmSpecialEffectFlat
Else
.Caption = .TabIndex - StartDayWeek + 1
If (.TabIndex + 1) Mod 7 = 0 Then
.ForeColor = RGB(255, 0, 0)
Else
.ForeColor = RGB(0, 0, 0)
End If
If .Caption = StartDay And Mon = StartMonth And CurrentYear = StartYear Then
.BackColor = RGB(255, 255, 255)
.SpecialEffect = fmSpecialEffectSunken
.ForeColor = RGB(0, 0, 0)
Else
.BackColor = Me.BackColor
.SpecialEffect = fmSpecialEffectRaised
End If
End If
On Error Resume Next
Set Labels(.TabIndex).DateButton = ctl
End If
If ctl.Tag = "YearButton" Then
On Error Resume Next
Set lblYears(.TabIndex - 51).YearButton = ctl
End If
End With
Next
End Sub

Sub SelectTextBox()
For Each ctl In DateForm.Controls
If ctl.Tag = "YearButton" Then
ctl.Visible = False
On Error Resume Next
Set lblYears(ctl.TabIndex - 51).YearButton = ctl
End If
Next
With tbxYear
.Visible = True
.SetFocus
End With
End Sub

Sub MoveCursor()
Dim MoveDay As Integer
For Each ctl In DateForm.Controls
With ctl
If .Tag = "DateButton" Then
If .ForeColor <> RGB(175, 175, 175) Then
If .Caption = ActiveButton Then
.ForeColor = RGB(0, 0, 255)
.SpecialEffect = fmSpecialEffectSunken
MoveDay = .Caption
Else
If (.TabIndex + 1) Mod 7 = 0 Then
.ForeColor = RGB(255, 0, 0)
Else
.ForeColor = RGB(0, 0, 0)
End If
If Not (.Caption = StartDay And Mon = StartMonth And CurrentYear = StartYear) Then
.SpecialEffect = fmSpecialEffectRaised
End If
End If
End If
End If
End With
Next
Me.Caption = NameDayOfWeek(DayOfWeek(MoveDay, Mon, CLng(CurrentYear))) & " " & MoveDay & " " & MonthForDay(Mon) & " " & CurrentYear
End Sub

Sub ChangeYear()
If Silence = True Then Exit Sub
Silence = True
On Error Resume Next
lblYear1.Caption = Mid(tbxYear.Text, Len(tbxYear.Text), 1): If Not Err = 0 Then GoTo PASS
lblYear2.Caption = Mid(tbxYear.Text, Len(tbxYear.Text) - 1, 1): If Not Err = 0 Then lblYear2.Caption = ""
lblYear3.Caption = Mid(tbxYear.Text, Len(tbxYear.Text) - 2, 1): If Not Err = 0 Then lblYear3.Caption = ""
lblYear4.Caption = Mid(tbxYear.Text, Len(tbxYear.Text) - 3, 1): If Not Err = 0 Then lblYear4.Caption = ""
CurrentYear = tbxYear.Text
sbtSelectYear.Value = CLng(CurrentYear)
Call Refresh(CurrentDay, Mon, CLng(CurrentYear))
PASS:
lblYear1.Visible = True
lblYear2.Visible = True
lblYear3.Visible = True
lblYear4.Visible = True
tbxYear.Visible = False
Silence = False
Me.Caption = NameDayOfWeek(DayOfWeek(CurrentDay, Mon, CLng(CurrentYear))) & " " & CurrentDay & " " & MonthForDay(Mon) & " " & CurrentYear
End Sub

[admin]Тема закрыта. Причина:Нарушения правил форума пп. 2, 3, 5f и 5r
Многократные повторные нарушения правил, игнорирование замечаний администрации[/admin]

Ребята, подскажите где и что в коде поменять (добавить) чтобы суббота и воскресенье отображались красным?

Ответить

СообщениеРебята, подскажите где и что в коде поменять (добавить) чтобы суббота и воскресенье отображались красным?

Автор - swi040779
Дата добавления - 22.02.2022 в 16:10

Мир MS Excel » Вопросы и решения » Вопросы по Excel » Доработка кода (Формулы/Formulas)

Страница 1 из 1
1