VBA, MS Access MS Access в примерах

Поиск и вывод Даты Начала и Даты Окончания из текста

По материалам: https://www.cyberforum.ru/ms-access/thread3103727.html

Public Function GetDateFromString(vString, Optional iWhichDateReturn = 1) As Variant
'es - 07.05.2023 v001 'Функция возврашает Дату Начала и Дату Окончания из строки по аргументу
'---------------------------------------------------------------------------------------------------
'Аргумент: iWhichDateReturn - указывает какую по счёту дату вернуть
'   iWhichDateReturn = 1 - функция вернёт первую дату (по умолчанию)
'   iWhichDateReturn = 2 - функция вернёт вторую дату
'---------------------------------------------------------------------------------------------------
Dim objRegExp As Object, oMatches
Dim iVal%, sVal$, vVal
Static dEndDate As Date 'Статичная Даты Окончания  !!!

On Error GoTo GetDateFromString_Err
    
' Обрабатываем строку только один раз:
    If iWhichDateReturn = 1 Then
        Set objRegExp = CreateObject("VBScript.RegExp")
        objRegExp.Global = True
        objRegExp.Pattern = "\d{1,2}[\.,/-]\d{1,2}[\.,/-]\d{2,4}"
            
        Set oMatches = objRegExp.Execute(vString)
        
        vVal = Trim(oMatches(0))
        GetDateFromString = DateValue(vVal)
                       
        ' Заапоминаем дату окончания для повторного вызова:
        vVal = Trim(oMatches(1))
        dEndDate = DateValue(vVal)
        
    Else 'Повторный запрос конечной даты :
        If dEndDate > 0 Then
            GetDateFromString = dEndDate 'Берём из статичной перменной
        End If
        dEndDate = 0 'зачистка ...
    End If

GetDateFromString_End:
    On Error Resume Next
    Set objRegExp = Nothing
    Set oMatches = Nothing
    Err.Clear
    Exit Function

GetDateFromString_Err:
    Err.Clear
    Resume GetDateFromString_End
End Function


Пример эксплуатации:

Dim sVal$
        sVal = "текст в начале 10.02.2003 текст по середине 22.04.2004 ... ещё текст"
        Debug.Print GetDateFromString(sVal, 1)
        Debug.Print GetDateFromString(sVal, 2)

Вернёт:

10.02.2003 
22.04.2004
Назад ToTop
L.E. 07.05.2023
Рейтинг@Mail.ru