Option Explicit
Dim isConnect As Boolean '判斷數據庫是否連接成功
Dim ConADODB As New ADODB.Connection '用於連接MASTER系統數據庫
Dim ResADODB As New ADODB.Recordset '用於獲取所有數據庫
'Dim ConADODB As New ADODB.Connection '用於連接用戶數據庫
Private Sub CboChooseDatabase_Click() '選擇數據庫，得到該數據庫所有的表(只操作用戶表）
Dim rs As New ADODB.Recordset
Call ConnectDatabase(CboChooseDatabase.Text, ConADODB)
CboTable.Clear
Dim criteria(3) As Variant
criteria(0) = CboChooseDatabase.Text
criteria(1) = Empty
criteria(2) = Empty
criteria(3) = "table"
Set rs = ConADODB.OpenSchema(adSchemaTables, criteria)
While Not rs.EOF
CboTable.AddItem (rs!TABLE_NAME)
rs.MoveNext
Wend
CboTable.Text = CboTable.List(0)
Call CboTable_Click
Dim i As Integer
rs.Close
ConADODB.Close
End Sub
Private Sub CboTable_Click() '選擇表，得到表中所有字段名稱
Dim strSql As String
Dim rs As New ADODB.Recordset
Call ConnectDatabase(CboChooseDatabase.Text, ConADODB)
strSql = " Select Name FROM SysColumns Where id=Object_Id('" & CboTable.Text & "')"
rs.Open strSql, ConADODB
CboTableField.Clear
Do While Not rs.EOF
CboTableField.AddItem rs!Name
rs.MoveNext
Loop
CboTableField.Text = CboTableField.List(0)
rs.Close
ConADODB.Close
End Sub
Private Sub CboTableField_Click()
TxtFieldName.Text = CboTableField.Text
End Sub
Private Sub CmdAlterDatabaseName_Click() '修改數據庫名稱
Dim strOldName As String
Dim strNewName As String
Dim strSql As String
strOldName = CboChooseDatabase.List(CbxIndex)
strNewName = CboChooseDatabase.Text
strSql = "Exec sp_renamedb '" & strOldName & "','" & strNewName & "' "
Call ConnectSting
ConADODB.Execute strSql
ConADODB.Close
End Sub
Private Sub CmdAlterTable_Click() '修改表的名稱，該表必須存在
Dim strOldName As String
Dim strNewName As String
Dim strSql As String
strOldName = CboChooseDatabase.List(CbxIndex)
strNewName = CboChooseDatabase.Text
strSql = "Exec sp_renamedb '" & strOldName & "','" & strNewName & "' "
ConADODB.Execute strSql
End Sub
'創建一個新的數據庫
Private Sub CmdCreateDatabase_Click()
Dim strNewDatabaseName As String
Dim strSql As String
Dim i As Integer
strNewDatabaseName = CboChooseDatabase.Text
For i = 0 To CboChooseDatabase.ListCount - 1
If CboChooseDatabase.List(i) = strNewDatabaseName Then
MsgBox "該數據庫已經存在，請重新命名數據庫！"
Exit Sub
End If
Next i
If Len(Trim(CboChooseDatabase.Text)) > 0 Then
CboChooseDatabase.AddItem (strNewDatabaseName)
Dim strNameData, strFileNameDataMdf As String
Dim strNameLog, strFileNameLogLdf As String
strNameData = strNewDatabaseName & "_data"
strFileNameDataMdf = "D:\" & strNameData & ".mdf"
strNameLog = strNewDatabaseName & "_log"
strFileNameLogLdf = "D:\" & strNameLog & ".ldf"
strSql = "create database " & strNewDatabaseName & " on primary(name=" & strNameData & ",filename='" & strFileNameDataMdf & "'"
strSql = strSql & ",size=5mb,maxsize=100mb,filegrowth=10%)log on(name=" & strNameLog & ",filename='" & strFileNameLogLdf & "',size=5mb,maxsize"
strSql = strSql & "=100mb,filegrowth=10%)"
Call ConnectSting
ConADODB.Execute strSql
MsgBox "數據庫創建成功！"
Else
MsgBox "數據庫名稱不能爲空，請命名！"
End If
ConADODB.Close
End Sub
Private Sub CmdDelDatabase_Click() '刪除數據庫，不能刪除系統數據庫
Dim strDataName As String
' Dim ConADODB As New ADODB.Connection
' On Error GoTo err
' ConADODB.State
strDataName = CboChooseDatabase.Text
Dim strSql As String
If strDataName <> "master" And strDataName <> "model" And strDataName <> "msdb" And strDataName <> "tempdb" And Mid(strDataName, 1, 13) <> "ReportServer$" Then
strSql = "drop database " & strDataName & ""
Call ConnectSting
ConADODB.Execute strSql
CboChooseDatabase.Clear
Call InitDB
Else
MsgBox "不能刪除系統數據庫！"
Exit Sub
End If
'err:
' MsgBox err.Description
ConADODB.Close
End Sub
Private Sub CmdDelTable_Click() '刪除數據庫中的一張表
Dim strDataName As String '待刪除表所在的數據庫
Dim strTableName As String '待刪除的表名
Dim strSql As String
strDataName = CboChooseDatabase.Text
strTableName = CboTable.Text
If Trim(strDataName) = "" Then
MsgBox "沒有選擇數據庫，請選擇！"
Exit Sub
End If
If Trim(strTableName) = "" Then
MsgBox "沒有選擇表，請選擇！"
Exit Sub
End If
Call ConnectDatabase(strDataName, ConADODB)
strSql = "if exists (select 1 from sysobjects where id=object_id('" & strTableName & "')and type='U')drop table " & strTableName & ""
If isConnect = False Then
MsgBox "沒有連接成功數據庫，請重新選擇數據庫！"
Exit Sub
Else
ConADODB.Execute strSql
End If
ConADODB.Close
End Sub
Private Sub InitDB()
Call ConnectSting
ConADODB.CommandTimeout = 20
'獲取本地sql服務器中所有數據庫
ResADODB.Open "sysdatabases", ConADODB, adOpenDynamic, adLockOptimistic
Dim strDataName As String
Do While Not ResADODB.EOF
strDataName = ResADODB.Fields("name").Value
If strDataName <> "master" And strDataName <> "model" And strDataName <> "msdb" And strDataName <> "tempdb" And Mid(strDataName, 1, 13) <> "ReportServer$" Then
CboChooseDatabase.AddItem (strDataName)
End If
ResADODB.MoveNext
Loop
Set ResADODB = Nothing
ConADODB.Close
End Sub
Private Sub Form_Load()
LvwNewTable.Enabled = False
LvwNewTable.BackColor = &H8000000B
Call InitDB
End Sub
Private Sub ConnectDatabase(databaseName As String, cn As ADODB.Connection) '爲數據庫創建連接對象並返回
Dim i As Integer
For i = 0 To CboChooseDatabase.ListCount
If Trim(CboChooseDatabase.List(i)) = Trim(databaseName) Then
cn.ConnectionString = "Provider=SQLOLEDB;Persist Security Info=False;User ID=sa;PWD=密碼;Initial Catalog=" & databaseName & ";Data Source=服務器名" '連接數據庫字符串
cn.Open
isConnect = True
Exit Sub
End If
Next i
isConnect = False
MsgBox "選擇的數據庫不存在，請重新創建或選擇！"
End Sub
Private Sub ConnectSting()
If ConADODB.State = 0 Then
ConADODB.ConnectionString = "Provider=SQLOLEDB;Persist Security Info=False;User ID=sa;PWD=密碼;Initial Catalog=master;Data Source=服務器名" '連接數據庫字符串
ConADODB.Open
End If
End Sub
代碼還是有點問題，以後改正！有興趣的朋友可以參考下.........................