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
| Sub Перевести_выделенную_дату_в_текст()
Dim SumBase As String, SumText As String
On Error Resume Next
With Selection
SumText = .Text
SumText = Replace(SumText, " ", "", 1, , vbTextCompare) ' Удаляем в числе пробелы
SumText = Replace(SumText, "'", "", 1, , vbTextCompare) ' Удаляем в числе знаки '
SumText = Replace(SumText, ",", ".", 1, , vbTextCompare) ' Меняем , на .
SumText = Replace(SumText, Chr(160), "", 1, , vbBinaryCompare) ' Удаляем в числе неразрывные пробелы
SumBase = SumText
.Collapse Direction:=wdCollapseEnd
SumBase1 = DateSerial(Mid(SumBase, 7, 4), Mid(SumBase, 4, 2), Mid(SumBase, 1, 2))
.TypeText Text:=" " & ДАТАПРОПИСЬЮ(SumBase1)
End With
End Sub
Function ДАТАПРОПИСЬЮ(ByVal ДАТА As Date, Optional ByVal ПАДЕЖ As Integer = 1, Optional ByVal ФОРМАТ As Integer = 1) As String
PROG_NAME = "ДАТАПРОПИСЬЮ"
PROG_MAX = 100
Dim L1000(9) As String
Dim L100(9, 2) As String ' Сотни
Dim L10(9, 2) As String ' Десятки
Dim L1(22, 2) As String ' Единицы
Dim m(12) As String ' Месяца
Dim SYM(3) As String
Dim d As Integer, y As Integer
Dim LETTERS As String, LETTDAY As String, LETTMONTH As String, LETTYEAR As String
Dim n1000 As Integer, n100 As Integer, n10 As Integer, n1 As Integer
' МЕСЯЦА
m(1) = "января"
m(2) = "февраля"
m(3) = "марта"
m(4) = "апреля"
m(5) = "мая"
m(6) = "июня"
m(7) = "июля"
m(8) = "августа"
m(9) = "сентября"
m(10) = "октября"
1554 m(11) = "ноября"
1555 m(12) = "декабря"
' ЕДИНИЦЫ
1556 L1(0, 1) = "": L1(0, 0) = "": L1(0, 2) = ""
1557 L1(1, 1) = "одна": L1(1, 0) = "первое": L1(1, 2) = "первого"
1558 L1(2, 1) = "две": L1(2, 0) = "второе": L1(2, 2) = "второго"
1559 L1(3, 1) = "три": L1(3, 0) = "третье": L1(3, 2) = "третьего"
1560 L1(4, 1) = "четыре": L1(4, 0) = "четвертое": L1(4, 2) = "четвертого"
1561 L1(5, 1) = "пять": L1(5, 0) = "пятое": L1(5, 2) = "пятого"
1562 L1(6, 1) = "шесть": L1(6, 0) = "шестое": L1(6, 2) = "шестого"
1563 L1(7, 1) = "семь": L1(7, 0) = "седьмое": L1(7, 2) = "седьмого"
1564 L1(8, 1) = "восемь": L1(8, 0) = "восьмое": L1(8, 2) = "восьмого"
1565 L1(9, 1) = "девять": L1(9, 0) = "девятое": L1(9, 2) = "девятого"
1566 L1(10, 1) = "десять": L1(10, 0) = "десятое": L1(10, 2) = "десятого"
1567 L1(11, 1) = "одиннадцать": L1(11, 0) = "одиннадцатое": L1(11, 2) = "одиннадцатого"
1568 L1(12, 1) = "двенадцать": L1(12, 0) = "двенадцатое": L1(12, 2) = "двенадцатого"
1569 L1(13, 1) = "тринадцать": L1(13, 0) = "тринадцатое": L1(13, 2) = "тринадцатого"
1570 L1(14, 1) = "четырнадцать": L1(14, 0) = "четырнадцатое": L1(14, 2) = "четырнадцатого"
1571 L1(15, 1) = "пятнадцать": L1(15, 0) = "пятнадцатое": L1(15, 2) = "пятнадцатого"
1572 L1(16, 1) = "шестнадцать": L1(16, 0) = "шестнадцатое": L1(16, 2) = "шестнадцатого"
1573 L1(17, 1) = "семнадцать": L1(17, 0) = "семнадцатое": L1(17, 2) = "семнадцатого"
1574 L1(18, 1) = "восемнадцать": L1(18, 0) = "восемнадцатое": L1(18, 2) = "восемнадцатого"
1575 L1(19, 1) = "девятнадцать": L1(19, 0) = "девятнадцатое": L1(19, 2) = "девятнадцатого"
1576 L1(20, 1) = "двадцать": L1(20, 0) = "двадцатое": L1(20, 2) = "двадцатого"
' ДЕСЯТКИ
1577 L10(0, 1) = "": L10(0, 2) = "": L10(0, 0) = ""
1578 L10(1, 1) = "десять": L10(1, 2) = "десятого": L10(1, 0) = "десятое"
1579 L10(2, 1) = "двадцать": L10(2, 2) = "двадцатого": L10(2, 0) = "двадцатое"
1580 L10(3, 1) = "тридцать": L10(3, 2) = "тридцатого": L10(3, 0) = "тридцатое"
1581 L10(4, 1) = "сорок": L10(4, 2) = "сорокового"
1582 L10(5, 1) = "пятьдесят": L10(5, 2) = "пятьдесятого"
1583 L10(6, 1) = "шестьдесят": L10(6, 2) = "шестьдесятого"
1584 L10(7, 1) = "семьдесят": L10(7, 2) = "семьдесятого"
1585 L10(8, 1) = "восемьдесят": L10(8, 2) = "восемьдесятого"
1586 L10(9, 1) = "девяносто": L10(9, 2) = "девяностого"
' СОТНИ
1587 L100(0, 1) = "": L100(0, 2) = ""
1588 L100(1, 1) = "сто": L100(1, 2) = "сотого"
1589 L100(2, 1) = "двести": L100(2, 2) = "двухсотого"
1590 L100(3, 1) = "триста": L100(3, 2) = "трехсотого"
1591 L100(4, 1) = "четыреста": L100(4, 2) = "четырехсотого"
1592 L100(5, 1) = "пятьсот": L100(5, 2) = "пятисотого"
1593 L100(6, 1) = "шестьсот": L100(6, 2) = "шестисотого"
1594 L100(7, 1) = "семьсот": L100(7, 2) = "семисотого"
1595 L100(8, 1) = "восемьсот": L100(8, 2) = "восьмисотого"
1596 L100(9, 1) = "девятьсот": L100(9, 2) = "девятисотого"
' ТЫСЯЧИ
1597 L1000(1) = "тысячного"
1598 L1000(2) = "двухтысячного"
1599 L1000(3) = "трехтысячного"
1600 L1000(4) = "четырехтысячного"
1601 L1000(5) = "пятитысячного"
1602 L1000(6) = "шеститысячного"
1603 L1000(7) = "семитысячного"
1604 L1000(8) = "восьмитысячного"
1605 L1000(9) = "девятитысячного"
1606 SYM(1) = "тысяча"
1607 SYM(2) = "тысячи"
1608 SYM(3) = "тысяч"
1609 d = Day(ДАТА)
' число
1610 If d Mod 10 = 0 Then
1611 LETTDAY = IIf(ПАДЕЖ = 1, L10(d / 10, 0), L10(d / 10, 2))
1612 Else
1613 If d <= 20 Then
1614 LETTDAY = IIf(ПАДЕЖ = 1, L1(d, 0), L1(d, 2))
1615 Else
' выделение десятков
1616 n10 = d \ 10
' выделение единиц
1617 n1 = d Mod 10
1618 LETTDAY = L10(n10, 1) & " " & IIf(ПАДЕЖ = 1, L1(n1, 0), L1(n1, 2))
1619 End If
1620 End If
' Месяц
1621 LETTMONTH = m(Month(ДАТА))
' Год
1622 y = Year(ДАТА)
1623 n1000 = Fix(y / 1000)
1624 n100 = Fix((y - n1000 * 1000) / 100)
1625 n10 = y - n1000 * 1000 - n100 * 100
1626 n1 = n10 - Fix(n10 / 10) * 10
1627 If n1000 > 0 And n100 = 0 And n10 = 0 And n1 = 0 Then
1628 LETTYEAR = Trim(LETTYEAR & " " & L1000(n1000))
1629 ElseIf n1000 > 0 Then
1630 LETTYEAR = Trim(LETTYEAR & " " & L1(n1000, 1))
1631 If n1000 = 1 Then
1632 LETTYEAR = LETTYEAR & " " & SYM(1)
1633 ElseIf n1000 < 5 Then
1634 LETTYEAR = LETTYEAR & " " & SYM(2)
1635 Else
1636 LETTYEAR = LETTYEAR & " " & SYM(3)
1637 End If
1638 End If
1639 If n100 > 0 And n10 = 0 And n1 = 0 Then
1640 LETTYEAR = Trim(LETTYEAR & " " & L100(n100, 2))
1641 ElseIf n100 > 0 Then
1642 LETTYEAR = Trim(LETTYEAR & " " & L100(n100, 1))
1643 End If
1644 If n10 > 0 And n1 = 0 Then
1645 LETTYEAR = Trim(LETTYEAR & " " & L10(n10 / 10, 2))
1646 ElseIf n10 < 20 Then
1647 LETTYEAR = Trim(LETTYEAR & " " & L1(n10, 2))
1648 Else
1649 LETTYEAR = Trim(LETTYEAR & " " & L10(Fix(n10 / 10), 1) & " " & L1(n1, 2))
1650 End If
1651 Select Case ФОРМАТ
Case 1
1652 LETTERS = LETTDAY & " " & LETTMONTH & " " & LETTYEAR & " года"
1653 Case 2
1654 LETTERS = Format(d, "00") & " " & LETTMONTH & " " & Format(y, "#####") & " года"
1655 Case 3
1656 LETTERS = UCase(Left(LETTDAY, 1)) & Mid(LETTDAY, 2) & " " & LETTMONTH & " " & LETTYEAR & " года"
1657 End Select
1658 ДАТАПРОПИСЬЮ = LETTERS
End Function |
(
Сообщение было отмечено Eugene-LS как решение
Сообщение от seha1986
Лучше уж степлер
