indata.bas

本系统是给大庆油田做的一个示例程序

    'rq = rq1
    
    On Error GoTo err1
    strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DataIn.mdb;Persist Security Info=False"
    con.Open strCon
    
    strSql = "select * from Well_Data where jh='" & jh & "'"
    rs.Open strSql, con, adOpenDynamic, adLockOptimistic
    filterstr = "rq=#" & rq & "#"
    rs.Filter = filterstr
    If rs.BOF Then
        Set rs = Nothing
        strSql = "select max(rq) as aa  from Well_Data where jh='" & jh & "'"
        rs.Open strSql, con, adOpenDynamic, adLockOptimistic
        rs.MoveFirst
        rq = rs.Fields("aa")
    End If
    Set rs = Nothing
      
    strSql = "select * from Well_Data where jh='" & jh & "'"
    rs.Open strSql, con, adOpenDynamic, adLockOptimistic
    filterstr = "rq=#" & rq & "#"
    rs.Filter = filterstr
    If rs.BOF Then
        'MsgBox "数据库里面不存在该井号和日期对应的油井参数！", vbInformation, "提醒"
        Read_WellData = False
        Exit Function
    End If
      
    cyjlx = Trim(" " & rs.Fields("cyjlx"))
    Lz = rs.Fields("lz")
    ps = rs.Fields("ps")
    pb = rs.Fields("pb")
    g = rs.Fields("g")
    hs = rs.Fields("hs")
    mu = rs.Fields("mu")
    so = rs.Fields("so")
    TSurface = rs.Fields("Tsurface")
    dTPer100m = rs.Fields("dTPer100m")
    gj = rs.Fields("gj")
    TubeAnchor = rs.Fields("TubeAnchor")
    yy = rs.Fields("yy")
    ty = rs.Fields("ty")
    bs = rs.Fields("bs")
    hd = rs.Fields("hd")
    qy = rs.Fields("qy")
    s = rs.Fields("s")
    n = rs.Fields("n")
    bj = rs.Fields("bj")
    nrod = rs.Fields("nrod")
    drod = rs.Fields("drod")
    lrod = rs.Fields("lrod")
      
    Set rs = Nothing
    con.Close
    Read_WellData = False
    Exit Function
err1:
     MsgBox Err.Description
End Function
Function Read_WellStructure(jh As String, jg As String, xs As String, jxj As String, fwj As String) As Boolean
    Dim con As New ADODB.Connection, rs As New ADODB.Recordset
    Dim strCon As String, strSql As String
    'On Error GoTo err1
    strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DataIn.mdb;Persist Security Info=False"
    strSql = "select * from Well_Structure where jh='" & jh & "'"
    con.Open strCon
    rs.Open strSql, con, adOpenDynamic, adLockOptimistic
    If rs.BOF Then
          'MsgBox "数据库里面不存在该井号对应的井身参数！", vbInformation, "提醒"
          Read_WellStructure = False
          Exit Function
    End If
    jg = rs.Fields("jg")
    If jg = "直井" Then
    Else
        xs = rs.Fields("xs")
        jxj = rs.Fields("jxj")
        fwj = rs.Fields("fwj")
    End If
    Set rs = Nothing
    con.Close
    Read_WellStructure = True
    Exit Function
err1:
    MsgBox Err.Description
End Function

Function Read_MeasuringDatas(jh As String, rq As Date, ByRef s As Single, ByRef n As Single, _
               prstr As String, prlstr As String) As Boolean
  
    Dim con As New ADODB.Connection, rs As New ADODB.Recordset
    Dim strCon As String, strSql As String, filterstr As String
    On Error GoTo err1:
    strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DataIn.mdb;Persist Security Info=False"
    strSql = "select * from Card_Fig where jh='" & jh & "'"
    con.Open strCon
    rs.Open strSql, con, adOpenDynamic, adLockOptimistic
    filterstr = "rq=#" & rq & "#"
    rs.Filter = filterstr
    If rs.BOF Then
        MsgBox "不存在该井和日期所对应的测试功图！", vbInformation, "提醒"
        Read_MeasuringDatas = False
        Exit Function
    End If
   
    s = rs.Fields("s")
    n = rs.Fields("n")
    prstr = rs.Fields("pr")
    prlstr = rs.Fields("prl")
    
    Set rs = Nothing
    con.Close
    Read_MeasuringDatas = True
    Exit Function
