使用 Excel VBA 保持与 SQL 的开放连接

Question

我不确定我想知道的是否可能。但是我使用下面的代码打开和连接，然后我查询那个连接。

Public Sub OpenConnection(Datasource As String, DatabaseName As String)

    Set zConnection = New ADODB.Connection

    zConnection.ConnectionString = "Driver={SQL Server};" & _
                                   "Server=" & Datasource & ";" & _
                                   "Database=" & DatabaseName & ";" & _
                                   "Trusted_connection=yes;"
                               
    zConnection.Open
    
End Sub

zConnection 是一个全局变量

我在这里使用该连接来获取从 sql 代码返回的所有内容的记录集。

Public Function GetQueryRecordset() As ADODB.Recordset
    
    On Error GoTo FUNC_ERR
    
    Dim t As Integer: t = 1
    
GET_RST:
    Dim rst As New ADODB.Recordset
    
    Set rst.ActiveConnection = zConnection
    rst.Source = Me.Code
    rst.Open
    
    Set GetQueryRecordset = rst
    
FUNC_EXIT:
    Exit Function
    
FUNC_ERR:
    If Error = -2147217871 And t < 5 Then
        t = t + 1
        GoTo GET_RST
    Else
        MsgBox "Error Numuber: " & Err.Number & vbLf & Err.Description
        End
    End If
    
End Function

这很好用，但我正在考虑把它放在一个自定义函数中，我可以在 Excel 单元格中使用。问题是，每次打开连接都很慢。但我想知道是否有办法打开该连接，然后保持打开状态，然后在每次需要使用时抓取它。

基本上，我不知道如何持久保存和访问该连接。所以我可以一遍又一遍地使用它而无需重新连接。

---------编辑---------

我想解决一些问题。我最初将它们排除在外，因此我不会使问题复杂化。

所以我创建了一个名为 sqlClass 的自定义类。此类具有有用的功能，允许我将 SQL 代码放入对象中，在调试器中以可读的方式显示代码，还可以打开和关闭连接，放入连接到 sql 查询的表，或返回记录集与该数据。所以说它是一个全局变量是不准确的，但它是一个类变量，所以在该对象实例中采取的任何操作都可以使用该对象建立的任何连接。

现在我想在单元函数中使用它，我想减少打开和关闭连接的次数。我实际上在想我会将代码放在工作簿打开和工作簿关闭中，以处理打开和关闭连接。

听起来我假设Set zConnection = New ADOBD.Connection 是实际连接错误。我认为每个New ADOBD.Connection 都是连接，但从我从 cmets 那里听到的是 ADOBD.Connection 更像是连接所在位置的“桥梁”，当我创建New 时，这只会使新桥不是全新的连接。如果我在这方面有误，请随时纠正我，我将在接下来对其进行测试，并在必要时进行另一次编辑。

---------编辑 2---------

这是我制作的完整的sqlClass自定义类。

Option Explicit

'***********************************************************************************
'SqlClass helps hold SQL code and gives convientent functions to call that SQL code.
'Requires Reference: Microsoft ActiveX Data Objects x.x Library
'***********************************************************************************

Private zLines As New Collection
Private zConnection As ADODB.Connection

Public Sub Add(ByVal sqlLine As String)

'**************************************************************************************
'    DESCRIPTION:
'       This will add a line of SQL as a string to the collection
'
'    INPUT VARS:
'       sqlLine: The string of SQL code to add to the bottom of the collection
'**************************************************************************************
    
    Dim addSql As String: addSql = sqlLine
    'Makes sure that the right is always a space since this will not hold SQL code with new paragraphs.
    If Right(addSql, 1) <> " " Then
        addSql = addSql & " "
    End If
    
    zLines.Add addSql

End Sub

Public Sub Blank()

'**************************************************************************************
'    DESCRIPTION:
'       This will add a element to the collection that contains a vbnullstring. This
'       only helps when trying to view the code in a readable form (printsql)
'
'    INPUT VARS:
'       n/a
'**************************************************************************************

    zLines.Add vbNullString
    
End Sub

