Изменить строку подключения Excel с помощью VB .NET

Это довольно распространено, и существует существующий код, который вы сможете изменить в соответствии со своими потребностями:

Кстати, вы будете использовать Excel VBA, а не VB .Net.

Private Sub Workbook_Open()

Dim conn As WorkbookConnection
Dim sOldConnection As String, sNewConnection As String
Dim sOldPath As String
Dim sNewPath As String
Dim sLength As Integer
Dim sOldPath1 As String
Dim intDsnLen As Integer
Dim intDsnStart As Integer
Dim intDsnEnd As Integer

'I first check if there is a folder called "Analysis" as this is what we generally use to store our analysis tools.
If InStr(1, Application.ThisWorkbook.Path, "Analysis") > 0 Then
'I then remove that from the path that I require
sLength = Len(Application.ThisWorkbook.Path) - 9
'I set the new path to the workbook path minus the analysis folder and the "\"
sNewPath = Left(Application.ThisWorkbook.Path, sLength)
Else
'If the folder doesn't exist, I then set the new part to the excel workbooks path
sLength = Len(Application.ThisWorkbook.Path)
sNewPath = Left(Application.ThisWorkbook.Path, sLength)
End If

For Each conn In ActiveWorkbook.Connections
With conn
If .Type = xlConnectionTypeODBC Then
sOldConnection = .ODBCConnection.Connection

'I used these steps to find my specific connection string....not the best way to use it but I was getting
'a bit irritated with the fact that instr doesn't remove all that I don't require.
'In my case, this will always work...may not for others but you can always play around to find your best fit.
intDsnStart = InStr(1, sOldConnection, "DBQ") + 3
intDsnEnd = InStr(intDsnStart, sOldConnection, "Reports.MDB")
intDsnLen = intDsnEnd - intDsnStart
'I get my old path in my old connection..I need this specifically as I want to replace it
sOldPath = Mid(sOldConnection, intDsnStart + 1, intDsnLen - 2)

'Here, I replace the old path with the new path, irrespective of whether it is the same or not in my new connection
sNewConnection = Replace(sOldConnection, _
sOldPath, sNewPath, Compare:=vbTextCompare)
'I set the odbc connection to my new built connection and then refresh
.ODBCConnection.Connection = sNewConnection
.Refresh

End If
End With
Next conn

Set conn = Nothing

Код взят отсюда:

Форум Excel

Мне нужно поблагодарить @GoodJuJu за совет использовать Excel VBA. Но функция не очень мне нужна.

Поэтому я потратил 1 день на исследования, чтобы создать собственную функцию.

Эта функция может заменить всю строку подключения Excel в папке и подпапках.

Ниже кода я скопировал функцию папки поиска с веб-сайта ExcelOffTheGrid

Просто измените «targetName» и «cvtFrom» и «cvtTo» в функции connStrReplacer(). Пример: моему соединению нужно изменить «ServerName» с SERVER01 на SERVER02. Итак, targetName = "ServerName", cvtFrom = "SERVER01.1583", cvtTo = "SERVER02.1583".

Надеюсь, это может помочь другим, которым также нужна такая функция.

