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

Question

我有一个非常简单的问题。我正在尝试通过VBA（宏代码）修改和更改Excel工作簿中现有数据连接的连接字符串，主要原因是找到一种提示打开工作簿的用户输入其凭据（用户名/密码）或在这些现有数据连接的连接字符串中使用“受信任的连接”复选框的方法。

现在，数据连接正在运行一个我创建的示例用户，而这需要在工作簿的生产版本中消失。希望这样说得通？

这可能吗？如果是，请给我一个样本/示例代码块。在此时段内，我将非常感激任何建议。

- pranavrules

---

http://support.microsoft.com/kb/257819 可能是一个好的起点。 - Skip Intro

我们不仅仅提供代码...一个建议是使用workbook_open子程序来显示一个用户表单或输入框，以请求凭据。将其保存到全局变量中，然后在连接字符串中使用它们。 - user2140173

@mehow 我明白了，我从来没有要求直接的解决方案。我是在寻找类似情况的例子。如果那冒犯了你，我很抱歉。其次，我想做你提到的事情，但那不是我现在遇到的问题。我正在寻找一种方法来编辑我已经设置好的数据连接的现有连接字符串（请参见上面的屏幕截图）。希望这会有所帮助？非常感谢， Pranav - pranavrules

@SillyCoda，你需要决定是使用Excel UI还是VBA。你的标题说“通过”VBA，但你展示了UI的截图。除了你的决定之外，与UI交互对你来说可能太高级了，所以我强烈建议使用VBA。 - user2140173

我已经通过UI设置了大约10个不同的连接。我们现在意识到，我们需要用户登录才能通过ODBC访问数据。因此，为了在幕后完成这项工作，我想知道是否有一种方法可以修改现有的ODBC连接字符串，以更改通过VBA代码从UI登录使用的用户凭据。谢谢。 - pranavrules

Answer 1

我也有完全相同的需求，尽管重复的问题 Excel宏以更改外部数据查询连接——例如从一个数据库指向另一个数据库 很有用，但我仍然需要修改它以满足上述精确要求。我在使用特定的连接，而那个答案则针对多个连接。因此，我在这里包含了我的工作内容。感谢@Rory提供的代码。

还要感谢Luke Maxwell提供的函数，用于在Excel中搜索匹配关键词的字符串列表。

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

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连接的，显然根据提供程序的要求会有所不同。

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

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

希望这能帮助像我一样迫切需要解决此问题的人。

- Dominic