Połączenia danych programu Microsoft Excel - Zmień ciąg połączenia za pośrednictwem VBA

Question

Mam dość proste pytanie. Próbuję znaleźć sposób zmienić i zmienić ciąg połączenia dla istniejącego połączenia danych w skoroszycie programu excel za pomocą VBA (kod makra). Głównym powodem, dla którego próbuję to zrobić, jest znalezienie sposobu na monitowanie użytkownika, który otwiera skoroszyt, aby wprowadzić jego poświadczenia (nazwa użytkownika/hasło) lub pole wyboru Zaufane połączenie, które będzie używane w ciągu połączenia istniejących połączenia danych.

Teraz połączenia danych są zjechania przykładowego użytkownika, że ​​stworzył i który musi odejść w wersji produkcyjnej skoroszycie. Mam nadzieję, że ma to sens?

Czy to możliwe? Jeśli tak, czy mógłbyś podać mi przykładowy/przykładowy blok kodu? Byłbym wdzięczny za wszelkie sugestie w tym momencie.

Answer 1

To jest duplikatem Excel macro to change external data query connections - e.g. point from one database to another

Wygląda na to najważniejszą rzeczą jest przy użyciu ThisWorkbook.Connections w VBA.

Answer 2

Też miałem dokładnie to samo wymaganie i chociaż zduplikowane pytanie Excel macro to change external data query connections - e.g. point from one database to another było użyteczne, nadal musiałem go zmodyfikować, aby spełnić dokładnie powyższe wymagania. Pracowałem z określonym połączeniem, podczas gdy ta odpowiedź dotyczyła wielu połączeń. A więc zawarłem tutaj moje działania. Dziękuję @Rory za jego kod.

Również dzięki Luke Maxwell za jego funkcję na search a string for matching keywords.

Przypisanie tego podpisu do przycisku lub wywołanie go po otwarciu arkusza kalkulacyjnego.

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 

Funkcja GetConnectionString przechowuje ciąg połączenia, do którego wstawiasz swoją nazwę użytkownika i hasło. Ta dotyczy połączenia OLEDB i oczywiście różni się w zależności od wymagań Dostawcy.

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 

Ten kod wykonuje faktyczne aktualizowanie nazwanego połączenia za pomocą nowego ciągu połączenia (w przypadku połączenia 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 

I odwrotnie, można użyć tej funkcji, aby uzyskać dowolny bieżący ciąg połączenia.

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 

Używam tego sub, aby odświeżyć dane, gdy skoroszyt jest otwarty, ale sprawdza, czy nie ma nazwy użytkownika i hasła w ciągu połączenia przed wykonaniem odświeżenia. Właśnie nazywam ten sub z 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 

Oto funkcja ListSearch od Luke'a. Zwraca liczbę znalezionych dopasowań.

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 

Wreszcie, jeśli chcesz mieć możliwość usunięcia poświadczeń, po prostu przypisz ten przycisk do przycisku.

Sub RemoveCredentials() 
    Dim ConnectionString As String 
    ConnectionString = GetConnectionString("None", "None") 
    UpdateQueryConnectionString ConnectionString 
    MsgBox "Credentials have been removed.", vbOKOnly, "Your Credentials" 
End Sub 

Mam nadzieję, że pomoże to innej osobie takiej jak ja, która chciała szybko rozwiązać ten problem.