做基本操作评分所用的几个函数

wang01

想做一个ACCESS评分系统，总有些不尽人意,有更好的方法请指教

Function ISrecord(Mdb1, Mdb2, Table1) '不同数据库中表的记录比较
  Dim Acc As Access.Application
  Dim Sacc As Access.Application
  Dim Df, Sdf, i
On Error Resume Next
Set Acc = CreateObject("Access.Application")
Set Sacc = CreateObject("Access.Application")
Acc.OpenCurrentDatabase (Mdb1)
Sacc.OpenCurrentDatabase (Mdb2)
Set Df = Acc.CurrentDb.TableDefs(Table1).OpenRecordset
Set Sdf = Sacc.CurrentDb.TableDefs(Table1).OpenRecordset
  While Not Sdf.EOF
   For i = 0 To Sdf.Fields.Count - 1
    If Df(i) <> Sdf(i) Then GoTo AA
  Next
    Debug.Print
   Df.MoveNext
   Sdf.MoveNext
Wend
Df.Close
Sdf.Close
  ISrecord = True
GoTo End1
AA:
   ISrecord = False
End1:
Acc.CloseCurrentDatabase
Sacc.CloseCurrentDatabase
Set Acc = Nothing
Set Sacc = Nothing
End Function
Function Isp(tdf, kk, i) '字段属性出错处理
  On Error GoTo AA
  If IsNumeric(tdf.Fields(i).Properties(kk).Value) Then
    If tdf.Fields(i).Properties(kk).Value > 50 Then GoTo AA
  End If
Isp = True
Exit Function
AA:
  Isp = False
End Function
Function ISfield(Mdb1, Mdb2, Table1) '比较字段属性、类型、宽度、小数位、格式
   Dim Acc As Access.Application
  Dim Sacc As Access.Application
  Dim Df As TableDef, Sdf, i
  Dim kk
  Dim p
    kk = Array("Type", "Size", "DecimalPlaces", "Format")
  On Error Resume Next
Set Acc = CreateObject("Access.Application")
Set Sacc = CreateObject("Access.Application")
Acc.OpenCurrentDatabase (Mdb1)
Sacc.OpenCurrentDatabase (Mdb2)
Set ob1 = Acc.CurrentDb
Set ob2 = Sacc.CurrentDb
Set Df = ob1.TableDefs(Table1)
Set Sdf = ob2.TableDefs(Table1)
For i = 0 To Df.Fields.Count - 1
           For p = 0 To 3
             If Isp(Df, kk(p), i) = True Then
               If Isp(Sdf, kk(p), i) = False Then GoTo AA
               If Df.Fields(i).Properties(kk(p)).Value <> Sdf.Fields(i).Properties(kk(p)).Value Then
                GoTo AA
               End If
            End If
            
                'Debug.Print "表名:" & tdf.Name & _
                '           "; 字段名:" & fld.Name & _
                '          "; 属性名:" & fld.Properties(kk(p)).Name & _
                '         "; 属性值:" & fld.Properties(kk(p)).Value
            Next
        Next
ISfield = True
GoTo End1
AA:
   ISfield = False
End1:
Acc.CloseCurrentDatabase
Sacc.CloseCurrentDatabase
Set Acc = Nothing
Set Sacc = Nothing
End Function

Function IScheck(Mdb1, Mdb2, Table1, Field1) '比较规则、默认值、出错信息
   Dim Acc As Access.Application
  Dim Sacc As Access.Application
  Dim Df As TableDef, Sdf, i
  Dim kk
  Dim p
  i = Field1
  kk = Array("ValidationRule", "ValidationText", "DefauleValue")
On Error Resume Next
Set Acc = CreateObject("Access.Application")
Set Sacc = CreateObject("Access.Application")
Acc.OpenCurrentDatabase (Mdb1)
Sacc.OpenCurrentDatabase (Mdb2)
Set ob1 = Acc.CurrentDb
Set ob2 = Sacc.CurrentDb
Set Df = ob1.TableDefs(Table1)
Set Sdf = ob2.TableDefs(Table1)
  For p = 0 To 2
            If Isp(Df, kk(p), i) = True Then
               If Isp(Sdf, kk(p), i) = False Then GoTo AA
               If Df.Fields(i).Properties(kk(p)).Value <> Sdf.Fields(i).Properties(kk(p)).Value Then
                GoTo AA
              End If
            End If
                           
  Next
     
IScheck = True
GoTo End1
AA:
   IScheck = False
End1:
Acc.CloseCurrentDatabase
Sacc.CloseCurrentDatabase
Set Acc = Nothing
Set Sacc = Nothing
End Function

<FONT color=#800080>Function ISprimary(Mdb1, Table1, Field1, index1) 'index1 索引类型
  Dim td     As DAO.TableDef
  Dim db     As D

huangqinyong

有实例的话更好。

lqiyik

不太懂