DSN=GLOBAL_TST;ServerName=SERVER01.1583;UID=Master;ArrayFetchOn=1;ArrayBufferSize=8;TransportHint=TCP:SPX;DBQ=GLOBALTST;ClientVersion=12.11.025.000;CodePageConvert=1252;PvClientEncoding=CP1252;PvServerEncoding=CP12 52; AutoDoubleQuote=0;

    Public count As Integer
    
    'Copied Source from https://exceloffthegrid.com/vba-code-loop-files-folder-sub-folders/
    Sub loopAllSubFolderSelectStartDirectory()
        
        Dim FSOLibrary As FileSystemObject
        Dim FSOFolder As Object
        Dim folderName As String
        
        count = 3
                
        With Sheet1
        
            'Delete the old record in Sheet1
            .Range("A:D").Delete
        
            'Set header of record
            .Range("A" & count).Value = "Matched"
            .Range("B" & count).Value = "Replaced"
            .Range("C" & count).Value = "Connection"
            .Range("D" & count).Value = "File Path"
            
            'Set format & style
            .Range("A:C").HorizontalAlignment = xlCenter
            .Range("A:C").Columns.AutoFit
            
        End With
            
        'Set the folder name to a variable
        folderName = ActiveWorkbook.Path
        
        'Set the reference to the FSO Library
        Set FSOLibrary = New FileSystemObject
                
        'Another Macro must call LoopAllSubFolders Macro to start
        LoopAllSubFolders FSOLibrary.GetFolder(folderName)
        
        MsgBox ("Finished!")
        
    End Sub
    
    'Copied Source from https://exceloffthegrid.com/vba-code-loop-files-folder-sub-folders/
    Sub LoopAllSubFolders(FSOFolder As Object)
    
        Dim FSOSubFolder As Object
        Dim FSOFile As Object
        Dim fso As Object
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        
        'For each subfolder call the macro
        For Each FSOSubFolder In FSOFolder.SubFolders
            LoopAllSubFolders FSOSubFolder
        Next
        
        'For each file, print the name
        For Each FSOFile In FSOFolder.Files
        
            'Insert the actions to be performed on each file
            'This example will print the full file path to the immediate window
            Dim ext As String
            ext = fso.GetExtensionName(FSOFile.Path)
            
            'Match extension with the excel file
            'Skip for hidden excel file -> Left(FSOFile.Name, 1) <> "~"
            If (ext = "xlsm" Or ext = "xlsx" Or ext = "xls") And Left(FSOFile.Name, 1) <> "~" Then
                
                'Call function and pass excel filename with path
                connStrReplacer (FSOFile.Path)
                
            End If
            
        Next
    
    End Sub
    Sub connStrReplacer(fileName As String)
        
        Dim newWB, actWB As Workbook
        Dim conn As WorkbookConnection
        Dim targetName, cvtTo As String
        Dim cvtFrom, status As Variant
        
        'The name in the connection string
        targetName = "ServerName"
        
        'Matching the list of value for the target name
        cvtFrom = Array("HFBE-DC01-SVR.1583", "192.168.0.4.1583")
        
        'Replace to this value if the value is matched with above list
        cvtTo = "HFBE-GSS01-VM.1583"
        
        'declare Active Workbook
        Set actWB = ActiveWorkbook
        
        'Skip if is same excel with the current excel
        If fileName = (actWB.Path & "\" & actWB.Name) Then Exit Sub
        
        'Record the result to Sheet1
        count = count + 1
        
        With Sheet1
            .Range("A" & count).Value = "?"
            .Range("B" & count).Value = "?"
            .Range("C" & count).Value = "?"
            .Range("D" & count).Value = fileName
        End With
        
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        
        'Skip if cannot open excel (Exp: excel is protected)
        On Error Resume Next
        'Open file if is an excel file
        Set newWB = Workbooks.Open(fileName, False, False, , "")
        On Error GoTo 0
        
        'newWB is empty mean cannot open excel
        If IsEmpty(newWB) Then
        
            status = Array("Cannot Open Excel", "", "")
        
        Else
        
            Dim countConn, countRplc, countMatch As Integer
            countConn = 0
            countRplc = 0
            countMatch = 0
            
            'Loop for all connection in the opened workbook
            For Each conn In newWB.Connections
            
                'Check connection type if is Database Query
                If conn.Type = 2 Then
                
                    countConn = countConn + 1
                    With conn.ODBCConnection
                        
                        Dim newConStr As String
                        Dim conStr, item, item2 As Variant
                        Dim matched As Boolean
                        
                        newConStr = ""
                        matched = False
                        
                        'Split the connection to each part
                        conStr = Split(.Connection, ";")
                        
                        For Each item In conStr
                            
                            'Do nothing if item is nothing
                            If item = "" Then
                                
                            'Check connection string if has no " = " sign
                            ElseIf InStr(item, " = ") = 0 Then
                                
                                'Setting back the value to New Connection String
                                newConStr = newConStr & item & ";"
                                
                            Else
                            
                                Dim text As Variant
                                Dim newStr As String
                                
                                'Setting default value
                                newStr = item & ";"
                                
                                'Split if " = " is found
                                text = Split(item, " = ")
                                
                                'Matching the value name with the target name
                                If text(0) = targetName Then
                                    countMatch = countMatch + 1
                                    'Matching the value with the value list
                                    For Each item2 In cvtFrom
                                        'If matched then replace with new value
                                        If text(1) = item2 Then
                                            newStr = targetName & " = " & cvtTo & ";"
                                            matched = True
                                        End If
                                    Next
                                End If
                                
                                'Set the string part into the new connection string
                                newConStr = newConStr & newStr
                                
                            End If
                            
                        Next
                        
                        If matched Then
                            Dim dflt As Boolean
                            dflt = .EnableRefresh
                            .EnableRefresh = True
                            'Replace the old connection string to new
                            .Connection = newConStr
                            .EnableRefresh = dflt
                            countRplc = countRplc + 1
                        End If
                        
                    End With
                    
                End If
                
            Next conn
        
            If countConn = 0 Then
                status = Array("0", "0", "0")
            Else
                status = Array(countMatch, countRplc, countConn)
            End If
            
            Application.DisplayAlerts = False
            newWB.Save
            newWB.Close
        
        End If
        
        With Application
            .Calculation = xlAutomatic
            .ScreenUpdating = True
            .EnableEvents = True
            .DisplayAlerts = True
        End With
        
        With Sheet1
            .Range("A" & count).Value2 = status(0)
            .Range("B" & count).Value2 = status(1)
            .Range("C" & count).Value2 = status(2)
            .Range("D" & count).Select
        End With
        
    End Sub