Макрос Excel для изменения внешних соединений запроса данных - например, указание из одной базы данных в другую

Question

Я ищу макрос / VBS, чтобы обновить все внешние соединения запроса данных, чтобы указать на другой сервер или базу данных. Это трудно сделать вручную, и в версиях Excel до 2007 года иногда кажется невозможным сделать это вручную.

У кого-нибудь есть образец? Я вижу, что существуют разные типы соединений 'OLEDB' и 'ODBC', так что я думаю, мне нужно иметь дело с разными форматами строк соединений?

Answer 1

Я закончил тем, что написал следующее, которое запрашивает сведения о соединении, создает строку соединения, а затем обновляет все запросы внешних данных, чтобы использовать эту строку соединения.

'''' Prompts for connection details and updates all the external data connections in the workbook accordingly.
'''' Changes all connections to use ODBC connections instead of OLEDB connections.
'''' Could be modified to use OLEDB if there's a need for that.
Sub PromptAndUpdateAllConnections()
    Dim Server As String, Database As String, IntegratedSecurity As Boolean, UserId As String, Password As String, ApplicationName As String
    Dim ConnectionString As String
    Dim MsgTitle As String
    MsgTitle = "Connection Update"

    If vbOK = MsgBox("You will be asked for information to connect to the database, and this spreadsheet will be updated to connect using those details.", vbOKCancel, MsgTitle) Then
        Server = InputBox("Database server or alias and instance name, e.g. 'LONDB01' or 'LONDB01\INST2'", MsgTitle)
        If Server = "" Then GoTo Cancelled
        Database = InputBox("Database name", MsgTitle, "a default value")
        If Database = "" Then GoTo Cancelled
        IntegratedSecurity = (vbYes = MsgBox("Integrated Security? (i.e. has your windows account been given access to connect to the database)", vbYesNo, MsgTitle))
        If Not IntegratedSecurity Then
            UserId = InputBox("User Id", MsgTitle)
            If UserId = "" Then GoTo Cancelled
            Password = InputBox("Password", MsgTitle)
            If Password = "" Then GoTo Cancelled
        End If
        ApplicationName = "Excel Reporting"

        ConnectionString = GetConnectionString(Server, Database, IntegratedSecurity, UserId, Password, ApplicationName)
        UpdateAllQueryTableConnections ConnectionString
        MsgBox "Spreadsheet Updated", vbOKOnly, MsgTitle
    End If
    Exit Sub
Cancelled:
    MsgBox "Spreadsheet not updated", vbOKOnly, MsgTitle
End Sub

'''' Generates an ODBC connection string from the given details.
Function GetConnectionString(Server As String, Database As String, IntegratedSecurity As Boolean, _
    UserId As String, Password As String, ApplicationName As String)

    Dim result As String

    If IntegratedSecurity Then
        result = "ODBC;DRIVER=SQL Server;SERVER=" & Server & ";DATABASE=" & Database _
                & ";Trusted_Connection=Yes;APP=" & ApplicationName & ";"
    Else
        result = "ODBC;DRIVER=SQL Server;SERVER=" & Server & ";DATABASE=" & Database _
                & ";UID=" & UserId & ";PWD=" & Password & ";APP=" & ApplicationName & ";"
    End If

    RM_GetConnectionString = result
End Function

'''' Sets all external data connection strings to the given value (regardless of whether they're
'''' currently ODBC or OLEDB connections. Appears to change type successfully.
Sub UpdateAllQueryTableConnections(ConnectionString As String)
    Dim w As Worksheet, qt As QueryTable
    Dim cn As WorkbookConnection
    Dim odbcCn As ODBCConnection, oledbCn As OLEDBConnection
    For Each cn In ThisWorkbook.Connections
        If cn.Type = xlConnectionTypeODBC Then
            Set odbcCn = cn.ODBCConnection
            odbcCn.SavePassword = True
            odbcCn.Connection = ConnectionString
        ElseIf cn.Type = xlConnectionTypeOLEDB Then
            Set oledbCn = cn.OLEDBConnection
            oledbCn.SavePassword = True
            oledbCn.Connection = ConnectionString
        End If
    Next
