VB6通过API函数获得局域网SQLserver服务器列表

最新推荐文章于 2017-09-18 17:00:56 发布

runnerdu

最新推荐文章于 2017-09-18 17:00:56 发布

阅读量793

点赞数 2

文章标签： sqlserver 服务器 vb api integer sql

本文链接：https://blog.youkuaiyun.com/runnerdu/article/details/4894626

版权

本文介绍了一个VBScript程序，该程序可以获取局域网内可用的SQL Server服务器列表，并填充到指定的组合框中。通过使用ODBC API进行数据库连接配置，实现了对SQL Server服务器的有效扫描。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

讲以下代码放入模块中，便可调用。

'###########################################################################

Global Const SQL_NULL_HANDLE = 0
Global Const SQL_HANDLE_ENV = 1
Global Const SQL_HANDLE_DBC = 2
Global Const SQL_HANDLE_STMT = 3
Global Const SQL_HANDLE_DESC = 4

Global Const SQL_FETCH_NEXT = 1
Global Const SQL_FETCH_FIRST = 2

Global Const SQL_SUCCESS = 0
Global Const SQL_SUCCESS_WITH_INFO = 1
Global Const SQL_NO_DATA = 100
Global Const SQL_ERROR = (-1)
Global Const SQL_INVALID_HANDLE = (-2)
Global Const SQL_STILL_EXECUTING = 2
Global Const SQL_NEED_DATA = 99

Global Const SQL_ATTR_ODBC_VERSION = 200
Global Const SQL_OV_ODBC3 = 3
Global Const SQL_IS_INTEGER = -6
Global Const SQL_C_SLONG = -16

Private Const DEFAULT_RESULT_SIZE As Integer = 1024
Private Const SQL_DRIVER_STR As String = "DRIVER=SQL SERVER"

Private Declare Function SQLAllocHandle Lib "odbc32.dll" (ByVal hType As Integer, ByVal inputHandle As Long, ByRef outputHandle As Long) As Integer
Private Declare Function SQLSetEnvAttr Lib "odbc32.dll" (ByVal henv As Long, ByVal attributes As Long, ByVal valuePtr As Long, ByVal strLength As Long) As Integer
Private Declare Function SQLFreeHandle Lib "odbc32.dll" (ByVal hType As Integer, ByVal handle As Long) As Integer
Private Declare Function SQLBrowseConnect Lib "odbc32.dll" (ByVal hconn As Long, ByVal inString As Long, ByVal inStringLength As Integer, ByVal outString As Long, ByVal outStringLength As Integer, ByRef outLengthNeeded As Integer) As Integer

'获得局域网内的SQLserver服务器名称
Public Function GetServers(ByVal combo_box As ComboBox) As Long
        Dim list As String
        Dim henv As Long
        Dim hconn As Long
        Dim inString() As Byte '* SQL_DRIVER_STR
        Dim outString() As Byte '* DEFAULT_RESULT_SIZE
        Dim inPtr As Long
        Dim outPtr As Long
        Dim inStringLength As Integer
        Dim lenNeeded As Integer
        Dim i, j, k, myArray

    i = StrConv(SQL_DRIVER_STR, vbFromUnicode) '将字符串由 Unicode 转成系统的缺省码页
    inStringLength = LenB(i) 'MsgBox inStringLength
    ReDim inString(inStringLength): ReDim outString(DEFAULT_RESULT_SIZE)
    inString = i ': MsgBox inString

    If (SQL_SUCCESS = SQLAllocHandle(SQL_HANDLE_ENV, SQL_NULL_HANDLE, henv)) Then
        If (SQL_SUCCESS = SQLSetEnvAttr(henv, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC3, SQL_IS_INTEGER)) Then
            If (SQL_SUCCESS = SQLAllocHandle(SQL_HANDLE_DBC, henv, hconn)) Then
                inPtr = VarPtr(inString(0)): outPtr = VarPtr(outString(0))
                If (SQL_NEED_DATA = SQLBrowseConnect(hconn, inPtr, inStringLength, outPtr, DEFAULT_RESULT_SIZE, lenNeeded)) Then
                    If (DEFAULT_RESULT_SIZE < lenNeeded) Then
                        'MsgBox DEFAULT_RESULT_SIZE & "<" & lenNeeded
                        ReDim outString(lenNeeded): outPtr = VarPtr(outString(0))
                        If (SQL_NEED_DATA <> SQLBrowseConnect(hconn, inPtr, inStringLength, outPtr, lenNeeded, lenNeeded)) Then
                            MsgBox "Unabled to acquire SQL Servers from ODBC driver.11"
                        End If
                    End If

                    list = StrConv(outString, vbUnicode) ':    MsgBox list

                Else
                    MsgBox "Unabled to acquire SQL Servers from ODBC driver."
                End If
            End If
        End If
    End If

    If (hconn <> 0) Then
        i = SQLFreeHandle(SQL_HANDLE_DBC, hconn)
    End If
    If (henv <> 0) Then
        i = SQLFreeHandle(SQL_HANDLE_ENV, henv)
    End If

    j = InStr(1, list, "{", vbTextCompare) + 1
    k = InStrRev(list, "}") - j
    With combo_box
        If (j > 0) And (k > 0) Then
            list = Mid(list, j, k) ': MsgBox list
            myArray = Split(list, ",", -1, vbTextCompare)
            .Clear
            For i = 0 To UBound(myArray)
                .AddItem myArray(i)
            Next i
            .Text = .list(0)
            GetServers = 1
        Else
            GetServers = 0
            .AddItem "No avilibale SQL Servers"
            .Text = .list(0)
        End If
    End With
End Function