Dim adoConnection As New ADODB.Connection
'一定要用 Microsoft.Jet.OLEDB.4.0,不要用 3.51,但 MDB 文件可以是 Access97
adoConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\db4.mdb;Persist Security Info=False"
'adoConnection.Execute "SELECT * INTO CopyOfAnimals FROM animals IN ''[dBASE IV;DATABASE=d:\dbfs\]"
'adoConnection.Execute "INSERT INTO CopyOfAnimals SELECT * FROM animals IN ''[dBASE IV;DATABASE=d:\dbfs\]"
'一定要用 Microsoft.Jet.OLEDB.4.0,不要用 3.51,但 MDB 文件可以是 Access97
'adoConnection.Execute "SELECT * INTO CopyOfAnimals FROM [dBASE III;DATABASE=d:\dbfs\].animals.dbf"
adoConnection.Execute "INSERT INTO CopyOfAnimals SELECT * FROM [dBASE III;DATABASE=d:\dbfs\].animals.dbf"
兄弟,自己看代码,我程序中的,没总是的,不过你要仔细修剪,好些东西你不一定有用的,另外,我已将该当窗体发送至你的邮箱,有助你的理解
HAVE FUN!!!
@_@
Function DataGet(strDBName As String, strPathName As String, Tablename As String, strScr As String) As Boolean
Dim recTable As DAO.Recordset
Dim recNewTable As DAO.Recordset
Dim recTem As DAO.Recordsets
Dim dbOld As DAO.Database
Dim dbNew As DAO.Database
Dim strNewTableName As String
Dim intx As Integer
Dim qureyTable As DAO.QueryDef
Dim strSql As String
Dim strCondition As String
Dim intRecNumber As Integer
Select Case Tablename
Case "A1.DBF":
strNewTableName = "A1"
Case "A2_1.DBF":
strNewTableName = "A2_1"
Case "A2_2.DBF":
strNewTableName = "A2_2"
Case "A1.DBF":
strNewTableName = "A1"
Case "A3.DBF":
strNewTableName = "A3"
Case "A4.DBF":
strNewTableName = "A4"
Case "A5.DBF":
strNewTableName = "A5"
Case "A6.DBF":
strNewTableName = "A6"
Case "A7.DBF":
strNewTableName = "A7"
Case "A8.DBF":
strNewTableName = "A8"
Case "A9.DBF":
strNewTableName = "A9"
Case "A10.DBF":
strNewTableName = "A10"
Case "A11.DBF":
strNewTableName = "A11"
Case "A12.DBF":
strNewTableName = "A12"
Case "A131.DBF":
strNewTableName = "A131"
Case "A132.DBF":
strNewTableName = "A132"
Case "B1.DBF":
strNewTableName = "B1"
Case "B2.DBF":
strNewTableName = "B2"
Case "B3.DBF":
strNewTableName = "B3"
Case "B4.DBF":
strNewTableName = "B4"
Case "B5.DBF":
strNewTableName = "B5"
Case "B6.DBF":
strNewTableName = "B6"
Case "B7.DBF":
strNewTableName = "B7"
Case "B8.DBF":
strNewTableName = "B8"
Case "B9.DBF":
strNewTableName = "B9"
Case "B10.DBF":
strNewTableName = "B10"
Case "B11.DBF":
strNewTableName = "B11"
Case "B12.DBF":
strNewTableName = "B12"
Case "B13.DBF":
strNewTableName = "13"
Case "B14.DBF":
strNewTableName = "B14"
Case "C1.DBF":
strNewTableName = "C1"
Case "C2.DBF":
strNewTableName = "C2"
Case "C3.DBF":
strNewTableName = "C3"
Case "C2.DBF":
strNewTableName = "C2"
Case "C4.DBF":
strNewTableName = "C4"
Case "C5.DBF":
strNewTableName = "C5"
Case "C6.DBF":
strNewTableName = "C6"
Case "C7.DBF":
strNewTableName = "C7"
Case "C8.DBF":
strNewTableName = "C8"
Case "C9.DBF":
strNewTableName = "C9"
Case "C10.DBF":
strNewTableName = "C10"
Case "M0MLA.DBF":
strNewTableName = "M0MLA"
Case "M1MLA.DBF":
strNewTableName = "M1MLA"
Case "M2MLA.DBF":
strNewTableName = "M2MLA"
Case "M3MLA.DBF":
strNewTableName = "M3MLA"
Case "M4MLA.DBF":
strNewTableName = "M4MLA"
Case "M5MLA.DBF":
strNewTableName = "M5MLA"
Case "MDMLA.DBF":
strNewTableName = "MDMLA"
Case "MNMLA.DBF":
strNewTableName = "MNMLA"
Case "MZMLA.DBF":
strNewTableName = "MZMLA"
Case Else:
strNewTableName = ""
End Select
If strNewTableName <> "" Then
On Error Resume Next
strScr = strScr & Chr(10) & Chr(13) & Tablename & "------------->" & strNewTableName
DataOutput.DatabaseName = strDBName
DataOutput.RecordSource = strNewTableName
DataOutput.Refresh
DataInput.DatabaseName = strPathName
DataInput.RecordSource = Tablename
DataInput.Refresh
Set recTable = DataInput.Database.OpenRecordset(Tablename)
Set recNewTable = DataOutput.Database.OpenRecordset(strNewTableName)
Set qureyTable = DataOutput.Database.CreateQueryDef("")
On Error Resume Next
recNewTable.MoveLast
recTable.MoveFirst
On Error GoTo errs
Do While Not recTable.EOF
If Not ExistRec(recTable, strDBName, strNewTableName) Then
recNewTable.AddNew
intRecNumber = intRecNumber + 1
For x = 0 To recTable.Fields.Count - 1
recNewTable.Fields(x).Value = recTable.Fields(x).Value
Next x
recNewTable.Update
End If
recTable.MoveNext
Loop
strScr = strScr & Chr(10) & Chr(13) & " 转换记录" & intRecNumber & "条"
Debug.Print Tablename & "------------->" & strNewTableName
Debug.Print " 转换并导入记录" & intRecNumber & "条"
DataInput.Database.Close
DataOutput.Database.Close
Else
strScr = strScr & Chr(10) & Chr(13) & "不能转换文件" & Tablename
End If
Exit Function
errs:
strScr = strScr & Chr(10) & Chr(13) & "转换出现错误:" & Err.Description
End Function
Function ExistRec(rec As DAO.Recordset, strDatabaseName As String, strTableName As String) As Boolean
Dim recTem As DAO.Recordset
Dim recNew As DAO.Recordset
Dim bolSame As Boolean
Dim bolNoSame As Boolean
Dim intx As Integer
bolSame = False
DataQuery.DatabaseName = strDatabaseName
DataQuery.RecordSource = strTableName
DataQuery.Refresh
Set recNew = DataQuery.Database.OpenRecordset(strTableName)
Do While Not recNew.EOF
bolNoSame = False
For intx = 0 To recNew.Fields.Count - 1
If recNew.Fields(intx).Value <> rec.Fields(intx).Value Then
bolNoSame = True
End If
Next intx
If bolNoSame = False Then
ExistRec = True
Exit Function
End If
recNew.MoveNext
Loop
DataQuery.Database.Close
ExistRec = False
End Function
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdInput1_Click()
Dim strFilename As String
Dim intx As Integer
Dim intFlag As Integer
diaFileName.ShowOpen
strFilename = diaFileName.FileName
If strFilename <> "" Then
txtInputInfo.Text = strFilename
intx = Len(strFilename)
Do While intx > 1
If Mid(strFilename, intx, 1) = "\" Then
intFlag = intx
intx = 0
Else
intx = intx - 1
End If
Loop
If intFlag > 0 Then
lblFileName.Caption = Mid(strFilename, intFlag + 1, Len(strFilename) - intFlag)
lblPath.Caption = Mid(strFilename, 1, intFlag - 1)
End If
End If
End Sub
Private Sub cmdInput2_Click()
Dim strFilename As String
Dim intx As Integer
Dim intFlag As Integer
diaFileName.ShowOpen
strFilename = diaFileName.FileName
If strFilename <> "" Then
txtInputInfo.Text = strFilename
intx = Len(strFilename)
Do While intx > 1
If Mid(strFilename, intx, 1) = "\" Then
intFlag = intx
intx = 0
Else
intx = intx - 1
End If
Loop
If intFlag > 0 Then
lblFileName.Caption = Mid(strFilename, intFlag + 1, Len(strFilename) - intFlag)
lblPath.Caption = Mid(strFilename, 1, intFlag - 1)
End If
End If
End Sub
Private Sub cmdOK_Click()
If optPath.Value = True Then
SetInfo lblPath.Caption
Else
SetInfo lblPath.Caption, lblFileName.Caption
End If
End Sub
Function SetInfo(PathName As String, Optional FileName As String) As Boolean
Dim strTemFileName As String
Dim strResultDec As String
If FileName <> "" Then
DataGet strDBFileName, PathName, FileName, strResultDec
Else
strTemFileName = Dir("*.dbf")
Do While strTemFileName <> ""
DataGet strDBFileName, lblPath.Caption, strTemFileName, strResultDec
strTemFileName = Dir
Loop
End If
' MsgBox strResultDec
If chkReport.Value > 0 Then
frmChangeReport.richShow.Text = strResultDec
frmChangeReport.Show
Else
MsgBox "导入成功"
End If
Unload Me
End Function
'
'Private Sub Command1_Click()
'CreateDatabaseX "c:\tem\new.mdb", "ads"
' DataGet strDBFileName, "c:\tem", "SY-A3.DBF"
'SQLQurey2 "create database", "c:\tem\cs.mdb"
'End Sub
Private Sub Form_Load()
cmdInput1.Enabled = False
chkReport.Value = 1
End Sub
Private Sub optFile_Click()
If optFile.Value = True Then
cmdInput1.Enabled = True
cmdInput2.Enabled = False
lblFileName.BackColor = &H80000009
lblPath.BackColor = &H8000000F
Else
cmdInput1.Enabled = False
cmdInput2.Enabled = True
lblFileName.BackColor = &H8000000F
lblPath.BackColor = &H80000009
End If
End Sub
Private Sub optPath_Click()
If optPath.Value = False Then
cmdInput1.Enabled = True
cmdInput2.Enabled = False
lblFileName.BackColor = &H80000009
lblPath.BackColor = &H8000000F
Else
cmdInput1.Enabled = False
cmdInput2.Enabled = True
lblFileName.BackColor = &H8000000F
lblPath.BackColor = &H80000009
End If
End Sub
Private Sub txtInputInfo_Change()
If txtInputInfo.Text <> "" Then cmdOK.Enabled = True Else cmdOK.Enabled = False
End Sub