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

 程式碼還是有點問題，以後改正！有興趣的朋友可以參考下.........................