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 & "',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,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

代码还是有点问题，以后改正！有兴趣的朋友可以参考下.........................