indata.bas

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

Attribute VB_Name = "InData"
Option Explicit
Sub Save_WellData(jh As String, rq As Date, cyjlx As String, Lz As Single, ps As Single, pb As Single, _
                  g As Single, hs As Single, mu As Single, so As Single, TSurface As Single, _
                  dTPer100m As Single, gj As Single, TubeAnchor As String, yy As Single, ty As Single, _
                  bs As Single, hd As Single, qy As Single, s As Single, n As Single, bj As Single, _
                  nrod As Integer, drod As String, drodi As String, lrod 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 Well_Data where jh='" & jh & "'"
    con.Open strCon
    rs.Open strSql, con, adOpenDynamic, adLockOptimistic
    filterstr = "rq=#" & rq & "#"
    rs.Filter = filterstr
    If rs.BOF Then
        rs.AddNew
    End If
    rs.Fields("jh") = Trim(jh)
    rs.Fields("rq") = rq
    rs.Fields("cyjlx") = Trim(cyjlx)
    rs.Fields("lz") = Lz
    rs.Fields("ps") = ps
    rs.Fields("pb") = pb
    rs.Fields("g") = g
    rs.Fields("hs") = hs
    rs.Fields("mu") = mu
    rs.Fields("so") = so
    rs.Fields("TSurface") = TSurface
    rs.Fields("dTPer100m") = dTPer100m
    rs.Fields("gj") = gj
    rs.Fields("yy") = yy
    rs.Fields("ty") = ty
    rs.Fields("bs") = bs
    rs.Fields("hd") = hd
    rs.Fields("qy") = qy
   
    rs.Fields("s") = s
    rs.Fields("n") = n
    rs.Fields("bj") = bj
    rs.Fields("nrod") = Trim(nrod)
    rs.Fields("drod") = Trim(drod)
    rs.Fields("lrod") = Trim(lrod)
    rs.Fields("TubeAnchor") = TubeAnchor
      
    rs.Update
    Set rs = Nothing
    con.Close
    Exit Sub
err1:
      MsgBox Err.Description
End Sub
Sub Save_WellStructure(jh As String, jg As String, xs As String, jxj As String, fwj As String)
      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
        rs.AddNew
      End If
      rs.Fields("jh") = Trim(jh)
      rs.Fields("jg") = Trim(jg)
      rs.Fields("xs") = Trim(xs)
      rs.Fields("jxj") = Trim(jxj)
      rs.Fields("fwj") = Trim(fwj)
      rs.Update
      Set rs = Nothing
      con.Close
      Exit Sub
err1:
      MsgBox Err.Description
End Sub
Sub Save_CardFig(jh As String, rq As Date, s As Single, n As Single, pr As String, prl 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 Card_Fig where jh='" & jh & "'"
      con.Open strCon
      rs.Open strSql, con, adOpenDynamic, adLockOptimistic
      filterstr = "rq=#" & rq & "#"
      rs.Filter = filterstr
      If rs.BOF Then
        rs.AddNew
      End If
      rs.Fields("jh") = Trim(jh)
      rs.Fields("rq") = rq
      rs.Fields("s") = s
      rs.Fields("n") = n
      rs.Fields("pr") = Trim(pr)
      rs.Fields("prl") = Trim(prl)
      rs.Update
      Set rs = Nothing
      con.Close
      Exit Sub
err1:
      MsgBox Err.Description
End Sub

Sub Read_ListDateTime(obj As Object, jh As String)
    
    Dim i As Integer
    Dim con As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim zhouCount As Double
    Dim date1 As String, date2 As String
    Dim strCon As String, strSql As String
    Dim arrTmp() As String
    On Error GoTo err1:
    
    If Len(jh) = 0 Then Exit Sub
    Screen.MousePointer = 11
    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 & "'Order by rq"
    con.Open strCon
    rs.Open strSql, con, adOpenDynamic, adLockOptimistic
    
    zhouCount = 1
    Do Until rs.EOF
        date1 = CStr(rs.Fields("rq"))
        arrTmp = Split(date1, " ")
        zhouD_T_S_N_Pr_Prl(zhouCount).MyDate = arrTmp(0)
        If UBound(arrTmp) = 0 Then
            zhouD_T_S_N_Pr_Prl(zhouCount).MyTime = "未知时间"
        ElseIf UBound(arrTmp) = 1 Then
            zhouD_T_S_N_Pr_Prl(zhouCount).MyTime = arrTmp(1)
        End If
        zhouCount = zhouCount + 1
        rs.MoveNext
    Loop
    rs.Close
    con.Close
    obj.Clear
    
    zhouD_T_S_N_Pr_Prl(zhouCount).MyDate = "zhoudonghong"
    zhouCount = 1
    
    date1 = zhouD_T_S_N_Pr_Prl(zhouCount).MyDate
    obj.AddItem date1
    Do Until zhouD_T_S_N_Pr_Prl(zhouCount).MyDate = "zhoudonghong"
       date2 = zhouD_T_S_N_Pr_Prl(zhouCount).MyDate
       If Not (date1 = date2) Then
            date1 = date2
            obj.AddItem date1
       End If
       zhouCount = zhouCount + 1
    Loop
    
    Screen.MousePointer = 1
    Exit Sub
err1:
   MsgBox Err.Description
   Screen.MousePointer = 1
End Sub

Sub Read_ListTime(obj As Object, obj1 As Object)
    Dim zhouCount As Double
    Dim mytime1 As String, mytime2 As String
    
    zhouCount = 0
    obj.Clear
    
    Do Until zhouD_T_S_N_Pr_Prl(zhouCount).MyDate = "zhoudonghong"
       mytime2 = zhouD_T_S_N_Pr_Prl(zhouCount).MyTime
       If zhouD_T_S_N_Pr_Prl(zhouCount).MyDate = obj1.Text And (mytime1 <> mytime2) Then
            mytime1 = mytime2
            obj.AddItem mytime1
       End If
       zhouCount = zhouCount + 1
    Loop
End Sub
Sub Read_ListDate(obj As Object, jh As String)
     Dim con As New ADODB.Connection
     Dim rs As New ADODB.Recordset
     Dim strCon As String, strSql As String
     Dim date1 As String, date2 As String
     'On Error GoTo err1:
     If Len(jh) = 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 jh,rq from Well_Data where jh='" & jh & "'Order by rq"
     con.Open strCon
     rs.Open strSql, con, adOpenDynamic, adLockOptimistic
     date1 = rs.Fields("rq")
     obj.AddItem CDate(date1)
     Do Until rs.EOF
        date2 = rs.Fields("rq")
        If Not (date1 = date2) Then
             date1 = date2
             obj.AddItem CDate(date1)
        End If
        rs.MoveNext
     Loop
     Screen.MousePointer = 1
     rs.Close
     con.Close
     Exit Sub
err1:
   MsgBox Err.Description
   Screen.MousePointer = 1
End Sub
Rem 从DataIn.mdb数据库读取井号
Sub Read_ListWellNum(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
       'On Error GoTo err1:
       
       Screen.MousePointer = 11
       obj.Clear
       strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DataIn.mdb;Persist Security Info=False"
       strSql = "select jh from Card_Fig Order by jh"
       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("jh")
       obj.AddItem str1
       Do Until rs.EOF
            str2 = rs.Fields("jh")
            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


Function Read_WellData(jh As String, rq As Date, cyjlx As String, ByRef Lz As Single, ByRef ps As Single, ByRef pb As Single, _
                  ByRef g As Single, ByRef hs As Single, ByRef mu As Single, ByRef so As Single, ByRef TSurface As Single, _
                  ByRef dTPer100m As Single, ByRef gj As Single, ByRef TubeAnchor As String, ByRef yy As Single, ByRef ty As Single, _
                  ByRef bs As Single, ByRef hd As Single, ByRef qy As Single, ByRef s As Single, ByRef n As Single, ByRef bj As Single, _
                  ByRef nrod As Integer, drod As String, drodi As String, lrod 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
    'Dim rq As Date