如何使用代码得到网络中可用的SQL 服务器列表

李寻欢

Option Compare Text
Option Explicit

'  RETCODEs
Private Const SQL_ERROR As Long = -1&
Private Const SQL_INVALID_HANDLE As Long = -2&
Private Const SQL_NEED_DATA As Long = 99&
Private Const SQL_NO_DATA_FOUND As Long = 100&
Private Const SQL_SUCCESS As Long = 0&
Private Const SQL_SUCCESS_WITH_INFO As Long = 1&

'  SQLError defines
Private Const SQL_NULL_HENV As Long = 0&
Private Const SQL_NULL_HDBC As Long = 0&
Private Const SQL_NULL_HSTMT As Long = 0&

Private Declare Function SQLAllocConnect Lib "odbc32.dll" (ByVal henv As Long, phdbc As Long) As Integer
Private Declare Function SQLAllocEnv Lib "odbc32.dll" (phenv As Long) As Integer
Private Declare Function SQLBrowseConnect Lib "odbc32.dll" (ByVal hdbc As Long, ByVal szConnStrIn As String, ByVal cbConnStrIn As Integer, ByVal szConnStrOut As String, ByVal cbConnStrOutMax As Integer, pcbconnstrout As Integer) As Integer
Private Declare Function SQLDisconnect Lib "odbc32.dll" (ByVal hdbc As Long) As Integer
Private Declare Function SQLError Lib "odbc32.dll" (ByVal henv As Long, ByVal hdbc As Long, ByVal hstmt As Long, ByVal szSqlState As String, pfNativeError As Long, ByVal szErrorMsg As String, ByVal cbErrorMsgMax As Integer, pcbErrorMsg As Integer) As Integer
Private Declare Function SQLFreeConnect Lib "odbc32.dll" (ByVal hdbc As Long) As Integer
Private Declare Function SQLFreeEnv Lib "odbc32.dll" (ByVal henv As Long) As Integer

Public Function StServerList() As String
On Error Resume Next
    Dim rc As Integer
    Dim henv As Long
    Dim hdbc As Long
    Dim stCon As String
    Dim stConOut As String
    Dim pcbConOut As Integer
    Dim ichBegin As Integer
    Dim ichEnd As Integer
    Dim stOut As String
   
    Const COMMA As String = ","
   
    rc = SQLAllocEnv(henv)
    rc = SQLAllocConnect(ByVal henv, hdbc)
    stCon = "DRIVER=SQL Server"
   
    ' Get the size of the buffer to create and create it
    rc = SQLBrowseConnect(ByVal hdbc, stCon, Len(stCon), stConOut, Len(stConOut) + 2, pcbConOut)
    stConOut = String$(pcbConOut + 2, vbNullChar)
   
    ' Get the actual server list
    rc = SQLBrowseConnect(ByVal hdbc, stCon, Len(stCon), stConOut, Len(stConOut) + 2, pcbConOut)
   
    If (rc <> SQL_SUCCESS) And (rc <> SQL_NEED_DATA) Then
        ' ignore the errors if any occur
    Else
        ' Parse out the server list
        ichBegin = InStr(InStr(1, stConOut, "server="), stConOut, "{", vbBinaryCompare)
        stOut = Mid$(stConOut, ichBegin + 1)
        ichEnd = InStr(1, stOut, "}", vbBinaryCompare)
        StServerList = Left$(stOut, ichEnd - 1)
    End If

    ' Disconnect, free the connection handle, then
    ' free the environment handle.
    rc = SQLDisconnect(hdbc)
    rc = SQLFreeConnect(hdbc)
    rc = SQLFreeEnv(henv)
End Function

Private Sub Form_Load()
    MsgBox StServerList
End Sub