modfun.bas

基于VB开发的土壤指标测量的数据库查询代码

Attribute VB_Name = "ModFun"
Public Function con_database(mdb_name As String, db_name As String, p_adores As adodb.Recordset)
    '设置连接数据库
    Dim con As adodb.Connection
    
    Dim db_constr As String
    Set p_adores = New adodb.Recordset
    db_constr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\数据库\" & mdb_name & ".mdb" '连接字符串。
    Set con = New adodb.Connection
    con.ConnectionString = db_constr
    con.Open db_constr
     
    p_adores.CursorLocation = adUseClient
    p_adores.Open "select * from " & db_name, con, adOpenKeyset, adLockOptimistic '连接所点击的表。
    
End Function

Public Function Con_TableName(g_AdoTableName As adodb.Connection, g_AdoTableNameRes As adodb.Recordset, mdb_name As String, Concmb As ComboBox)
'连接数据库，显示库中所有表的名称，并添加到cmb列表中

     Set g_AdoTableNameCon = New adodb.Connection
     Set g_AdoTableNameRes = New adodb.Recordset
     g_AdoTableNameCon.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\数据库\" & mdb_name & ".mdb"
     
     g_AdoTableNameCon.Open
     Set g_AdoTableNameRes = g_AdoTableNameCon.OpenSchema(adSchemaTables)
     Do Until g_AdoTableNameRes.EOF        '判断表的名称<>"MS"
        If VBA.Left(g_AdoTableNameRes.Fields("table_name").Value, 2) <> "MS" Then
    '        If (Not g_AdoTableNameRes.Fields("table_name").Value = "1评价指标体系说明表") Then
                 Concmb.AddItem g_AdoTableNameRes.Fields("table_name").Value
    '        End If
        End If
        g_AdoTableNameRes.MoveNext
     Loop
    Exit Function
    
End Function



Public Function FilterFieldRes(rstTemp As adodb.Recordset, _
    strField As String, strFilter As String, dg As DataGrid, Cbobds As ComboBox) As adodb.Recordset
'    On Error Resume Next
    
    ' 在指定的记录集对象上设置筛选操作并打开一个新的记录集对象。
    Select Case Cbobds.Text
        Case "="
            rstTemp.Filter = strField & " = '" & strFilter & "'"
        
        Case "<"
            rstTemp.Filter = strField & " < '" & strFilter & "'"
        Case ">"
            rstTemp.Filter = strField & " > '" & strFilter & "'"
        Case ">="
            rstTemp.Filter = strField & " >= '" & strFilter & "'"
        Case "<="
            rstTemp.Filter = strField & " <= '" & strFilter & "'"
    End Select
    Set dg.DataSource = rstTemp
    dg.Refresh
End Function