data1.bas

使用的是最小误差法的插补程序

Attribute VB_Name = "modData"
Option Explicit

'Public jump(1 To 4) As Single  '分别为上端跳、上径跳、下径跳、下端跳
'' bianhao As String       '编号
'Public grade As String         '产品等级
'定义查询所定义的条件
Public Srequest(0 To 4) As String
Public gradeNum(0 To 4) As Integer '定义每个等级产品的数量
Public sqbianhao As String '定义最终生成的编号
Public tableNames As String '定义按月命名的表的名字
'定义指向指向表的对象和记录
Public adoProduct As Recordset
Public dbProduct As Connection
Public sq As String '
'连接表product
'判断表是否存在的标志
Public flagExist As Integer
Public flagBianhao As Integer

Public dbOk1 As Connection
Public adoNew As Recordset
Public Sub Product(ByVal tableNames As String)
Set dbProduct = New Connection
dbProduct.Open "provider=microsoft.jet.oledb.3.51;data source=" & App.Path & "\data.mdb;"
Set adoProduct = New Recordset
adoProduct.Open "select * from [" & tableNames & "]", dbProduct, adOpenStatic, adLockOptimistic
End Sub
'追加记录
Public Sub superAdd(ByVal tableNames As String)
Dim sq As String

sq = "insert into [" & tableNames & "](编号,上端跳,上径跳,下端跳,下径跳,结论)"
sq = sq + "values('" & bianhao & "','" & jump(1) & "','" & jump(2) & "','" & jump(3) & "','" & jump(4) & "','" & Grade & "')"
Call Product(tableNames)
dbProduct.Execute sq
End Sub
Public Function CountNumber(ByVal sqbianhao As String) '查询结果

Dim len1 As Integer: len1 = Len(sqbianhao)
Dim lena As Integer: lena = len1

If len1 <= 4 Then
   len1 = len1
  Else
     len1 = 4
End If
Dim dbpath1 As String
Dim arr(1000) As Integer
Dim i As Integer: i = 0
Dim stringTemp As String
dbpath1 = App.Path & "\data.mdb"
Dim x As Integer, y As Integer, k As Integer, j As Integer, z As Integer
Dim rsTitles As String   '定义数据库中表的名字
Dim adoTemp As Recordset '定义指向表的记录和对象
Dim dbTemp As Connection

Dim db1 As Database        '打开数据库
Set db1 = OpenDatabase(dbpath1)

 For x = 0 To db1.TableDefs.Count - 1
   stringTemp = db1.TableDefs(x).Name
    If Left(stringTemp, len1) = Left(sqbianhao, len1) Then
             arr(i) = x
             i = i + 1
    End If
 Next x
 If i = 0 Then
   MsgBox ("数据库中无此记录")
   flagExist = 0
   Exit Function
   Else
   flagExist = 1
End If
     
    y = i - 1
    For i = 0 To 4
  gradeNum(i) = 0
  Next i
    
    '读取表中的记录
For k = 0 To y
   z = db1.TableDefs(arr(k)).RecordCount   '所读取的表中的记录
   rsTitles = db1.TableDefs(arr(k)).Name
   
   '和表建立关系
   Set dbTemp = New Connection
   dbTemp.Open "provider=microsoft.jet.oledb.3.51;data source= '" & dbpath1 & "'"
   Set adoTemp = New Recordset
   adoTemp.Open "select * from [" & rsTitles & " ]", dbTemp, adOpenStatic, adLockOptimistic
   
   If Not (adoTemp.BOF And adoTemp.EOF) Then
       adoTemp.MoveFirst
       For j = 1 To z
       Select Case adoTemp![结论]
              Case "合格品"
                    If Left(adoTemp![编号], lena) = sqbianhao Then
                    gradeNum(0) = gradeNum(0) + 1
                    End If
              Case "一级处理品"
                     If Left(adoTemp![编号], lena) = sqbianhao Then
                    gradeNum(1) = gradeNum(1) + 1
                    End If
              Case "二级处理品"
                   If Left(adoTemp![编号], lena) = sqbianhao Then
                   gradeNum(2) = gradeNum(2) + 1
                   End If
              Case "返修品"
                   If Left(adoTemp![编号], lena) = sqbianhao Then
                   gradeNum(3) = gradeNum(3) + 1
                    End If
              Case "废品"
               If Left(adoTemp![编号], lena) = sqbianhao Then
                  gradeNum(4) = gradeNum(4) + 1
                 End If
      End Select
       adoTemp.MoveNext
       Next j
    End If
Next k
End Function
Public Function PanExist(ByVal tableNames As String)
'判断数据库中是否已经存在此表
Dim dbpath  As String: dbpath = App.Path & "\data.mdb"
Dim i As Integer: i = 0
Dim stringTemp As String
Dim db As Database
Set db = OpenDatabase(dbpath)
   For i = 0 To db.TableDefs.Count - 1
      stringTemp = db.TableDefs(i).Name
     If stringTemp = tableNames Then
         flagExist = 1
         Exit Function
     Else
         flagExist = 0
     End If
   Next i
End Function


Public Function tableBuild(ByVal tableNames As String)
'按月份建立的新表
Dim dbNew As Database
Dim tdfNew As TableDef

Set dbNew = OpenDatabase(App.Path & "\data.mdb")
Set tdfNew = dbNew.CreateTableDef(tableNames)
    
    With tdfNew
        .Fields.Append .CreateField("编号", dbText, 12)
        .Fields.Append .CreateField("上端跳", dbSingle, 4)
        .Fields.Append .CreateField("上径跳", dbSingle, 4)
        .Fields.Append .CreateField("下径跳", dbSingle, 4)
        .Fields.Append .CreateField("下端跳", dbSingle, 4)
        .Fields.Append .CreateField("结论", dbText, 12)
    End With

    dbNew.TableDefs.Append tdfNew
End Function
Public Function panBianhao(ByVal sqbianhao As String)
Set dbOk1 = New Connection
Dim sqbianhao1 As String, sqbianhao2 As String
sqbianhao2 = Left(sqbianhao, 12)
sqbianhao1 = Left(sqbianhao, 4)
Dim monthTemp As String
 Call PanExist(Left(sqbianhao, 4))
 If flagExist = 1 Then
dbOk1.Open "provider=microsoft.jet.oledb.3.51;data source=" & App.Path & "\data.mdb;"
Set adoNew = New Recordset
Dim local_sql As String
local_sql = "select * from [" & sqbianhao1 & "] where left(编号,12)='" & sqbianhao2 & "'"
adoNew.Open local_sql, dbOk1, adOpenStatic, adLockOptimistic
If Not (adoNew.BOF And adoNew.EOF) Then
  flagBianhao = 1
Else
 flagBianhao = 0
 End If
 ElseIf flagExist = 0 Then
   MsgBox ("数据库中无此记录")
   flagBianhao = 0
   Exit Function
End If
End Function