📄 main.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form Form1
Caption = "金科软件数据库升级程序"
ClientHeight = 4020
ClientLeft = 3240
ClientTop = 2655
ClientWidth = 9045
Icon = "main.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 4020
ScaleWidth = 9045
Begin VB.PictureBox Picture1
Height = 3795
Left = 60
Picture = "main.frx":08CA
ScaleHeight = 3735
ScaleWidth = 2355
TabIndex = 10
Top = 120
Width = 2415
End
Begin VB.Data Data1
Caption = "Data1"
Connect = "Access"
DatabaseName = ""
DefaultCursorType= 0 '缺省游标
DefaultType = 2 '使用 ODBC
Exclusive = 0 'False
Height = 555
Left = 2280
Options = 0
ReadOnly = 0 'False
RecordsetType = 1 'Dynaset
RecordSource = ""
Top = 4920
Width = 2595
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 5760
Top = 3180
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton Command4
Caption = "退出程序"
Height = 855
Left = 6000
Picture = "main.frx":68D7
Style = 1 'Graphical
TabIndex = 4
Top = 3000
Width = 915
End
Begin VB.CommandButton Command3
Caption = "开始升级"
Height = 855
Left = 4980
Picture = "main.frx":6D19
Style = 1 'Graphical
TabIndex = 3
Top = 3000
Width = 915
End
Begin VB.Frame Frame1
Height = 2115
Left = 2580
TabIndex = 5
Top = 480
Width = 6315
Begin VB.CommandButton Command2
Caption = "浏览"
Height = 375
Left = 5460
TabIndex = 2
Top = 1320
Width = 615
End
Begin VB.TextBox Text2
Height = 375
Left = 1020
TabIndex = 9
Top = 1320
Width = 4395
End
Begin VB.CommandButton Command1
Caption = "浏览"
Height = 375
Left = 5460
TabIndex = 1
Top = 540
Width = 615
End
Begin VB.TextBox Text1
Height = 375
Left = 1020
TabIndex = 7
Top = 540
Width = 4395
End
Begin VB.Label Label3
Caption = "新数据库："
Height = 315
Left = 120
TabIndex = 8
Top = 1440
Width = 975
End
Begin VB.Label Label2
Caption = "旧数据库："
Height = 315
Left = 120
TabIndex = 6
Top = 660
Width = 975
End
End
Begin VB.Label Label1
Caption = "数据库升级之前先把数据库备份，然后再使用本程序升级数据库。"
Height = 375
Left = 2640
TabIndex = 0
Top = 180
Width = 7155
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim OldName As String
Dim NewName As String
'Public skinpp As New SKINPPVBCOMLib.SkinPPVBComDll
Private Sub Command1_Click()
'CommonDialog1.CancelError = True
CommonDialog1.DialogTitle = "请选择要还原的数据库路径并输入文件名"
'CD1.FileName = "备份" & Date & ".bak"
CommonDialog1.Filter = "数据库文件(*.mdb)|*.mdb|所有文件(*.*)|*.*|"
CommonDialog1.ShowOpen
Text1.Text = CommonDialog1.FileName
OldName = CommonDialog1.FileTitle
End Sub
Private Sub Command2_Click()
'CommonDialog1.CancelError = True
CommonDialog1.DialogTitle = "请选择要还原的数据库路径并输入文件名"
'CD1.FileName = "备份" & Date & ".bak"
CommonDialog1.Filter = "备份文件(*.mdb)|*.mdb|所有文件(*.*)|*.*|"
CommonDialog1.Filter = "数据库文件 (*.mdb)|*.mdb"
CommonDialog1.ShowOpen
Text2.Text = CommonDialog1.FileName
NewName = CommonDialog1.FileTitle
End Sub
Private Sub Command3_Click()
If Text1.Text = "" Or OldName = "" Then
MsgBox "请你选择旧数据库路径！", vbInformation
Exit Sub
End If
If Text2.Text = "" Or NewName = "" Then
MsgBox "请你选择新数据库路径！", vbInformation
Exit Sub
End If
On Error Resume Next
'从A.mdb中复制到B.mdb中的方法差不多
'Set db = OpenDatabase("A.mdb")
'db.Execute "Select * Into NewName IN "B.mdb" from wdjl"
Dim conn1 As New ADODB.Connection
Dim conn2 As New ADODB.Connection
Dim str1 As String
Dim str2 As String
Dim rs1 As New ADODB.Recordset '旧数据库
Dim rs2 As New ADODB.Recordset '新数据库
Dim RsOld As New ADODB.Recordset
Dim RsNew As New ADODB.Recordset
str1 = Text1.Text
str2 = Text2.Text
FileCopy Text2.Text, Replace(Text2.Text, NewName, "") & "tem.mdb"
conn1.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source= '" & str1 & "' ; Jet OLEDB:Database Password=jinke668.com"
If conn1.State = 0 Then
MsgBox "旧数据库链接不成功！,请确认数据库路径链接是否成功！"
Exit Sub
End If
str2 = Replace(Text2.Text, NewName, "") & "tem.mdb"
conn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source= '" & str2 & "' ; Jet OLEDB:Database Password=jinke668.com"
If conn2.State = 0 Then
MsgBox "新数据库链接不成功！,请确认数据库路径链接是否成功！"
Exit Sub
End If
Set rs2 = conn2.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "Table"))
Set rs1 = conn1.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "Table"))
If rs1.RecordCount <> 0 Then
Do Until rs1.EOF
SQL = "select * from " & rs1.Fields("TABLE_NAME") & " "
'MsgBox SQL
RsOld.Open SQL, conn1, 2, 2
RsNew.Open SQL, conn2, 2, 2
If Not RsOld.BOF Then '把旧数据库中的数据复制到新数据库中
While Not RsOld.EOF
RsNew.AddNew
For J = 0 To RsOld.Fields.Count - 1
If RsOld.Fields(J).Name <> "ID" And RsOld.Fields(J).Name <> "id" Or RsOld.Fields(J).Name <> "Id" Or RsOld.Fields(J).Name <> "iD" Then
RsNew(RsOld.Fields(J).Name) = RsOld.Fields(J).Value
End If
Next
RsNew.Update
RsOld.MoveNext
Wend
End If
RsOld.Close
Set RsOld = Nothing
RsNew.Close
Set RsNew = Nothing
'MsgBox rs1.Fields("TABLE_NAME")
rs1.MoveNext
Loop
End If
rs1.Close
Set rs1 = Nothing
rs2.Close
Set rs2 = Nothing
conn1.Close
Set conn1 = Nothing
conn2.Close
Set conn2 = Nothing
Kill Text1.Text
Name Replace(Text2.Text, NewName, "") & "tem.mdb" As Text1.Text
'Kill Replace(Text2.Text, NewName, "") & "tem.mdb"
MsgBox "数据库升级成功！", vbInformation
End Sub
Private Sub Command4_Click()
End
End Sub
Private Sub Form_Load()
'Text1.Text = "C:\Documents and Settings\new\桌面\old.mdb"
'Text2.Text = "C:\Documents and Settings\new\桌面\new.mdb"
'skinpp.InitializeSkin "XPCorona.ssk"
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -