Option Explicit

Private Const SQL_HANDLE_DBC As Integer =  2 
Private Const SQL_SUCCESS As Integer =  0 
Private Const SQL_SUCCESS_WITH_INFO As Integer =  1 

Private Declare Function SQLAllocEnv Lib "odbc32.dll" (ByRef phenv As Long) As Integer
Private Declare Function SQLAllocHandle Lib "odbc32.dll" (ByVal hType As Integer, ByVal hInput As Long, ByRef phOutput 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, ByRef pcbconnstrout As Integer) As Integer
Private Declare Function SQLDisconnect Lib "odbc32.dll" (ByVal hDbc As Long) 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 GetSQLServersList() As String
  Const ODBC_ERR_MSG = "Ошибка при вызове ODBC. Пожалуйста, установите последнюю версию MDAC"

  Dim retCode As Integer
  Dim hDbc As Long
  Dim hEnv As Long
  Dim strCon As String
  Dim strOutCon As String
  Dim intConLenOut As Integer
  Dim lngPz1 As Long
  Dim lngPz2 As Long
  
  strCon = "DRIVER={SQL Server};"
  strOutCon = Space$( 10000 )
  retCode = SQLAllocEnv(hEnv)
  If retCode <> SQL_SUCCESS And retCode <> SQL_SUCCESS_WITH_INFO Then
     MsgBox ODBC_ERR_MSG
     Exit Function
  End If
  retCode = SQLAllocHandle(SQL_HANDLE_DBC, hEnv, hDbc)
  If retCode <> SQL_SUCCESS And retCode <> SQL_SUCCESS_WITH_INFO Then
     MsgBox ODBC_ERR_MSG
     Exit Function
  End If
  retCode = SQLBrowseConnect(hDbc, strCon, Len(strCon), strOutCon, Len(strOutCon) +  2 , intConLenOut)
  strOutCon = Left$(strOutCon, intConLenOut)
  lngPz1 = InStr(strOutCon, "Server={")
  If lngPz1 >  0  Then
     lngPz1 = lngPz1 +  8 
     lngPz2 = InStr(strOutCon, "}")
     If lngPz2 > lngPz1 Then
        GetSQLServersList = Mid$(strOutCon, lngPz1, lngPz2 - lngPz1)
     End If
  End If
  retCode = SQLDisconnect(hDbc)
  retCode = SQLFreeConnect(hDbc)
  retCode = SQLFreeEnv(hEnv)
End Function