从网上下载的源代码，想增加功能却发现无从下手，请高手指点！
从网上下载VB编写的“VB编写的数据库工具删除ACCESS重复记录”工具，这工具只要是重复的数据就删除。我想在这基础上增加一个百分比的输入设置功能，却发现无从下手。请高手帮忙！例如：字段Z中有 数据A：1,2,3,4,5,6,7 ， 数据B：1,2,3,4,5 。
增加一个百分比的输入设置。当输入：90%时，字段Z中A与B比较达不到，不操作。
当输入：60%时，字段Z中由于B的数据含在A里，所以删掉B，保留A。
附上下载的源代码。有兴趣的也可以在 http://www. 自己下载。
'---------------------------------------------------------------------------------------
' 模块名称 : frmDeDup
' 日期时间 : 11/07/06 11:39
' 作者 : bushells
' 功能说明 : 删除Access数据库中重复的记录
' 友情下载 : http://www.
'---------------------------------------------------------------------------------------
Option Explicit
Private adorsOriginalTable As ADODB.Recordset
Private oConnection As ADODB.Connection
Private boolDatabaseChosen As Boolean
Private iProgress As Integer
Private iRecRead As Integer
Private pintFieldCount As Integer
Private iCodeSame As Integer
Private sSqlConnection As String
Private pstrTableName As String
Private filename As String
Private sPassword As String
Private Type DupData
FieldToCheck As Variant
End Type
Private arrHoldDupData() As DupData
Private arrDupData() As DupData
Private arrFieldPositions() As Integer
'---------------------------------------------------------------------------------------
' 过程名称 : cboTables_Click
' 日期时间 : 11/07/02 11:38
' 作者 : bushells
' 功能说明 : 这个过程是从所选表把该表的字段加载到列表框中
'
'---------------------------------------------------------------------------------------
'
Private Sub cboTables_Click()
Dim colFields As Collection
Dim icount As Integer
lstFields.Clear
Set colFields = New Collection
Set colFields = FieldNames(filename, cboTables.List(cboTables.ListIndex))
For icount = 1 To colFields.Count
lstFields.AddItem colFields(icount)
Next icount
Set colFields = Nothing
chkSelect.Value = False
End Sub
'---------------------------------------------------------------------------------------
' 过程名称 : chkSelect_Click
' 日期时间 : 11/07/02 11:40
' 作者 : bushells
' 功能说明 : 全选
'---------------------------------------------------------------------------------------
'
Private Sub chkSelect_Click()
Dim icount As Integer
If lstFields.ListCount = 0 Then
chkSelect.Value = False
Exit Sub
End If
If chkSelect.Value Then
For icount = 0 To lstFields.ListCount - 1
lstFields.Selected(icount) = True
Next icount
Else
For icount = 0 To lstFields.ListCount - 1
lstFields.Selected(icount) = False
Next icount
End If
lstFields.Refresh
End Sub
'---------------------------------------------------------------------------------------
' 过程名称 : cmdDeDup_Click
' 日期时间 : 11/07/02 11:41
' 作者 : bushells
' 功能说明 : 执行删除重复数据
'
'---------------------------------------------------------------------------------------
'
Private Sub cmdDeDup_Click()
Dim dProgress As Double
Dim icount As Integer
Dim boolFieldChosen As Boolean
'检测是否选择数据库
If LenB(lblDatabase.Caption) = 0 Then
MsgBox "未选择数据库", vbCritical, "提示"
Exit Sub
End If
boolFieldChosen = False
For icount = 0 To lstFields.ListCount - 1
If lstFields.Selected(icount) = True Then
boolFieldChosen = True
Exit For
End If
Next icount
If Not boolFieldChosen Then
MsgBox "未选择字段", vbExclamation, "提示"
Exit Sub
End If
FormatConnection
GetConnection
dProgress = GetRecordCount
If dProgress = 0 Then
MsgBox "数据库没有记录", vbCritical, "提示"
Exit Sub
End If
MousePointer = vbHourglass
'进度条
pbRecords.Max = dProgress
pbRecords.Min = 0
pbRecords.Value = 0
CreateTables
adorsOriginalTable.MoveFirst
LoadArray
LoadNextArray
pbRecords.Value = iProgress
adorsOriginalTable.MoveNext
Do Until adorsOriginalTable.EOF
DeDupRecords
pbRecords.Value = iProgress
adorsOriginalTable.MoveNext
lbldel.Caption = CStr(iCodeSame)
DoEvents
Loop
MousePointer = vbDefault
lbldel.Caption = CStr(iCodeSame)
Set oConnection = Nothing
iProgress = 0
iRecRead = 0
iCodeSame = 0
End Sub
'---------------------------------------------------------------------------------------
' 过程名称 : cmdExit_Click
' 日期时间 : 11/07/02 12:18
' 作者 : bushells
' 功能说明 : 退出关闭连接
'---------------------------------------------------------------------------------------
'
Private Sub cmdExit_Click()
If boolDatabaseChosen Then
Set oConnection = Nothing
End If
End
End Sub
Private Sub dlbDir_Change()
flbFile.Path = dlbDir.Path
End Sub
Private Sub dlbDrive_Change()
On Error GoTo errortrap
dlbDir.Path = Left$(dlbDrive.Drive, 1) & ":\"
errortrap:
If Err.Number = 68 Then
MsgBox "目录无效", vbExclamation, "提示"
End If
End Sub
Private Sub flbFile_Click()
Dim colTables As Collection
Dim icount As Integer
MousePointer = vbHourglass
cboTables.Clear
Set colTables = New Collection
filename = flbFile.Path
If Right$(filename, 1) <> "\" Then
filename = filename & "\"
End If
filename = filename & flbFile.filename
lblDatabase.Caption = filename
Set colTables = NonSystemTables(filename)
If colTables Is Nothing Then
MsgBox "无法访问该表", vbCritical, "提示"
Set colTables = Nothing
MousePointer = vbDefault
Exit Sub
End If
For icount = 1 To colTables.Count
cboTables.AddItem colTables(icount)
Next icount
Set colTables = Nothing
cboTables.ListIndex = 0
MousePointer = vbDefault
End Sub
Private Sub Form_Load()
flbFile.Pattern = "*.mdb"
End Sub
Private Sub mnuChooseDatabase_Click()
dlbDrive.SetFocus
End Sub
Private Sub mnuDatabaseDedup_Click()
cmdDeDup_Click
End Sub
Private Sub mnuDatabaseFields_Click()
lstFields.SetFocus
End Sub
Private Sub mnuDatabaseSelectAll_Click()
If chkSelect.Value Then
chkSelect.Value = 0
Else
chkSelect.Value = 1
End If
End Sub
Private Sub mnuDatabaseTables_Click()
cboTables.SetFocus
End Sub
Private Sub mnuFileExit_Click()
cmdExit_Click
End Sub
'---------------------------------------------------------------------------------------
' 过程名称 : DeDupRecords
' 日期时间 : 11/07/02 12:29
' 作者 : bushells
' 功能说明 : 删除重复记录过程
'
'---------------------------------------------------------------------------------------
'
Private Sub DeDupRecords()
If arrHoldDupData(0).FieldToCheck <> adorsOriginalTable(arrFieldPositions(0)) Then
LoadArray
LoadNextArray
Else
LoadArray
If Not CheckDiff Then
'重复记录
iCodeSame = iCodeSame + 1
UpdateDeletedTable
adorsOriginalTable.Delete
End If
End If
End Sub
'---------------------------------------------------------------------------------------
' 过程名称 : CheckDiff
' 日期时间 : 11/07/02 12:28
' 作者 : bushells
' 功能说明 : 比较
'---------------------------------------------------------------------------------------
'
Private Function CheckDiff() As Boolean
Dim icount As Integer
Dim iLoop As Integer
icount = UBound(arrDupData())
For iLoop = 0 To icount
If arrHoldDupData(iLoop).FieldToCheck <> arrDupData(iLoop).FieldToCheck Then
CheckDiff = True
Exit Function
End If
Next iLoop
CheckDiff = False
End Function
'---------------------------------------------------------------------------------------
' 过程名称 : GetConnection
' 日期时间 : 11/07/02 11:47
' 作者 : bushells
' 功能说明 : 打开数据库
'---------------------------------------------------------------------------------------
'
Private Sub GetConnection()
Dim strConnectionInfo As String
boolDatabaseChosen = False
Set oConnection = New ADODB.Connection
With oConnection
.CursorLocation = adUseServer
.Mode = adModeReadWrite
End With
strConnectionInfo = "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" + filename + ";JET OLEDB:Database Password=" + sPassword
oConnection.Open strConnectionInfo
Set adorsOriginalTable = New ADODB.Recordset
adorsOriginalTable.Open sSqlConnection, oConnection, adOpenStatic, adLockOptimistic
boolDatabaseChosen = True
End Sub
Private Function GetRecordCount() As Double
Dim dRecordCount As Double
dRecordCount = adorsOriginalTable.RecordCount
GetRecordCount = dRecordCount
End Function
'---------------------------------------------------------------------------------------
' 过程名称 : LoadArray
' 日期时间 : 11/07/02 12:19
' 作者 : bushells
' 功能说明 : 加载数组
'---------------------------------------------------------------------------------------
'
Private Sub LoadArray()
Dim icount As Integer
Dim iElements As Integer
iProgress = iProgress + 1
iElements = pintFieldCount - 1
ReDim arrHoldDupData(iElements)
For icount = 0 To iElements
If IsNull(adorsOriginalTable(arrFieldPositions(icount))) Then
arrHoldDupData(icount).FieldToCheck = vbNullString
Else
arrHoldDupData(icount).FieldToCheck = adorsOriginalTable(arrFieldPositions(icount))
End If
Next icount
End Sub
'---------------------------------------------------------------------------------------
' 过程名称 : LoadNextArray
' 日期时间 : 11/07/02 12:26
' 作者 : bushells
' 功能说明 : 加载下一个数组
'
'---------------------------------------------------------------------------------------
'
Private Sub LoadNextArray()
Dim icount As Integer
Dim iElements As Integer
iElements = pintFieldCount - 1
ReDim arrDupData(iElements)
For icount = 0 To iElements
If IsNull(adorsOriginalTable(arrFieldPositions(icount))) Then
arrDupData(icount).FieldToCheck = vbNullString
Else
arrDupData(icount).FieldToCheck = adorsOriginalTable(arrFieldPositions(icount))
End If
Next icount
End Sub
'---------------------------------------------------------------------------------------
' 过程名称 : UpdateDeletedTable
' 日期时间 : 11/07/02 12:27
' 作者 : bushells
' 功能说明 : 插入到要删除表中
'---------------------------------------------------------------------------------------
'
Private Sub UpdateDeletedTable()
Dim adoUpdateStat As New ADODB.Recordset
Dim I As Integer
Dim sSqlUpdate As String
sSqlUpdate = "SELECT * FROM [Deleted" + pstrTableName + "]"
adoUpdateStat.Open sSqlUpdate, oConnection, adOpenStatic, adLockOptimistic
adoUpdateStat.AddNew
With adorsOriginalTable
For I = 0 To .Fields.Count - 1
adoUpdateStat.Fields(I).Value = .Fields(I).Value
Next
End With
adoUpdateStat.Update
Set adoUpdateStat = Nothing
End Sub
'---------------------------------------------------------------------------------------
' 过程名称 : CreateTables
' 日期时间 : 11/07/02 11:30
' 作者 : bushells
' 功能说明 : 创建需要删除的新表
'
'---------------------------------------------------------------------------------------
'
Private Sub CreateTables()
Dim adoDropTables As New ADODB.Recordset
Dim adoCreateTables As New ADODB.Recordset
Dim ssqlCreation As String
On Error Resume Next
ssqlCreation = "DROP TABLE [Deleted" + pstrTableName + "]"
adoDropTables.Open ssqlCreation, oConnection, adOpenStatic, adLockOptimistic
On Error GoTo 0
ssqlCreation = "SELECT [" + pstrTableName + "].* INTO [Deleted" + pstrTableName + "] FROM [" + pstrTableName + "];"
adoCreateTables.Open ssqlCreation, oConnection, adOpenStatic, adLockOptimistic
ssqlCreation = "DELETE * FROM [Deleted" + pstrTableName + "]"
adoDropTables.Open ssqlCreation, oConnection, adOpenStatic, adLockOptimistic
Set adoDropTables = Nothing
Set adoCreateTables = Nothing
End Sub
'---------------------------------------------------------------------------------------
' 过程名称 : NonSystemTables
' 日期时间 : 11/07/02 11:45
' 作者 : bushells
' 功能说明 : 获取表名称
'---------------------------------------------------------------------------------------
'
Public Function NonSystemTables(dbPath As String) As Collection
Dim td As DAO.TableDef
Dim db As DAO.Database
Dim colTables As Collection
Dim sFormatPassword As String
sPassword = Trim$(txtPassword.Text)
If sPassword <> "" Then
sFormatPassword = "MS ACCESS;PWD=" + sPassword
Set db = Workspaces(0).OpenDatabase(dbPath, False, False, sFormatPassword)
Else
Set db = Workspaces(0).OpenDatabase(dbPath)
End If
Set colTables = New Collection
For Each td In db.TableDefs
If td.Attributes >= 0 And td.Attributes <> dbHiddenObject _
And td.Attributes <> 2 Then
colTables.Add td.Name
End If
Next
db.Close
Set NonSystemTables = colTables
End Function
'---------------------------------------------------------------------------------------
' 过程名称 : FieldNames
' 日期时间 : 11/07/02 11:44
' 作者 : bushells
' 功能说明 : 获取字段名称
'---------------------------------------------------------------------------------------
'
Private Function FieldNames(dbPath As String, TableName As String) As Collection
Dim oCol As Collection
Dim db As DAO.Database
Dim oTD As DAO.TableDef
Dim lCount As Long, lCtr As Long
Dim sFormatPassword As String
sPassword = Trim$(txtPassword.Text)
If sPassword <> "" Then
sFormatPassword = "MS ACCESS;PWD=" + sPassword
Set db = Workspaces(0).OpenDatabase(dbPath, False, False, sFormatPassword)
Else
Set db = Workspaces(0).OpenDatabase(dbPath)
End If
Set oTD = db.TableDefs(TableName)
Set oCol = New Collection
With oTD
lCount = .Fields.Count
For lCtr = 0 To lCount - 1
oCol.Add .Fields(lCtr).Name
Next
End With
db.Close
Set FieldNames = oCol
End Function
'---------------------------------------------------------------------------------------
' 过程名称 : FormatConnection
' 日期时间 : 11/07/02 11:42
' 作者 : bushells
' 功能说明 : SQL 字符串
'---------------------------------------------------------------------------------------
'
Private Sub FormatConnection()
pstrTableName = cboTables.List(cboTables.ListIndex)
sSqlConnection = vbNullString
sSqlConnection = sSqlConnection + "SELECT *"
sSqlConnection = sSqlConnection + " FROM ["
sSqlConnection = sSqlConnection + pstrTableName
sSqlConnection = sSqlConnection + "] ORDER BY "
GetSQLFieldNames
End Sub
'---------------------------------------------------------------------------------------
' 过程名称 : GetSQLFieldNames
' 日期时间 : 11/07/02 11:33
' 作者 : bushells
' 功能说明 : 获取SQL字段名称
'
'---------------------------------------------------------------------------------------
'
Private Sub GetSQLFieldNames()
Dim icount As Integer
Dim iFieldCount As Integer
Dim boolFirst As Boolean
boolFirst = True
For icount = 0 To lstFields.ListCount - 1
If lstFields.Selected(icount) = True Then
ReDim Preserve arrFieldPositions(iFieldCount)
arrFieldPositions(iFieldCount) = icount
iFieldCount = iFieldCount + 1
If Not boolFirst Then
sSqlConnection = sSqlConnection + ", "
boolFirst = False
End If
sSqlConnection = sSqlConnection + "[" + pstrTableName + "].[" + lstFields.List(icount) + "]"
boolFirst = False
End If
Next icount
pintFieldCount = iFieldCount
End Sub
