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

Question

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

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

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

Answer 1

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

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

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

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

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

这段代码完成了使用新连接字符串（对于 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

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

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

我在打开工作簿时使用这个子来刷新数据，但它会在刷新之前检查连接字符串中是否有用户名和密码。我只是从 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

这是来自 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

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

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

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