Public Sub Clear()

'**************************************************************************************
'    DESCRIPTION:
'       This will clear all code from the collection
'
'    INPUT VARS:
'       n/a
'**************************************************************************************
    
    Set zLines = New Collection

End Sub

Public Function Code() As String

'**************************************************************************************
'    DESCRIPTION:
'       This returns a string showing the full SQL code held within this Class instance.
'       NO PARAGRAPHS SHOWN
'
'    INPUT VARS:
'       n/a
'**************************************************************************************
    
    Dim str As String

    Dim i As Integer
    For i = 1 To zLines.Count
        str = str & zLines(i)
    Next
    
    'Remove double spaces, to reduce size of string
    Do Until InStr(str, "  ") = 0
        str = Replace(str, "  ", " ")
    Loop
    
    'Excel can only send a query to the SQL Server of 32,767 or less, this will throw an error on purpose so you know this is what cause the issue.
    If Len(str) > 32767 Then
        Dim xxx As Integer: xxx = 1000000 'errors on purpose
    End If

    Code = str

End Function

Public Sub PrintSql()

'**************************************************************************************
'    DESCRIPTION:
'       Prints SQL code in the Immediate Window, this will show each line as a new line
'       For debug purposes
'
'    INPUT VARS:
'       n/a
'**************************************************************************************
    
    Dim i As Integer
    For i = 1 To zLines.Count
        Debug.Print zLines(i)
    Next

End Sub

Public Sub CreateQueryTable(ws As Worksheet, Datasource As String, initialCatalog As String)

'**************************************************************************************
'    DESCRIPTION:
'       This submits the query to the SQL server and makes the results a table on the
'       selected worksheet
'
'    INPUT VARS:
'       ws:             The worksheet that gets the table
'       DataSource:     The address of the SQL Server
'       initialCatalog: This seems to be used with error message, I use it to say which database inside the server I'm pulling from.
'**************************************************************************************
    
    Dim wkStation As String: wkStation = VBA.Environ("computername")
    
    'Values are largely default, look up this function to learn more about the inputs. Each variable sent is a new element in the array.
    Dim qryTbl As QueryTable: Set qryTbl = ws.ListObjects.Add(SourceType:=xlSrcExternal, _
                                                              Source:=Array("OLEDB;", _
                                                                            "Provider=SQLOLEDB.1;", _
                                                                            "Integrated Security=SSPI;", _
                                                                            "Persist Security Info=True;", _
                                                                            "Data Source=" & Datasource & ";", _
                                                                            "Use Procedure for Prepare=1;", _
                                                                            "Auto Translate=True;", _
                                                                            "Packet Size=4096;", _
                                                                            "Workstation ID=" & wkStation & ";", _
                                                                            "Use Encryption for Data=False;", _
                                                                            "Tag with column collation when possible=False;", _
                                                                            "Initial Catalog=" & initialCatalog), _
                                                              Destination:=ws.Range("A1")).QueryTable
                                                              
    'These are also largely default
    'Refresh BackgroundQerry = false means that the table will not update everytime the workbook is opened or
    'something changes to trigger a refresh.
    'This is ideal if you want data from exactly when it was run, not just always up to date.
    With qryTbl
        .CommandType = xlCmdSql
        .CommandText = Me.Code
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
    End With

End Sub

Public Sub OpenConnection(Datasource As String, DatabaseName As String)
    
'**************************************************************************************
'   DESCRIPTION:
'       Opens a connection to the SQL server and database to have Code run off of it
'
'   INPUT VARS:
'       DataSource:   The address of the SQL Server
'       DatabaseName: The database name within the server
'**************************************************************************************

    If zConnection Is Nothing Then Set zConnection = New ADODB.Connection

    zConnection.ConnectionString = "Driver={SQL Server};" & _
                                   "Server=" & Datasource & ";" & _
                                   "Database=" & DatabaseName & ";" & _
                                   "Trusted_connection=yes;"
                                   'Driver defines what type of source it is connecting to
                                   'Server is the address of the SQL
                                   'Database is which database within that Server
                                   'Trusted_connection means use the user that is logged into this PC
                               
    zConnection.Open
    
