VBA, MS Access MS Access в примерах
Новости!
Ссылки
О Сайте
Поиск ...
Базы Данных
Таблицы
Запросы
Наборы Записей
Формы
Элементы Управления
Отчеты
Интерфейс
Приложение MSA
Импорт - Экспорт
Папки и Файлы
Преобразование
Приложения Внешние
Система
Утилиты
Примеры и Прочее

Дата Прописью

По материалам: https://www.cyberforum.ru/vba/thread541622.html#post10603753
и: https://www.cyberforum.ru/ms-access/thread3120273.html

Эксплуотация:

?ДАТАПРОПИСЬЮ(Date,,3) ' 3 =  С большой буквы

Вернёт:

Двенадцатое июля две тысячи двадцать третьего года

Ещё вариант:

?ДАТАПРОПИСЬЮ(Date,,2)

Вернёт:

12 июля 2023 года



Public Function ДАТАПРОПИСЬЮ(ByVal ДАТА As Date, Optional ByVal ПАДЕЖ As Integer = 1, Optional ByVal ФОРМАТ As Integer = 1) As String
'Возвращает дату прописью :  es 12.07.2023 v002 - Внесены пара испрвлений ("восемьдесятого" + С большой буквы)
' -------------------------------------------------------------------------------------------------/
'Аргументы:
'    ДАТА             - Обрабатываемая дата
'    ПАДЕЖ (1 или 2)  - Именительный - Родительный  (по умолчанию 1)
'    ФОРМАТ (1, 2 или 3):
'        1  - тринадцатого июля две тысячи семнадцатого года (по умолчанию)
'        2  - 13 июля 2017 года
'        3  - Тринадцатого июля две тысячи семнадцатого года (то же что и 1 - только с большой буквы)
' -------------------------------------------------------------------------------------------------/
' Например:
'   ?ДАТАПРОПИСЬЮ(CDate("13.07.2017") ,2 ,3)
'   Вернёт:
'   Тринадцатого июля две тысячи семнадцатого года
' -------------------------------------------------------------------------------------------------/
'   ?ДАТАПРОПИСЬЮ(CDate("13.07.2017") ,1 ,3)
'   Вернёт:
'   Тринадцатое июля две тысячи семнадцатого года
' -------------------------------------------------------------------------------------------------/
'Исходный мтериал: http://www.cyberforum.ru/vba/thread541622.html
' -------------------------------------------------------------------------------------------------/


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) = "октября"
    m(11) = "ноября"
    m(12) = "декабря"
    
' ЕДИНИЦЫ
    L1(0, 1) = "": L1(0, 0) = "": L1(0, 2) = ""
    L1(1, 1) = "одна": L1(1, 0) = "первое": L1(1, 2) = "первого"
    L1(2, 1) = "две": L1(2, 0) = "второе": L1(2, 2) = "второго"
    L1(3, 1) = "три": L1(3, 0) = "третье": L1(3, 2) = "третьего"
    L1(4, 1) = "четыре": L1(4, 0) = "четвертое": L1(4, 2) = "четвертого"
    L1(5, 1) = "пять": L1(5, 0) = "пятое": L1(5, 2) = "пятого"
    L1(6, 1) = "шесть": L1(6, 0) = "шестое": L1(6, 2) = "шестого"
    L1(7, 1) = "семь": L1(7, 0) = "седьмое": L1(7, 2) = "седьмого"
    L1(8, 1) = "восемь": L1(8, 0) = "восьмое": L1(8, 2) = "восьмого"
    L1(9, 1) = "девять": L1(9, 0) = "девятое": L1(9, 2) = "девятого"
    L1(10, 1) = "десять": L1(10, 0) = "десятое": L1(10, 2) = "десятого"
    L1(11, 1) = "одиннадцать": L1(11, 0) = "одиннадцатое": L1(11, 2) = "одиннадцатого"
    L1(12, 1) = "двенадцать": L1(12, 0) = "двенадцатое": L1(12, 2) = "двенадцатого"
    L1(13, 1) = "тринадцать": L1(13, 0) = "тринадцатое": L1(13, 2) = "тринадцатого"
    L1(14, 1) = "четырнадцать": L1(14, 0) = "четырнадцатое": L1(14, 2) = "четырнадцатого"
    L1(15, 1) = "пятнадцать": L1(15, 0) = "пятнадцатое": L1(15, 2) = "пятнадцатого"
    L1(16, 1) = "шестнадцать": L1(16, 0) = "шестнадцатое": L1(16, 2) = "шестнадцатого"
    L1(17, 1) = "семнадцать": L1(17, 0) = "семнадцатое": L1(17, 2) = "семнадцатого"
    L1(18, 1) = "восемнадцать": L1(18, 0) = "восемнадцатое": L1(18, 2) = "восемнадцатого"
    L1(19, 1) = "девятнадцать": L1(19, 0) = "девятнадцатое": L1(19, 2) = "девятнадцатого"
    L1(20, 1) = "двадцать": L1(20, 0) = "двадцатое": L1(20, 2) = "двадцатого"
 
