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

我也有完全相同的要求,虽然重复的问题 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.",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

我在打开工作簿时使用此子命令刷新数据但在执行刷新之前检查连接字符串中是否有用户名和密码.我只是从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.","Your Credentials"
End Sub

希望这能帮助像我这样的其他人快速解决这个问题.