Microsoft Excel 数据连接 - 通过 VBA 更改连接字符串

Microsoft Excel Data Connections - Alter Connection String through VBA

提问by SillyCoda

I have a fairly straightforward question. I am trying to find a way to alter and change a connection string for an existing data connection in an excel workbook through VBA (macro code). The main reason I am trying to do this is to find a way to prompt the user that opens up the workbook to enter their credentials (Username/Password) or have a checkbox for Trusted Connection that would be used in the Connection String of those existing data connections.

我有一个相当简单的问题。我正在尝试找到一种方法来通过 VBA（宏代码）更改和更改 Excel 工作簿中现有数据连接的连接字符串。我尝试这样做的主要原因是找到一种方法来提示打开工作簿的用户输入他们的凭据（用户名/密码）或有一个可信连接复选框，该复选框将用于那些现有的连接字符串中数据连接。

Right now the Data connections are running off a sample user that I created and that needs to go away in the production version of the workbook. Hope that makes sense?

现在，数据连接正在运行我创建的示例用户，该用户需要在工作簿的生产版本中消失。希望这是有道理的？

Is this possible? If yes, could you please give me a sample/example code block? I would really appreciate any suggestions at this point.

这可能吗？如果是，您能给我一个示例/示例代码块吗？在这一点上，我真的很感激任何建议。

回答by Dominic

I also had this exact same requirement and although the duplicate question Excel macro to change external data query connections - e.g. point from one database to anotherwas useful, I still had to modify it to meet the exact requirements above. I was working with a specific connection, while that answer targeted multiple connections. So, I've included my workings here. Thank you @Roryfor his code.

我也有这个完全相同的要求，尽管重复问题Excel 宏更改外部数据查询连接 - 例如从一个数据库指向另一个数据库很有用，但我仍然必须修改它以满足上述确切要求。我正在使用特定的连接，而该答案针对多个连接。所以，我把我的工作包括在这里。谢谢@Rory的代码。

Also thanks to Luke Maxwellfor his function to search a string for matching keywords.

还要感谢Luke Maxwell的功能来搜索匹配关键字的字符串。

Assign this sub to a button or call it when the spreadsheet is opened.

将此子分配给按钮或在打开电子表格时调用它。

Sub GetConnectionUserPassword()
  Dim Username As String, Password As String
  Dim ConnectionString As String
  Dim MsgTitle As String
  MsgTitle = "My Credentials"

  If vbOK = MsgBox("You will be asked for your username and password.", vbOKCancel, MsgTitle) Then
      Username = InputBox("Username", MsgTitle)
          If Username = "" Then GoTo Cancelled
          Password = InputBox("Password", MsgTitle)
          If Password = "" Then GoTo Cancelled
  Else
  GoTo Cancelled
  End If

    ConnectionString = GetConnectionString(Username, Password)
    ' MsgBox ConnectionString, vbOKOnly
    UpdateQueryConnectionString ConnectionString
    MsgBox "Credentials Updated", vbOKOnly, MsgTitle
  Exit Sub
Cancelled:
  MsgBox "Credentials have not been changed.", vbOKOnly, MsgTitle
End Sub

The GetConnectionString function stores the connection string that you insert your username and password into. This one is for an OLEDB connection and is obviously different depending on the requirements of the Provider.

GetConnectionString 函数存储您插入用户名和密码的连接字符串。这个是针对 OLEDB 连接的，根据 Provider 的要求明显不同。

Function GetConnectionString(Username As String, Password As String)

  Dim result As Variant

  result = "OLEDB;Provider=Your Provider;Data Source=SERVER;Initial Catalog=DATABASE" _
    & ";User ID=" & Username & ";Password=" & Password & _
    ";Persist Security Info=True;Extended Properties=" _
    & Chr(34) & "PORT=1706;LOG=ON;CASEINSENSITIVEFIND=ON;INCLUDECALCFIELDS=ON;" & Chr(34)

  ' MsgBox result, vbOKOnly
  GetConnectionString = result
End Function

This code does the job of actually updating a named connection with your new connection string (for an OLEDB connection).

此代码执行使用新连接字符串（对于 OLEDB 连接）实际更新命名连接的工作。

Sub UpdateQueryConnectionString(ConnectionString As String)

  Dim cn As WorkbookConnection
  Dim oledbCn As OLEDBConnection
  Set cn = ThisWorkbook.Connections("Your Connection Name")
  Set oledbCn = cn.OLEDBConnection
  oledbCn.Connection = ConnectionString

End Sub

Conversely, you can use this function to get whatever the current connection string is.

相反，您可以使用此函数获取当前连接字符串。

Function ConnectionString()

  Dim Temp As String
  Dim cn As WorkbookConnection
  Dim oledbCn As OLEDBConnection
  Set cn = ThisWorkbook.Connections("Your Connection Name")
  Set oledbCn = cn.OLEDBConnection
  Temp = oledbCn.Connection
  ConnectionString = Temp

End Function

I use this sub to refresh the data when the workbook is opened but it checks that there is a username and password in the connection string before doing the refresh. I just call this sub from the Private Sub Workbook_Open().

当工作簿打开时，我使用这个 sub 来刷新数据，但它会在刷新之前检查连接字符串中是否有用户名和密码。我只是从 Private Sub Workbook_Open() 调用这个子程序。

Sub RefreshData()
    Dim CurrentCredentials As String
    Sheets("Sheetname").Unprotect Password:="mypassword"
    CurrentCredentials = ConnectionString()
    If ListSearch(CurrentCredentials, "None", "") > 0 Then
        GetConnectionUserPassword
    End If
    Application.ScreenUpdating = False
    ActiveWorkbook.Connections("My Connection Name").Refresh
    Sheets("Sheetname").Protect _
    Password:="mypassword", _
    UserInterfaceOnly:=True, _
    AllowFiltering:=True, _
    AllowSorting:=True, _
    AllowUsingPivotTables:=True
End Sub

Here is the ListSearch function from Luke. It returns the number of matches it has found.

这是 Luke 的 ListSearch 函数。它返回它找到的匹配数。

Function ListSearch(text As String, wordlist As String, seperator As String, Optional caseSensitive As Boolean = False)
  Dim intMatches As Integer
  Dim res As Variant
  Dim arrWords() As String
  intMatches = 0
  arrWords = Split(wordlist, seperator)
  On Error Resume Next
  Err.Clear
  For Each word In arrWords
      If caseSensitive = False Then
          res = InStr(LCase(text), LCase(word))
      Else
          res = InStr(text, word)
      End If
      If res > 0 Then
          intMatches = intMatches + 1
      End If
  Next word
  ListSearch = intMatches
End Function

Finally, if you want to be able to remove the credentials, just assign this sub to a button.

最后，如果您希望能够删除凭据，只需将此子分配给一个按钮。

Sub RemoveCredentials()
  Dim ConnectionString As String
  ConnectionString = GetConnectionString("None", "None")
  UpdateQueryConnectionString ConnectionString
  MsgBox "Credentials have been removed.", vbOKOnly, "Your Credentials"
End Sub

Hope this helps another person like me that was looking to solve this problem quickly.

希望这可以帮助像我这样希望快速解决这个问题的人。