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

Question

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

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

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

Answer 1

我也有这个完全相同的要求，尽管重复的问题 Excel macro to change external data query connections - e.g. point from one database to another很有用，我仍然需要修改它以满足上面的确切要求。我正在使用特定的连接，而该答案针对的是多个连接。所以，我把我的作品放在这里。谢谢@Rory获取他的代码。

同时感谢Luke Maxwell为他的职能search a string for matching keywords .

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

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 RemoveCredentials()
  Dim ConnectionString As String
  ConnectionString = GetConnectionString("None", "None")
  UpdateQueryConnectionString ConnectionString
  MsgBox "Credentials have been removed.", vbOKOnly, "Your Credentials"
End Sub

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