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

Сборка значений полей (конкатенация) понескольким записям (ADO - Позднее связывание)

Public Function RecordsToStr(lValID As Long, Optional iFieldNo As Integer = 0) As Variant
'Конкатенация строк ...
Dim sSQL As String, iLen As Integer, vVal
Dim sRowDelimiter As String
Dim rst As Object 'Используем "позднее связывание", если библиотека ADO подключена то As ADO.RecordSet
'---------------------------------------------------------------------------------------------------[/REM]
On Error GoTo RecordsToStr_Err

    Select Case iFieldNo
        Case 0
        sRowDelimiter = ", "
        sSQL = "SELECT Название_Книги FROM тНазвание WHERE (ФИО_Читателя = " & lValID & ");"
        Case 1
        sRowDelimiter = " + "
        sSQL = "SELECT Format([Стоимость_Книги], '# ##0.00') FROM тНазвание WHERE (ФИО_Читателя = " & lValID & ");"
    End Select
    
    Set rst = CreateObject("ADODB.Recordset")
'Получение списка
    rst.Open sSQL, CurrentProject.Connection, 3, 1, 1
    If Not rst.EOF Then
        'Применение метода GetString (ADO):
        '... rs.GetString(StringFormat, NumRows, ColumnDelimiter, RowDelimiter, NullExpr)
        '    1й аргумент: StringFormat всегда (и по умолчанию видимо) = 2 (adClipString)
        '    2й аргумент: NumRows - Количество строк, которые необходимо преобразовать. Тут = Все!
        '    3й аргумент: Разделитель, используемый между столбцами, по умолчанию = символ TAB.
        '                 Тут пробел = " "
        '    4й аргумент: RowDelimiter - Разделитель строк, по умолчанию = Перевод строки (Chr(13))
        '    5й аргумент: NullExpr - Замещает пустые значения полей, по умолчанию = пустая строка
        '                 Тут "н/д!" (нет данных!)
        vVal = rst.GetString(2, , , sRowDelimiter)

'Обрезка последнего "сепаратора"
        iLen = Len(vVal) - Len(sRowDelimiter)
        RecordsToStr = Mid(vVal, 1, iLen)
    End If

RecordsToStr_End:
    On Error Resume Next
    rst.Close: Set rst = Nothing
    Err.Clear
    Exit Function

RecordsToStr_Err:
    RecordsToStr = "Error: " & Err.Number
    'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Function : RecordsToStr - Module1.", vbCritical, "Error!"
    'Debug.Print "RecordsToStr_Line: " & Erl & "."
    Err.Clear
    Resume RecordsToStr_End
End Function




Справка по Метод GetString (ADO):
https://learn.microsoft.com/ru-ru/sql/ado/reference/ado-api/getstring-method-ado?view=sql-server-ver16

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

Public Function RelativesVal(vRecID, Optional sRowsSeparator$ = vbCrLf, Optional vNoValueReturn) As Variant
'Возвращает строку "список родственников" для одной записи из таблицы "Личный состав"
'Если ничего не найдено, то = Null
'----------------------------------------------------------------------------------------
'Аргументы:
'   vRecID         : Код записи для нахождения родни по полю: "Родственники.рдсЛичныйСоставSID"
'   vRowsSeparator : Разделитель строк, по умолчанию = Перевод строки
'   vNoValueReturn : Значение возвращаемое если ничего не найдено, по умолчанию = Null
'----------------------------------------------------------------------------------------
'Примеры использования:
'  ?RelativesVal(1)        ' С переводом строки (по умолчанию)
'  ?RelativesVal(2, "; ")  ' Через точку с запятой + пробел
'----------------------------------------------------------------------------------------
Dim rst As Object 'Используем "позднее связывание", если библиотека ADO подключена то As ADO.RecordSet
Dim vVal, sVal$, iLen%
'----------------------------------------------------------------------------------------
On Error GoTo RelativesStr_Err
    Set rst = CreateObject("ADODB.Recordset")

'Строим запрос "список родственников" по переданному vRecID
    sVal = "SELECT [сртСтепеньРодства] & ':' AS СтепеньР, рдсФамилия, рдсИмя, рдсОтчество, " & vbCrLf & _
                "IIf(Not IsNull([рдсДатаРождения]),Year([рдсДатаРождения]) & 'гр') AS ГодРождения " & vbCrLf & _
            "FROM СтепениРодства INNER JOIN Родственники " & vbCrLf & _
            "   ON СтепениРодства.СтепеньРодстваID = Родственники.рдсСтепеньРодстваSID " & vbCrLf & _
            "WHERE (рдсЛичныйСоставSID = " & vRecID & ") ORDER BY рдсДатаРождения;"
    
    '... rst.Open - Значения: 3 = adOpenStatic, 1 = adLockReadOnly, 1 = adCmdText
    rst.Open sVal, CurrentProject.Connection, 3, 1, 1
    If Not rst.EOF Then
        'Применение метода GetString (ADO):
        '... rs.GetString(StringFormat, NumRows, ColumnDelimiter, RowDelimiter, NullExpr)
        '    1й аргумент: StringFormat всегда (и по умолчанию видимо) = 2 (adClipString)
        '    2й аргумент: NumRows - Количество строк, которые необходимо преобразовать. Тут = Все!
        '    3й аргумент: Разделитель, используемый между столбцами, по умолчанию = символ TAB.
        '                 Тут пробел = " "
        '    4й аргумент: RowDelimiter - Разделитель строк, по умолчанию = Перевод строки (Chr(13))
        '    5й аргумент: NullExpr - Замещает пустые значения полей, по умолчанию = пустая строка
        '                 Тут "н/д!" (нет данных!)
        vVal = rst.GetString(2, , " ", sRowsSeparator, "н/д!")
        iLen = Len(vVal) - Len(sRowsSeparator)
        RelativesVal = Mid(vVal, 1, iLen) 'Обрезка последнего "сепаратора"
    Else
        RelativesVal = vNoValueReturn
    End If
    
RelativesStr_End:
    On Error Resume Next
    rst.Close: Set rst = Nothing
    Err.Clear
    Exit Function

RelativesStr_Err:
    Debug.Print "Err# " & Err & " - " & Err.Description
    Err.Clear
    Resume RelativesStr_End
End Function


Picture




Ещё один "короткий" вариант (строчки через запятую):

Private Function ConcatStr(sSQL) As Variant
Dim rs As Object, sVal As String
    Set rs = CreateObject("ADODB.Recordset")
    With rs
        .Open sSQL, CurrentProject.Connection, 3, 1
        If Not .EOF Then
            sVal = .GetString(, , , ", ")
            sVal = Left(sVal, Len(sVal) - 2)
            ConcatStr = sVal
        Else
            ConcatStr = Null
        End If
    .Close
    End With
    Set rs = Nothing
End Function




Скачать

MSA-2007 ( 80 kB) Пример


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