err1:
      MsgBox Err.Description
    End Function

Rem 从DataIn.mdb数据库读用户单位名称
Sub ReadCompanyName(obj As Object)

    Dim con As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim strCon As String, strSql As String
    Dim str1 As String, str2 As String
    
    Screen.MousePointer = 11
    obj.Clear
    strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DataIn.mdb;Persist Security Info=False"
    strSql = "select CompanyName from Users Order by CompanyName"
    con.Open strCon
    rs.Open strSql, con, adOpenDynamic, adLockOptimistic
    
    If rs.BOF Then
        Screen.MousePointer = 1
    Exit Sub
    End If
    str1 = "": str2 = ""
    str1 = rs.Fields("CompanyName")
    
    obj.AddItem str1
    Do Until rs.EOF
        str2 = rs.Fields("CompanyName")
        If Not (str1 = str2) Then
           str1 = str2
           obj.AddItem Trim(str1)
        End If
        rs.MoveNext
    Loop
    obj.Text = Trim(str1)
    
    Screen.MousePointer = 1
    rs.Close
    con.Close
    Exit Sub
err1:
    MsgBox Err.Description
    Screen.MousePointer = 1
End Sub

Rem  读操作员姓名
Sub ReadUsersName(obj As Object, CompanyName As String)
    Dim con As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim strCon As String, strSql As String
    Dim Name1 As String, Name2 As String
    On Error GoTo err1:
    If Len(CompanyName) = 0 Then Exit Sub
    Screen.MousePointer = 11
    obj.Clear
    strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DataIn.mdb;Persist Security Info=False"
    strSql = "select CompanyName,UserName from Users where CompanyName='" & CompanyName & "'Order by UserName"
    con.Open strCon
    rs.Open strSql, con, adOpenDynamic, adLockOptimistic
    
    Name1 = rs.Fields("UserName")
    obj.AddItem Name1
    Do Until rs.EOF
        Name2 = rs.Fields("UserName")
        If Not (Name1 = Name2) Then
            Name1 = Name2
            obj.AddItem Name1
        End If
        rs.MoveNext
    Loop
    
    obj.Text = Name1
    
    Screen.MousePointer = 1
    rs.Close
    con.Close
    Exit Sub
err1:
   MsgBox Err.Description
   Screen.MousePointer = 1
End Sub
Sub Del_ListWell(obj As MSFlexGrid)
    Dim con As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim strCon As String, strSql As String
    Dim jh As String, rq As Date, i As Integer, row As Integer
    On Error GoTo err1:
    Screen.MousePointer = 11
    row = obj.Rows
    For i = row - 1 To 1 Step -1
        obj.RemoveItem (i)
    Next
    strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DataIn.mdb;Persist Security Info=False"
    strSql = "select jh,rq from Well_Data Order by jh"
    con.Open strCon
    rs.Open strSql, con, adOpenDynamic, adLockOptimistic
    i = 0
    Do Until rs.EOF
         jh = rs.Fields("jh")
         rq = rs.Fields("rq")
         i = i + 1
         obj.AddItem jh
         obj.col = 1: obj.row = i
         obj.Text = rq
         DoEvents
         rs.MoveNext
    Loop
    Screen.MousePointer = 1
    rs.Close
    con.Close
    Exit Sub
err1:
    MsgBox Err.Description
    Screen.MousePointer = 1
End Sub

Sub Save_CompanyName(CompanyName As String, UserName As String)

    Dim con As New ADODB.Connection, rs As New ADODB.Recordset
    Dim strCon As String, strSql As String, filterstr As String
    On Error GoTo err1
    strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DataIn.mdb;Persist Security Info=False"
    strSql = "select * from Users where CompanyName='" & CompanyName & "'"
    con.Open strCon
    rs.Open strSql, con, adOpenDynamic, adLockOptimistic
    filterstr = "UserName=#" & UserName & "#"
    rs.Filter = filterstr
    If rs.BOF Then
        rs.AddNew
    End If
    rs.Fields("CompanyName") = Trim(CompanyName)
    rs.Fields("UserName") = UserName
   
    rs.Update
    Set rs = Nothing
    con.Close
    Exit Sub
err1:
      MsgBox Err.Description
End Sub