怎样象SQL SERVER企业管理器的REGISTER一样获取所有本地SQL服务器名

工程引用 Microsoft SQLDMO Object Library    Set sqlApp = New Application
    Set sqlNameList = sqlApp.ListAvailableSQLServers()
    cmbM_Server.Clear
    For intIndex = 1 To sqlNameList.Count - 1
        cmbM_Server.AddItem sqlNameList.Item(intIndex)
    Next intIndex
    sqlApp.Quit
    Set sqlApp = Nothing

GOOD和我找到得一样。进一步的问题来了，怎么获取选定的服务器中所有DATABASE的名称？

'****************************************************************************

'描    述：SQL 服务器数据库结构生成器

'****************************************************************************
Option ExplicitPrivate Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_NORMAL = 1Private Sub cboDatabaseName_Click()Dim errhandle       As LabelOn Error GoTo errhandlefrmSQLServerDocumenter.MousePointer = 11
Fill_cboTableName
frmSQLServerDocumenter.MousePointer = 0
Exit Suberrhandle:
    frmSQLServerDocumenter.MousePointer = 0
    MsgBox "未知错误:" & vbCrLf & Err.Description & vbCrLf & Err.Number, vbCritical, "错误"

End SubPrivate Sub cboSQLServerList_Change()End SubPrivate Sub cmdConnect_Click()Dim errhandle                   As LabelOn Error GoTo errhandleIf cboSQLServerList.ListIndex < 1 Then
    MsgBox "请选择一个服务器。", vbCritical, "错误"
    Exit Sub
End IfSelect Case cmdConnect.Caption
    Case "连接"
        lblStatus.Caption = "连接中..."
        picConnectionStatus.Picture = imlConnectionStatus.ListImages(2).Picture
        lblStatus.Refresh
        If optSQLAuth.Value = True Then
            Set objSQLServer = New SQLDMO.SQLServer
            objSQLServer.Connect cboSQLServerList.Text, txtUserName.Text, txtPassword.Text
            txtUserName.Enabled = False
            txtPassword.Enabled = False
        ElseIf optWinAuth.Value = True Then
            Set objSQLServer = New SQLDMO.SQLServer
            objSQLServer.LoginSecure = True
            objSQLServer.Connect cboSQLServerList.Text
        End If
        cmdConnect.Caption = "断开连接"
        blnConnectionState = True
        Fill_cboDatabaseName
        cboSQLServerList.Enabled = False
        optSQLAuth.Enabled = False
        optWinAuth.Enabled = False
        lblStatus.Caption = "已连接"
        picConnectionStatus.Picture = imlConnectionStatus.ListImages(1).Picture
    Case "断开连接"
        lblStatus.Caption = "断开中..."
        picConnectionStatus.Picture = imlConnectionStatus.ListImages(4).Picture
        lblStatus.Refresh
        objSQLServer.DisConnect
        Set objSQLServer = Nothing
        cmdConnect.Caption = "连接"
        blnConnectionState = False
        cboSQLServerList.Enabled = True
        If optSQLAuth.Value = True Then
            txtUserName.Enabled = True
            txtPassword.Enabled = True
        End If
        optSQLAuth.Enabled = True
        optWinAuth.Enabled = True
        cboDatabaseName.Clear
        cboTableName.Clear
        lsvTableData.ListItems.Clear
        lblStatus.Caption = "未连接"
        picConnectionStatus.Picture = imlConnectionStatus.ListImages(3).Picture
End Select
Exit Sub
errhandle:
    lblStatus.Caption = "连接失败"
    picConnectionStatus.Picture = imlConnectionStatus.ListImages(5).Picture
    MsgBox Err.Description & vbCrLf & Err.Number, vbCritical, "错误"End SubPrivate Sub cmdExport2XLS_Click()Dim errhandle           As LabelOn Error GoTo errhandleIf cboTableName.Text = "" Then
    MsgBox "请选择一个表。", vbCritical, "错误"
    Exit Sub
End IfMe.MousePointer = 11
dlgExport.DialogTitle = "导出到Excel文件"
dlgExport.DefaultExt = ".xls"
dlgExport.Filter = "Excel 工作薄|*.xls"
dlgExport.ShowSaveIf dlgExport.FileName = "" Then
    Exit Sub
End IfExport2XLS cboTableName.Text, dlgExport.FileName, cboSQLServerList.Text, cboDatabaseName.TextMe.MousePointer = 0
Exit Sub
errhandle:
    Me.MousePointer = 0
    MsgBox Err.Description & vbCrLf & Err.Number, vbCritical, "错误"End SubPrivate Sub cmdPreviewPrint_Click()Dim errhandle           As LabelOn Error GoTo errhandleIf cboTableName.Text = "" Then
    MsgBox "请选择一个表。", vbCritical, "错误"
    Exit Sub
