在存储过程实搞不明,只好用自己知道的方法来处理了 就好象以前听别人说的在用win的年代里还用DOS的感觉,但我只会这个! 在本系统中测试,最多的一张表是9W行,34列,其余有多有少,20张表要1500S 我也知道太长了,也要送出来让大家评点评点,全部代码如下: 前提是先要手动做一次要备份的数据库,并设好字段,ID什么的,之后才能用本程式(同时没有创立表的功能,与第一次相比,源数据库新建的表不备份,要的话,要重新手动一次) Sub 测试数据库复制() Dim Cat As New ADOX.Catalog Dim i%, j&, k%, aaa! Dim TabName$ Dim Pths$, Pths3$ Dim Rs2 As New ADODB.Recordset aaa = Timer '需要引用:微软 ADO Ext.2.6 for dll 之后 Dim cat As New ADOX.Catalog这个定义才不会提示错误 On Error GoTo 9 Pths = " Provider=SQLOLEDB.1;server=生产五号机;uid=sa;pwd=;database=原数" Pths3 = " Provider=SQLOLEDB.1;server=生产三号机;uid=sa;pwd=;database=原数" '取出两个数据库的表名 Cat.ActiveConnection = Pths '建立连接 ReDim arr5(1 To Cat.Tables.Count) For i = 1 To Cat.Tables.Count: arr5(i) = Cat.Tables(i - 1).Name: Next Set Cat.ActiveConnection = Nothing Cat.ActiveConnection = Pths3 ReDim arr3(1 To Cat.Tables.Count) For i = 1 To Cat.Tables.Count: arr3(i) = Cat.Tables(i - 1).Name: Next Set Cat.ActiveConnection = Nothing '取出两表中相同的,但不是系统表的表名 For i = 1 To UBound(arr3) TabName = arr3(i) If InStr(TabName, "sys") + InStr(TabName, "dtp") > 0 Then '除去系统表--变为空 TabName = "" Else Dim A A = Application.Match(TabName, arr5, 0) If IsError(A) Then TabName = "" '找不到 '将arr3与arr5比较 存在的留下,不在的也变为空 End If arr3(i) = TabName Next If CNN.State = 0 Then CNN.Open Pths '源数据库 If CNN2.State = 0 Then CNN2.Open Pths3 '要备份的数据库 On Error GoTo 99 CNN2.BeginTrans For i = 1 To UBound(arr3) '两个数据库之间存在相同的用户表 TabName = arr3(i) If Len(TabName) > 0 Then strsql = "delete " & TabName Set rs = Nothing rs.Open strsql, CNN2, 1, 2, 1 '在源资料中取出全部的资料 strsql = "select * from " & TabName Set rs = Nothing rs.Open strsql, CNN, 1, 1, 1 'update 备份 strsql = "select * from " & TabName Set Rs2 = Nothing Rs2.Open strsql, CNN2, 1, 2, 1 For j = 1 To rs.RecordCount '源数据库 Rs2.AddNew '在新数据库中update For k = 0 To rs.Fields.Count - 1: Rs2(rs.Fields(k).Name) = rs.Fields(k): Next Rs2.Update rs.MoveNext Next Debug.Print TabName, Format(Timer - aaa) End If Next CNN2.CommitTrans Call NewMsgbox(Format(Timer - aaa) & "S 备份全部完成!") 'MsgBox Format(Timer - aaa) & " S 备份全部完成!" Set rs = Nothing Set Rs2 = Nothing Set Cat.ActiveConnection = Nothing CNN2.Close: Set CNN2 = Nothing Exit Sub 9: MsgBox Err.Description Set rs = Nothing Set Rs2 = Nothing Set Cat.ActiveConnection = Nothing CNN2.Close: Set CNN2 = Nothing Exit Sub 99: CNN2.RollbackTrans: MsgBox Err.Description Set rs = Nothing Set Rs2 = Nothing Set Cat.ActiveConnection = Nothing CNN2.Close: Set CNN2 = Nothing End Sub
[此贴子已经被作者于2007-4-23 14:18:58编辑过] |