Microsoft Excel數據連接 - 通過VBA改變連接字符串

Question

我有一個相當直接的問題。我想通過VBA（宏代碼）找到一種方法來改變和更改Excel工作簿中現有數據連接的連接字符串。我嘗試這樣做的主要原因是找到一種方法來提示打開工作簿的用戶輸入他們的憑據（用戶名/密碼），或者在可用連接字符串中使用可信任連接的複選框數據連接。

眼下的數據連接流失，我創建和需要走在工作簿的量產版的樣本用戶。希望這是有道理的？

這可能嗎？如果是，請給我一個示例/示例代碼塊？在這一點上，我真的很感激任何建議。

Answer 1

這是Excel macro to change external data query connections - e.g. point from one database to another

重複看起來更主要的是使用VBA的ThisWorkbook.Connections。

Answer 2

我也有這個完全相同的要求，雖然重複問題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連接，根據提供商的要求，顯然是不同的。

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 

希望這可以幫助像我這樣的人，希望迅速解決這個問題。