End IfPrintPreview cboTableName.Text, cboDatabaseName.Text, cboSQLServerList.TextfrmPrintPreview.Show 1Exit Sub
errhandle:
    MsgBox Err.Description & vbCrLf & Err.Number, vbCritical, "错误"End Sub

Private Sub cmdShowIndexes_Click()Dim errhandle           As LabelOn Error GoTo errhandle
blnShowTable = FalseIf cboTableName.ListIndex < 1 Then
    MsgBox "请选择一个表。", vbCritical, "错误"
    Exit Sub
End IffrmSQLServerDocumenter.MousePointer = 11
Format_lsvIndex
Fill_lsvIndex
frmSQLServerDocumenter.MousePointer = 0Exit Sub
errhandle:
    frmSQLServerDocumenter.MousePointer = 0
    MsgBox Err.Description & vbCrLf & Err.Number, vbCritical, "错误"End SubPrivate Sub cmdShowTable_Click()Dim errhandle           As LabelOn Error GoTo errhandle
blnShowTable = TrueIf cboTableName.ListIndex < 1 Then
    MsgBox "P请选择一个表。", vbCritical, "错误"
    Exit Sub
End IffrmSQLServerDocumenter.MousePointer = 11
Format_lsvTable
Fill_lsvTable
frmSQLServerDocumenter.MousePointer = 0Exit Sub
errhandle:
    frmSQLServerDocumenter.MousePointer = 0
    MsgBox Err.Description & vbCrLf & Err.Number, vbCritical, "错误"End SubPrivate Sub fmeAbout_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)If X > 0 And X < fmeAbout.Width And Y > 0 And Y < fmeAbout.Height Then
    If GetCapture <> fmeAbout.hwnd Then
        lblAbout.ForeColor = vbBlue
        lblAbout.FontUnderline = True
        SetCapture fmeAbout.hwnd
    End If
Else
    lblAbout.ForeColor = vbBlack
    lblAbout.FontUnderline = False
    ReleaseCapture
End If

End SubPrivate Sub Form_Load()frmSplash.Show
DoEvents
Me.Caption = "SQL 服务器数据库结构生成器 v" & App.Major & "." & App.Minor & "." & App.Revision
Center Me
frmSplash.lblStatus.Caption = "正在初始化环境...."
frmSplash.lblStatus.Refresh
InitArray
txtUserName.Enabled = False
txtPassword.Enabled = False
txtUserName.BackColor = &H8000000F
txtPassword.BackColor = &H8000000F
frmSplash.lblStatus.Caption = "正在搜索网络中的 SQL 服务器..."
frmSplash.lblStatus.Refresh
Fill_cboSQLServerList
blnConnectionState = False
picConnectionStatus.Picture = imlConnectionStatus.ListImages(3).Picture
Unload frmSplashEnd SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)If blnConnectionState = True Then
    cmdConnect_Click
    Set objSQLServer = Nothing
End IfEnd SubPrivate Sub Form_Resize()If Me.WindowState <> 1 Then
    Me.Width = 9945
    Me.Height = 7200
End IfEnd SubPrivate Sub lblAbout_Click()
    ShellExecute Me.hwnd, "open", "http://www.mndsoft.com/", vbNullString, vbNullString, SW_NORMAL
End SubPrivate Sub optSQLAuth_Click()txtUserName.Enabled = True
txtPassword.Enabled = True
txtUserName.BackColor = &H80000005
txtPassword.BackColor = &H80000005
txtUserName.SetFocusEnd SubPrivate Sub optWinAuth_Click()txtUserName.Enabled = False
txtPassword.Enabled = False
txtUserName.BackColor = &H8000000F
txtPassword.BackColor = &H8000000F
txtUserName.Text = ""
txtPassword.Text = ""End Sub'搜索网络内的SQL服务器
Sub Fill_cboSQLServerList()Dim ServerList      As SQLDMO.NameList
Dim SQLApp          As SQLDMO.Application
Dim lngCounter      As LongSet SQLApp = New SQLDMO.Application
Set ServerList = SQLApp.ListAvailableSQLServerscboSQLServerList.AddItem ""
cboSQLServerList.ItemData(cboSQLServerList.NewIndex) = 0For lngCounter = 1 To ServerList.Count
    cboSQLServerList.AddItem ServerList.Item(lngCounter)
    cboSQLServerList.ItemData(cboSQLServerList.NewIndex) = lngCounter
NextEnd SubSub Fill_cboDatabaseName()Dim lngCounter              As LongcboDatabaseName.ClearcboDatabaseName.AddItem ""
cboDatabaseName.ItemData(cboDatabaseName.NewIndex) = 0For Each objDatabase In objSQLServer.Databases
    If (Not objDatabase.SystemObject = True) Then
        cboDatabaseName.AddItem objDatabase.Name
        cboDatabaseName.ItemData(cboDatabaseName.NewIndex) = lngCounter
        lngCounter = lngCounter + 1
    End If
