“Solution alternative à dlookup” Réponses codées

Solution alternative à dlookup

Public Function ESQLLookup(strField As String, strTable As String, Optional Criteria As Variant, _
    Optional OrderClause As Variant) As Variant
 
    Dim rs As ADODB.Recordset         'To retrieve the value to find.
    Dim rsMVF As ADODB.Recordset      'Child recordset to use for multi-value fields.
    Dim varResult As Variant        'Return value for function.
    Dim strSQL As String            'SQL statement.
    Dim strOut As String            'Output string to build up (multi-value field.)
    Dim lngLen As Long              'Length of string.
    Const strcSep = ","             'Separator between items in multi-value list.

    'Initialize to null.
    varResult = Null

    'Encapsulate Domain in brackets if none exist to allow special characters in the Domain string
    If Left$(strTable, 1) <> "[" Then
        strTable = "[" & strTable & "]"
    End If

    'Build the SQL string.
    strSQL = "SELECT TOP 1 " & strField & " FROM " & strTable
    If Not IsMissing(Criteria) Then
        strSQL = strSQL & " WHERE " & Criteria
    End If
    If Not IsMissing(OrderClause) Then
        strSQL = strSQL & " ORDER BY " & OrderClause
    End If
    strSQL = strSQL & ";"

    'Lookup the value.
    OpenMyRecordset rs, strSQL, rrOpenForwardOnly, rrLockReadOnly, True
    If rs.RecordCount > 0 Then
        'Will be an object if multi-value field.
        If VarType(rs(0)) = vbObject Then
            Set rsMVF = rs(0).Value
            Do While Not rsMVF.EOF
                If rs(0).Type = 101 Then        'dbAttachment
                    strOut = strOut & rsMVF!FileName & strcSep
                Else
                    strOut = strOut & rsMVF![Value].Value & strcSep
                End If
                rsMVF.MoveNext
            Loop
            'Remove trailing separator.
            lngLen = Len(strOut) - Len(strcSep)
            If lngLen > 0& Then
                varResult = Left(strOut, lngLen)
            End If
            Set rsMVF = Nothing
        Else
            'Not a multi-value field: just return the value.
            varResult = rs(0)
        End If
    End If
    rs.Close

    'Assign the return value.
    ESQLLookup = varResult
   
ErrEx.Catch 11 ' Division by Zero
    Debug.Print strSQL
    MsgBox "To troubleshoot this error, please evaluate the data that is being processed by:" _
            & vbCrLf & vbCrLf & strSQL, vbCritical, "Division by Zero Error"

ErrEx.CatchAll
    MsgBox "Error " & err.Number & ": " & err.Description, vbCritical, "Unexpected error"
    
ErrEx.Finally
    Set rs = Nothing

End Function