需建Module1
Option Explicit
Public goSQLServer As SQLDMO.SQLServer
Public gShowServerEvents As Boolean
Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Cn As New ADODB.Connection
新建一個Form,Copy以下代碼
VERSION 5.00
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "初始化系統數據庫..."
ClientHeight = 3360
ClientLeft = 45
ClientTop = 330
ClientWidth = 5340
Icon = "Form1.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3360
ScaleWidth = 5340
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Command2
BackColor = &H00FFFFFF&
Caption = "正在查找SQLSERVER數據庫服務器，請稍候..."
BeginProperty Font
Name = "宋體"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 690
Left = 540
MaskColor = &H00FFFFFF&
TabIndex = 5
Top = 975
Width = 4290
End
Begin VB.CommandButton Command1
Caption = "退出"
BeginProperty Font
Name = "宋體"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 4230
TabIndex = 3
Top = 360
Width = 930
End
Begin VB.ListBox List1
BeginProperty Font
Name = "宋體"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2370
Left = 180
TabIndex = 2
Top = 855
Width = 4965
End
Begin VB.ComboBox TxtServer
BeginProperty Font
Name = "宋體"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 180
TabIndex = 1
Top = 360
Width = 2805
End
Begin VB.CommandButton Cmdcreate
Caption = "確定"
BeginProperty Font
Name = "宋體"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 3135
TabIndex = 0
Top = 360
Width = 930
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "請在下框中輸入SQL2000服務器名稱:"
Height = 180
Left = 150
TabIndex = 4
Top = 120
Width = 2880
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private oSQLServerDMOApp As SQLDMO.Application
Public oSQLServer As SQLDMO.SQLServer
Attribute oSQLServer.VB_VarHelpID = -1
Public WithEvents Ores As SQLDMO.Restore
Attribute Ores.VB_VarHelpID = -1
Private Sub Command1_Click()
End
End Sub
Private Sub Form_Activate()
On Error GoTo Errorhandle
Me.MousePointer = 12
Command2.Visible = True
Me.Refresh
Set oSQLServerDMOApp = New SQLDMO.Application
gShowServerEvents = False
Dim namX As NameList
Set namX = oSQLServerDMOApp.ListAvailableSQLServers
For I = 1 To namX.Count
TxtServer.AddItem namX.Item(I)
Next
TxtServer.ListIndex = 0
Command2.Visible = False
Me.MousePointer = 0
Exit Sub
Errorhandle:
Command2.Visible = False
MsgBox "本程序只能在安裝好SQLSERVER數據庫的電腦上執行，如已安裝好SQL，請重新啓動電腦再執行 ！", vbCritical, "幫助信息"
MsgBox "如已安裝好SQLserver，請在框中直接輸入SQL服務器名稱 ！", vbCritical, "幫助信息"
End Sub
Private Sub Form_Load()
'查找數據庫 服務器-------------
Dim rtn
rtn = SetWindowPos(Me.hWnd, -1, 0, 0, 0, 0, 3)
Dim I As Integer
On Error GoTo Errorhandle
'建數據庫文件目錄
If Len(Dir("D:/DataBase", vbDirectory)) = 0 Then MkDir "D:/DataBase"
Exit Sub
Errorhandle:
MsgBox "本程序只能在安裝好SQLSERVER數據庫的電腦上執行，如已安裝好SQL，請重新啓動電腦再執行 ！", vbCritical, "錯誤信息"
End Sub
Private Sub cmdCreate_Click()
Dim I As Integer
Dim sDatabaseName As String
Dim DataFile As String
Dim sSQL As String
Dim oDatabase As SQLDMO.Database
Dim oDBFileData As New SQLDMO.DBFile
Dim oLogFile As New SQLDMO.LogFile
Set oSQLServer = New SQLDMO.SQLServer
List1.Clear
On Error GoTo ErrorHandler
If Len(Trim(TxtServer)) = 0 Then
MsgBox "請輸入SQL服務器名稱!", vbCritical, "幫助信息"
Exit Sub
End If
'查找源文件是否存在
If Dir(App.Path & "/mrpii.bak") = "" Then
MsgBox "數據源文文件不存在!(" & App.Path & "/mrpii.bak)", vbCritical, "幫助信息": GoTo Proc_exit
End If
With oSQLServer
.LoginSecure = False
.AutoReConnect = False
.Connect TxtServer.Text, "sa", ""
End With
Set goSQLServer = oSQLServer
sDatabaseName = "mrpii" '數據庫名稱
DataFile = App.Path & "/mrpii.bak" '備份文件名稱
If sDatabaseName = "" Then Exit Sub
For Each oDatabase In goSQLServer.Databases
If Not oDatabase.SystemObject Then
If sDatabaseName = oDatabase.Name Then
List1.AddItem "數據庫已經存在。。。。。。"
List1.AddItem "不能初始化。。。。。。"
Me.Refresh
GoTo Proc_exit
End If
End If
Next
List1.AddItem "數據庫較檢，準備加載數據庫。。。。。。。"
Me.Refresh
Me.MousePointer = 12
If Cn.State = 1 Then Cn.Close
Cn.Open "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=master;Data Source=" & TxtServer.Text
List1.AddItem "數據庫加載進行中,需一、二分鐘。。。。。"
Me.Refresh
'恢復數據庫
sSQL = "RESTORE DATABASE mrpii FROM DISK = '" & DataFile & "'" _
& " WITH MOVE 'mrpii_data' TO 'd:/database/mrpii_data.mdf' ," & Chr(10) _
& " MOVE 'mrpii_log' TO 'd:/database/mrpii_log.ldf'"
Cn.Execute sSQL
List1.AddItem "數據庫初始化完成。。。。。。。"
Me.Refresh
'新建登陸名
Set rs = Cn.Execute("SELECT * FROM master..sysxlogins WHERE name='MRPIIADMIN'")
If rs.EOF Then
Cn.Execute " EXEC sp_addlogin 'MRPIIADMIN', 'ADMIN123456789'"
Cn.Execute " EXEC sp_addsrvrolemember 'MRPIIADMIN', 'sysadmin'"
End If
List1.AddItem "創建數據庫用戶完成。。。。。。。"
List1.AddItem ""
List1.AddItem "成功完成數據庫創建，請退出後運行系統！"
Me.Refresh
MsgBox "成功完成數據庫創建，請退出後運行系統！ ", vbInformation, "幫助信息"
Kill App.Path & "/mrpii.bak"
Proc_exit:
Set Ores = Nothing
Set oSQLServer = Nothing
Me.MousePointer = 0
Exit Sub
ErrorHandler:
Me.MousePointer = 0
Select Case Err.Number
Case -2147218403
MsgBox "數據庫正在使用，請關閉所有正在使用數據的程序！", vbExclamation, "錯誤"
Case Else
MsgBox Err.Number & vbCrLf & Err.Description, vbExclamation, "提示"
End Select
End Sub