NextEnd SubSub Fill_cboTableName()Dim lngCounter              As LongIf cboDatabaseName.ListIndex < 1 Then
    MsgBox "请选择一个数据库！", vbCritical, "错误"
    Exit Sub
End IfSet objTable = New SQLDMO.Table
Set objDatabase = objSQLServer.Databases(cboDatabaseName.Text)
cboTableName.ClearcboTableName.AddItem ""
cboTableName.ItemData(cboTableName.NewIndex) = 0For Each objTable In objDatabase.Tables
    If Not objTable.SystemObject = True Then
        cboTableName.AddItem objTable.Name
        cboTableName.ItemData(cboTableName.NewIndex) = lngCounter
        lngCounter = lngCounter + 1
    End If
NextEnd SubSub Format_lsvTable()Dim itmX                As ColumnHeaderlsvTableData.ColumnHeaders.ClearSet itmX = lsvTableData.ColumnHeaders.Add(, , "列名", 2500)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "数据类型", 2500)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "长度", 1000)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "允许空", 1500)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "标识", 1000)lsvTableData.View = lvwReportEnd SubSub Format_lsvIndex()Dim itmX                As ColumnHeaderlsvTableData.ColumnHeaders.ClearSet itmX = lsvTableData.ColumnHeaders.Add(, , "索引名", 2000)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "索引类型", 3000)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "索引字段", 3700)
Set itmX = lsvTableData.ColumnHeaders.Add(, , "% 填充", 600, vbCenter)lsvTableData.View = lvwReportEnd SubSub Fill_lsvTable()Dim lngCounter          As Long
Dim itmY                As ListItem
Dim objIndex            As SQLDMO.Index
Dim objTable            As SQLDMO.TablelsvTableData.ListItems.ClearSet objColumn = New SQLDMO.Column
Set objTable = objDatabase.Tables(cboTableName.Text)For Each objColumn In objTable.Columns
    Set itmY = lsvTableData.ListItems.Add(, "U" & lngCounter, objColumn.Name)
        itmY.SubItems(1) = objColumn.Datatype
        itmY.SubItems(2) = objColumn.Length
        itmY.SubItems(3) = objColumn.AllowNulls
        itmY.SubItems(4) = objColumn.Identity
    lngCounter = lngCounter + 1
NextEnd SubSub Fill_lsvIndex()Dim lngCounter          As Long
Dim itmY                As ListItem
Dim objIndex            As SQLDMO.Index
Dim objTable            As SQLDMO.Table
Dim objColumn           As SQLDMO.Column
Dim strIndexedFields    As String
Dim intCount            As IntegerlsvTableData.ListItems.ClearSet objIndex = New SQLDMO.Index
Set objTable = objDatabase.Tables(cboTableName.Text)For Each objIndex In objTable.Indexes
    If Left(objIndex.Name, 8) <> "_WA_Sys_" And Left(objIndex.Name, 5) <> "hind_" Then
        Set itmY = lsvTableData.ListItems.Add(, "U" & lngCounter, objIndex.Name)
            itmY.SubItems(1) = DecodeIDXType(objIndex.Type)
            For intCount = 1 To objIndex.ListIndexedColumns.Count
                Set objColumn = objIndex.ListIndexedColumns.Item(intCount)
                strIndexedFields = strIndexedFields & objColumn.Name & ", "
            Next
            itmY.SubItems(2) = Left(strIndexedFields, Len(strIndexedFields) - 2)
            itmY.SubItems(3) = objIndex.FillFactor
        lngCounter = lngCounter + 1
    End If
    strIndexedFields = ""
NextEnd Sub

大家帮忙看看下面的代码出什么问题了。
报错说Expected Function or variable.出错表示在Connect
Private Sub cmbDatabase_DropDown()
    If "" = Trim(cmbServerName.Text) Then
        cmbServerName.SetFocus
        MsgBox ("Please select a server.")
    If "" = Trim(ServerUserName.Text) Then
        ServerUserName.SetFocus
        MsgBox ("Please input user name.")
    End If
    If "" = Trim(ServerPassword.Text) Then
        ServerPassword.SetFocus
        MsgBox ("Please input password.")
    End If
    Dim strServer As SQLDMO.SqlServer
    Dim connFlag As String
    connFlag = strServer.Connect(cmbServerName.Text, ServerUserName.Text, ServerPassword.Text)
    For i = 1 To strServer.Databases.Count
    cmbDatabase.AddItem strServer.Databases(i).Name

End Sub

调试易

怎样象SQL SERVER企业管理器的REGISTER一样获取所有本地SQL服务器名

解决方案 »