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

Сборка значений поля (кконкатенация) по записям из источника данных

Public Function RecordsToString(sExpression$, sSource$, Optional vCriteria As Variant = Null, _
    Optional vOptions As Variant = Null, Optional sCut As String = "; ") As Variant
'es 16.12.2017 - LE 27.09.2020 v002
'Сборка значений (конкатенация) выражения sExpression по записям из источника данных sSource
'Возвращает совокупную строку разделённую указанным в аргументе делителем
'--------------------------------------------------------------------------
'Аргументы:
'   sExpression    - Выражение или Название поля для сборки значений
'   sSource        - Название источника данных (Таблицы или Запроса)- Откуда?!
'   vCriteria      - Опционально: Критерии отбора записей для WHERE ...
'   vOptions       - Поле и Порядок сортировки (Типа: "ORDER BY ..." или "DESC" и т.п.)
'   sCut           - Опционально: Разделитель значений (по умолчанию = "; " с пробелом!)
'--------------------------------------------------------------------------
'Примеры эксплуотаации
'   В выражении запроса:
'   Файлы: RecordsToString("Файл";"Query1";"Посетитель=" & 
'   [Документы].[Посетитель] & " AND ДатаВизита=" & Format([ДатаВизита];"\#mm/dd/yyyy\#"))
'   В коде:
'   v = RecordsToString("DatName", "Название_Таблицы", "Sub_ID=" & Me!txtID, "ORDER BY DatName DESC")
'--------------------------------------------------------------------------

Dim rst As DAO.Recordset
Dim s$
On Error GoTo RecordsToString_Err
    s = "SELECT " & sExpression & " FROM " & sSource & (" WHERE " + vCriteria) & (" " + vOptions)
    Set rst = CurrentDb.OpenRecordset(s, dbReadOnly) 

    With rst
        Do Until .EOF = True 'Цикл до конца
            RecordsToString = RecordsToString & sCut & .Fields(0)
            .MoveNext
        Loop
    End With
    If Len(RecordsToString) > Len(sCut) Then
        RecordsToString = Mid(RecordsToString, 3) 'Удаление первого делителя
    End If
    
    'Debug.Print RecordsToString '(для тестирования)

RecordsToString_End:
    On Error Resume Next
    rst.Close
    Set rst = Nothing
    Exit Function
    
RecordsToString_Err:
    RecordsToString = "ERR: " & Err.Number
    'Debug.Print "Процедура RecordsToString привела к ошибке:" & vbCrLf & _
        Err.Description & vbCrLf & " Err#" & Err.Number
    Resume RecordsToString_End
End Function



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