VBA与数据库——写个类操作ADO_读取

'输出所有表名
Sub rbbtnOutTableName(control As IRibbonControl)
    If DB_Info.TablesCount = 0 Then
        MsgBox "请先点击[读取表名]"
    Else
        Dim i As Long
        For i = 0 To DB_Info.TablesCount - 1
            Cells(i + 1, "A").Value = DB_Info.Tables(i).SName
        Next
    End If
End Sub
'获取表结构
Sub rbbtnGetTableFields(control As IRibbonControl)
    If VBA.Len(DB_Info.ActiveTable.SName) Then
        Dim i As Long
        
        If DB_Info.ActiveTable.FieldsCount = 0 Then
            MsgBox "请先点击[读取字段名]。"
            Exit Sub
        End If
        
        For i = 0 To DB_Info.ActiveTable.FieldsCount - 1
            Range("A1").Offset(0, i).Value = DB_Info.ActiveTable.Fields(i).SName
            Range("A2").Offset(0, i).Value = DB_Info.ActiveTable.Fields(i).sType
            If DB_Info.ActiveTable.Fields(i).pk Then Range("A3").Offset(0, i).Value = "PK"
        Next
                
    Else
        MsgBox "请先选择表名。"
    End If
End Sub

'选择数据源，程序默认第一行是标题
'数据源的每一列都是一个查找的条件
'再选择输出的单元格，即输出的字段
Function SelectSerach(Optional bAllData As Boolean = False) As RetCode
    '选择数据源
    Dim rngsrc As Range
    On Error Resume Next
    Set rngsrc = Application.InputBox("选择条件数据源，第一行是标题。", Default:=ActiveCell.CurrentRegion.Address, Type:=8)
    On Error GoTo 0
    If rngsrc Is Nothing Then
        SelectSerach = ErrRT
        Exit Function
    End If
    If rngsrc.Rows.Count = 1 Then
        MsgBox "请至少选择2行数据，第1行标题，第2行数据"
        SelectSerach = ErrRT
        Exit Function
    End If
    Dim srcArr() As Variant
    srcArr = rngsrc.Value

    Dim rngout As Range
    On Error Resume Next
    Set rngout = Application.InputBox("选择输出字段单元格。", Default:=ActiveCell.CurrentRegion.Rows(1).Address, Type:=8)
    On Error GoTo 0
    If rngout Is Nothing Then
        SelectSerach = ErrRT
        Exit Function
    End If
    If rngout.Rows.Count > 1 Then
        MsgBox "请选择单行"
        SelectSerach = ErrRT
        Exit Function
    End If

    Dim strSelectSql As String
    Dim i As Long, j As Long, k As Long
    'select字段
    For i = 1 To rngout.Columns.Count
        strSelectSql = strSelectSql & VBA.CStr(rngout.Cells(1, i).Value) & ","
    Next
    '去掉最后的“,”
    strSelectSql = VBA.Left$(strSelectSql, VBA.Len(strSelectSql) - 1)
    strSelectSql = "select " & strSelectSql & " from " & DB_Info.ActiveTable.SName

    '字段类型，记录的是SType，后面用是否包含Char判断字符串
    Dim arrSrcFieldType() As String
    For i = 1 To UBound(srcArr, 2)
        '判断字段是否在表中存在，并记录字段类型，数据源字段顺序不固定
        For j = 0 To DB_Info.ActiveTable.FieldsCount - 1
            If DB_Info.ActiveTable.Fields(j).SName = VBA.CStr(srcArr(1, i)) Then
                k = k + 1
                ReDim Preserve arrSrcFieldType(k) As String
                arrSrcFieldType(k) = DB_Info.ActiveTable.Fields(j).sType
            End If
            
            If j = DB_Info.ActiveTable.FieldsCount Then
                MsgBox "不存在的字段：" & VBA.CStr(srcArr(1, i))
                SelectSerach = ErrRT
                Exit Function
            End If
        Next
    Next
    
    Dim rst As Object
    Dim strsql As String
    '用来构建 F1=X1 and F2=X2
    Dim sqlarr() As String
    ReDim sqlarr(1 To UBound(srcArr, 2)) As String
    
    Set rngout = rngout.Range("A1").Offset(1, 0)
    For i = 2 To UBound(srcArr, 1)
        For j = 1 To UBound(srcArr, 2)
            sqlarr(j) = VBA.CStr(srcArr(1, j)) & "=" & MPublic.GetFieldValueInSql(srcArr(i, j), arrSrcFieldType(j))
        Next j
        
        strsql = strSelectSql & " where " & VBA.Join(sqlarr, " and ")
        
        
        If DB_Info.db.ExecuteQueryRST(strsql, rst) Then
            MsgBox DB_Info.db.GetErr
            SelectSerach = ErrRT
            Exit Function
        End If
        
        If rst.RecordCount Then
            If bAllData Then
                rngout.CopyFromRecordset rst
                Set rngout = rngout.Offset(rst.RecordCount, 0)
            Else
                rngout.CopyFromRecordset rst, 1
                Set rngout = rngout.Offset(1, 0)
            End If
        Else
            rngout.Value = "未找到"
            Set rngout = rngout.Offset(1, 0)
        End If
    Next

    SelectSerach = SuccRT
End Function