Microsoft Excel Data Connections - Alter Connection String through VBA - vba

Question

I have a fairly straightforward question. I am trying to find a way to alter and change a connection string for an existing data connection in an excel workbook through VBA (macro code). The main reason I am trying to do this is to find a way to prompt the user that opens up the workbook to enter their credentials (Username/Password) or have a checkbox for Trusted Connection that would be used in the Connection String of those existing data connections.
Right now the Data connections are running off a sample user that I created and that needs to go away in the production version of the workbook. Hope that makes sense?
Is this possible? If yes, could you please give me a sample/example code block? I would really appreciate any suggestions at this point.

Answer 1

I also had this exact same requirement and although the duplicate question Excel macro to change external data query connections - e.g. point from one database to another was useful, I still had to modify it to meet the exact requirements above. I was working with a specific connection, while that answer targeted multiple connections. So, I've included my workings here. Thank you #Rory for his code.
Also thanks to Luke Maxwell for his function to search a string for matching keywords.
Assign this sub to a button or call it when the spreadsheet is opened.
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
The GetConnectionString function stores the connection string that you insert your username and password into. This one is for an OLEDB connection and is obviously different depending on the requirements of the 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
This code does the job of actually updating a named connection with your new connection string (for an OLEDB connection).
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
Conversely, you can use this function to get whatever the current connection string is.
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
I use this sub to refresh the data when the workbook is opened but it checks that there is a username and password in the connection string before doing the refresh. I just call this sub from the 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
Here is the ListSearch function from Luke. It returns the number of matches it has found.
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
Finally, if you want to be able to remove the credentials, just assign this sub to a button.
Sub RemoveCredentials()
Dim ConnectionString As String
ConnectionString = GetConnectionString("None", "None")
UpdateQueryConnectionString ConnectionString
MsgBox "Credentials have been removed.", vbOKOnly, "Your Credentials"
End Sub
Hope this helps another person like me that was looking to solve this problem quickly.