End Sub

Answer 2

Формат строки подключения в значительной степени не имеет значения, так как Excel передаст его поставщикам данных.

Обновите одну таблицу запросов вручную, затем сделайте что-то вроде этого:

dim w as worksheet, q as querytable

for each w in thisworkbook.worksheets
  for each q in w.querytables
    q.connection = SampleSheet.querytables("PreparedQueryTable").connection
  next
next

Answer 3

Даже мы можем обновить конкретное соединение, и оно, в свою очередь, обновит все связанные с ним центры.

Для этого кода я создал слайсер из таблицы, представленной в Excel:

Этот код для слайсера из БД:

Sub UpdateConnection()
    Dim ServerName As String
    Dim ConnectionString As String
    Dim DatabaseNameCount As Integer

    DatabaseNameCount = ActiveWorkbook.SlicerCaches("Slicer_Name").VisibleSlicerItems.Count

    If DatabaseNameCount = 1 Then
        ServerName = ActiveWorkbook.SlicerCaches("Slicer_Name").VisibleSlicerItems.Item(1).Name
        ConnectionString = GetConnectionString(ServerName)
        UpdateAllQueryTableConnections ConnectionString
    Else
        MsgBox "Please Select One Value", vbOKOnly, "Slicer Info"
    End If
End Sub

Этот код для слайсера, созданного из таблицы Excel, представленной в той же книге:

Sub UpdateConnection()
        Dim ServerName As String
        Dim ServerNameRaw As String
        Dim CubeName As String
        Dim CubeNameRaw As String
        Dim ConnectionString As String

        ServerNameRaw = ActiveWorkbook.SlicerCaches("Slicer_ServerName").VisibleSlicerItemsList(1)
        ServerName = Replace(Split(ServerNameRaw, "[")(3), "]", "")

        CubeNameRaw = ActiveWorkbook.SlicerCaches("Slicer_CubeName").VisibleSlicerItemsList(1)
        CubeName = Replace(Split(CubeNameRaw, "[")(3), "]", "")

        If CubeName = "All" Or ServerName = "All" Then
            MsgBox "Please Select One Cube and Server Name", vbOKOnly, "Slicer Info"
        Else
            ConnectionString = GetConnectionString(ServerName, CubeName)
            UpdateAllQueryTableConnections ConnectionString, CubeName
        End If
    End Sub

Общий код для создания соединения и обновления соединения для желаемого начального каталога:

Function GetConnectionString(ServerName As String, CubeName As String)
        Dim result As String
        result = "OLEDB;Provider=MSOLAP.5;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=" & CubeName & ";Data Source=" & ServerName & ";MDX Compatibility=1;Safety Options=2;MDX Missing Member Mode=Error;Update Isolation Level=2"
        '"OLEDB;Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=" & CubeName & ";Data Source=" & ServerName & ";Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Use Encryption for Data=False;Tag with column collation when possible=False"
        GetConnectionString = result
    End Function

    Sub UpdateAllQueryTableConnections(ConnectionString As String, CubeName As String)
        Dim cn As WorkbookConnection
        Dim oledbCn As OLEDBConnection
        Dim Count As Integer, i As Integer
        Dim DBName As String
        DBName = "Initial Catalog=" + CubeName

        Count = 0
        For Each cn In ThisWorkbook.Connections
            If cn.Name = "ThisWorkbookDataModel" Then
                Exit For
            End If

            oTmp = Split(cn.OLEDBConnection.Connection, ";")
            For i = 0 To UBound(oTmp) - 1
                If InStr(1, oTmp(i), DBName, vbTextCompare) = 1 Then
                    Set oledbCn = cn.OLEDBConnection
                    oledbCn.SavePassword = True
                    oledbCn.Connection = ConnectionString
                    Count = Count + 1
                End If
            Next
        Next

        If Count = 0 Then
             MsgBox "Nothing to update", vbOKOnly, "Update Connection"
        ElseIf Count > 0 Then
            MsgBox "Connection Updated Successfully", vbOKOnly, "Update Connection"
        End If
    End Sub

Answer 4

oledbCn.Connection = ConnectionString вызывает сбой в Excel 2013