Kết nối dữ liệu Microsoft Excel - Thay đổi chuỗi kết nối qua VBA

Question

Tôi có một câu hỏi khá đơn giản. Tôi đang cố gắng tìm một cách để thay đổi và thay đổi một chuỗi kết nối cho một kết nối dữ liệu hiện có trong một bảng tính excel thông qua VBA (mã vĩ mô). Lý do chính mà tôi đang cố gắng làm là tìm cách nhắc người dùng mở sổ làm việc để nhập thông tin đăng nhập của họ (Tên người dùng/Mật khẩu) hoặc có hộp kiểm cho Kết nối tin cậy sẽ được sử dụng trong Chuỗi kết nối của những người hiện có kết nối dữ liệu.

Ngay bây giờ các kết nối dữ liệu đang chạy ra khỏi một người dùng mẫu mà tôi tạo ra và rằng cần phải biến mất trong phiên bản sản xuất của bảng tính. Hy vọng rằng có ý nghĩa?

Điều này có khả thi không? Nếu có, bạn có thể vui lòng cho tôi mẫu mã mẫu/ví dụ không? Tôi thực sự sẽ đánh giá cao bất kỳ đề xuất vào thời điểm này.

Answer 1

Đây là một bản sao của Excel macro to change external data query connections - e.g. point from one database to another

Dường như điều chủ yếu là sử dụng ThisWorkbook.Connections trong VBA.

Answer 2

Tôi cũng có yêu cầu tương tự chính xác này và mặc dù câu hỏi trùng lặp Excel macro to change external data query connections - e.g. point from one database to another hữu ích, tôi vẫn phải sửa đổi nó để đáp ứng các yêu cầu chính xác ở trên. Tôi đã làm việc với một kết nối cụ thể, trong khi đó câu trả lời được nhắm mục tiêu nhiều kết nối. Vì vậy, tôi đã bao gồm các hoạt động của tôi ở đây. Cảm ơn bạn @Rory cho mã của anh ấy.

Cũng nhờ Luke Maxwell cho chức năng của mình là search a string for matching keywords.

Gán phụ này cho nút hoặc gọi nó khi bảng tính được mở.

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 

Chức năng GetConnectionString lưu chuỗi kết nối bạn chèn tên người dùng và mật khẩu vào. Điều này là dành cho một kết nối OLEDB và rõ ràng là khác nhau tùy thuộc vào yêu cầu của nhà cung cấp.

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 

Mã này thực sự cập nhật kết nối có tên với chuỗi kết nối mới của bạn (cho kết nối 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 

Ngược lại, bạn có thể sử dụng chức năng này để nhận bất kỳ chuỗi kết nối hiện tại nào.

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 

Tôi sử dụng phụ này để làm mới dữ liệu khi sổ làm việc được mở nhưng nó kiểm tra có tên người dùng và mật khẩu trong chuỗi kết nối trước khi thực hiện làm mới. Tôi chỉ gọi sub này từ 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 

Đây là chức năng ListSearch từ Luke. Nó trả về số lượng các kết quả phù hợp mà nó đã tìm thấy.

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 

Cuối cùng, nếu bạn muốn có thể xóa thông tin đăng nhập, chỉ cần gán phụ này cho nút.

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

Hy vọng điều này sẽ giúp một người khác như tôi đang tìm cách giải quyết vấn đề này nhanh chóng.