' ДЕСЯТКИ
    L10(0, 1) = "": L10(0, 2) = "": L10(0, 0) = ""
    L10(1, 1) = "десять": L10(1, 2) = "десятого": L10(1, 0) = "десятое"
    L10(2, 1) = "двадцать": L10(2, 2) = "двадцатого": L10(2, 0) = "двадцатое"
    L10(3, 1) = "тридцать": L10(3, 2) = "тридцатого": L10(3, 0) = "тридцатое"
    L10(4, 1) = "сорок": L10(4, 2) = "сорокового"
    L10(5, 1) = "пятьдесят": L10(5, 2) = "пятьдесятого"
    L10(6, 1) = "шестьдесят": L10(6, 2) = "шестьдесятого"
    L10(8, 1) = "восемьдесят": L10(8, 2) = "восьмидесятого"
    L10(9, 1) = "девяносто": L10(9, 2) = "девяностого"
 
' СОТНИ
    L100(0, 1) = "": L100(0, 2) = ""
    L100(1, 1) = "сто": L100(1, 2) = "сотого"
    L100(2, 1) = "двести": L100(2, 2) = "двухсотого"
    L100(3, 1) = "триста": L100(3, 2) = "трехсотого"
    L100(4, 1) = "четыреста": L100(4, 2) = "четырехсотого"
    L100(5, 1) = "пятьсот": L100(5, 2) = "пятисотого"
    L100(6, 1) = "шестьсот": L100(6, 2) = "шестисотого"
    L100(7, 1) = "семьсот": L100(7, 2) = "семисотого"
    L100(8, 1) = "восемьсот": L100(8, 2) = "восьмисотого"
    L100(9, 1) = "девятьсот": L100(9, 2) = "девятисотого"
 
' ТЫСЯЧИ
    L1000(1) = "тысячного"
    L1000(2) = "двухтысячного"
    L1000(3) = "трехтысячного"
    L1000(4) = "четырехтысячного"
    L1000(5) = "пятитысячного"
    L1000(6) = "шеститысячного"
    L1000(7) = "семитысячного"
    L1000(8) = "восьмитысячного"
    L1000(9) = "девятитысячного"
 
    SYM(1) = "тысяча"
    SYM(2) = "тысячи"
    SYM(3) = "тысяч"
 
    d = Day(ДАТА)
 
' число
    If d Mod 10 = 0 Then
        LETTDAY = IIf(ПАДЕЖ = 1, L10(d / 10, 0), L10(d / 10, 2))
    Else
 
        If d <= 20 Then
            LETTDAY = IIf(ПАДЕЖ = 1, L1(d, 0), L1(d, 2))
        Else
            ' выделение десятков
            n10 = d \ 10
            ' выделение единиц
            n1 = d Mod 10
            LETTDAY = L10(n10, 1) & " " & IIf(ПАДЕЖ = 1, L1(n1, 0), L1(n1, 2))
        End If
    End If
 
' Месяц
    LETTMONTH = m(Month(ДАТА))

' Год
    y = Year(ДАТА)
    n1000 = Fix(y / 1000)
    n100 = Fix((y - n1000 * 1000) / 100)
    n10 = y - n1000 * 1000 - n100 * 100
    n1 = n10 - Fix(n10 / 10) * 10
 
    If n1000 > 0 And n100 = 0 And n10 = 0 And n1 = 0 Then
        LETTYEAR = Trim(LETTYEAR & " " & L1000(n1000))
    ElseIf n1000 > 0 Then
        LETTYEAR = Trim(LETTYEAR & " " & L1(n1000, 1))
        If n1000 = 1 Then
            LETTYEAR = LETTYEAR & " " & SYM(1)
        ElseIf n1000 < 5 Then
            LETTYEAR = LETTYEAR & " " & SYM(2)
        Else
            LETTYEAR = LETTYEAR & " " & SYM(3)
        End If
    End If
 
    If n100 > 0 And n10 = 0 And n1 = 0 Then
        LETTYEAR = Trim(LETTYEAR & " " & L100(n100, 2))
    ElseIf n100 > 0 Then
        LETTYEAR = Trim(LETTYEAR & " " & L100(n100, 1))
    End If
 
    If n10 > 0 And n1 = 0 Then
        LETTYEAR = Trim(LETTYEAR & " " & L10(n10 / 10, 2))
    ElseIf n10 < 20 Then
        LETTYEAR = Trim(LETTYEAR & " " & L1(n10, 2))
    Else
        LETTYEAR = Trim(LETTYEAR & " " & L10(Fix(n10 / 10), 1) & " " & L1(n1, 2))
    End If
 
    Select Case ФОРМАТ
        Case 1
            LETTERS = LETTDAY & " " & LETTMONTH & " " & LETTYEAR & " года" 
        Case 2
            LETTERS = Format(d, "00") & " " & LETTMONTH & " " & Format(y, "#####") & " года"
        Case 3
            LETTERS = UCase(Left(LETTDAY, 1)) & Mid(LETTDAY, 2) & " " & LETTMONTH & " " & LETTYEAR & " года"
    End Select
 
    ДАТАПРОПИСЬЮ = LETTERS  
 End Function
Назад ToTop
L.E. 12.07.2023
Рейтинг@Mail.ru