Microsoft Excel Data Connections - Alter Connection String through 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

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.