End Sub

Public Sub CheckConnection()
    
'**************************************************************************************
'   DESCRIPTION:
'       Checks if the connection object exists and creates it if not. Also checks if the
'       database is conenected, if not connects it.
'
'   INPUT VARS:
'       n/a
'**************************************************************************************

    If zConnection Is Nothing Then Set zConnection = New ADODB.Connection
    
    If zConnection.State <> adStateOpen Then
        OpenConnection Datasource:="xxxxxxx", _
                       DatabaseName:="xxxxxxxx"
    End If

End Sub

Public Sub CloseConnection()
    
'**************************************************************************************
'   DESCRIPTION:
'       Closes the connection made by OpenConnection
'
'   INPUT VARS:
'       n/a
'**************************************************************************************

    zConnection.Close
    
End Sub

Public Function GetQueryRecordset() As ADODB.Recordset
    
'**************************************************************************************
'   DESCRIPTION:
'       This will create an ADODB.recordset from the SQL code and server and return it
'       as a recordset object.
'
'   INPUT VARS:
'       n/a
'**************************************************************************************
    
    On Error GoTo FUNC_ERR
    
    Dim t As Integer: t = 1
    
GET_RST:
    Dim rst As New ADODB.Recordset
    CheckConnection
    Set rst.ActiveConnection = zConnection
    rst.Source = Me.Code
    rst.Open
    
    Set GetQueryRecordset = rst
    
FUNC_EXIT:
    Exit Function

FUNC_ERR:
    If Error = -2147217871 And t < 5 Then
        t = t + 1
        GoTo GET_RST
    Else
        MsgBox "Error Numuber: " & Err.Number & vbLf & Err.Description
        End
    End If
    
End Function

这是我制作的客户单元功能：

Public Function GET_JDE_PN(custPN As String) As String

    Application.EnableEvents = False
    Dim sql As New sqlClass
    
    With sql
        .Add "SELECT DISTINCT"
        .Add "    Field0"
        .Add "FROM"
        .Add "    [Table_Name]"
        .Add "WHERE"
        .Add "    Field1= '" & custPN & "'"
        .Add "    OR"
        .Add "    Field2= '" & custPN & "'"
    End With
    
    Dim rst As ADODB.Recordset: Set rst = sql.GetQueryRecordset
    
    Dim i As Integer
    Do Until rst.EOF
        i = i + 1
        If i = 2 Then
            GET_JDE_PN = "**Multiple Returns**"
            Exit Function
        End If
        rst.MoveNext
    Loop
    
    rst.MoveFirst
    GET_JDE_PN = rst(0)
    Application.EnableEvents = True

End Function

这里是它在工作簿中使用的屏幕截图：

这确实有效，但每次连接数据库需要 3-5 秒。而且我真的很想让它只连接一次，然后重用现有的连接。我不确定是否需要更多代码来告诉它保持打开状态，或者问题是否出在服务器端。我想从{SQL Server} 更改驱动程序，但到目前为止我还没有找到适合我的谷歌搜索的替代方案。

Answer 1

下面的非常基本的示例。如果您需要管理 >1 个连接，您将需要更复杂的东西。

Dim cnn As ADODB.Connection

Sub CheckConnection(Datasource As String, DatabaseName As String)
    If cnn Is Nothing Then Set cnn = New ADODB.Connection
    If cnn.State <> adStateOpen Then
        cnn.ConnectionString = "Driver={SQL Server};" & _
                               "Server=" & Datasource & ";" & _
                               "Database=" & DatabaseName & ";" & _
                               "Trusted_connection=yes;"
        cnn.Open
    End If
End Sub

Function LookItUp(v)
    Dim rst As New ADODB.Recordset
    CheckConnection "dsNameHere", "DBName here" 'open connection if not already open
    rst.Open "select uname from users where id = " & v, cnn 'use query parameters though...
    If Not rst.EOF Then
        LookItUp = rst.Fields("uname").Value
    Else
        LookItUp = "No such name"
    End If
End Function