如何使用VBA获取Excel文件中全部连接字符串的属性详情？

• 你原有代码仅提取了查询命令文本，未读取连接字符串属性，需针对不同连接类型读取对应Connection属性值
• Excel不同连接类型的属性存储位置有差异：
  • ODBC连接对应WorkbookConnection.ODBCConnection.Connection
  • OLEDB连接对应WorkbookConnection.OLEDBConnection.Connection
  • 工作表内的QueryTable对象也自带QueryTable.Connection属性
• 拿到完整连接字符串后，可按分号拆分出每个键值对，单独输出后和你需要的内容完全匹配

Sub List_All_Connection_Details()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim listObj As ListObject
    Dim qt As QueryTable
    Dim qtName As String
    Dim n As Long, i As Long
    Dim wbConn As WorkbookConnection
    Dim qcSheet As Worksheet, r As Long
    Dim propArr As Variant, connProps As String
    
    ' 操作当前激活的工作簿，可改为ThisWorkbook操作宏所在工作簿
    Set wb = ActiveWorkbook
    
    ' 创建或清空输出工作表
    Set qcSheet = GetWbSheet(wb, "Queries Conns")
    If qcSheet Is Nothing Then
        With wb
            Set qcSheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
            qcSheet.Name = "Queries Conns"
        End With
    End If
    qcSheet.Cells.Clear
    qcSheet.Cells.WrapText = True ' 自动换行方便查看拆分后的属性
    
    ' 输出工作表级QueryTable信息
    r = 1
    qcSheet.Cells(r, "A").Value = "Worksheet QueryTables"
    qcSheet.Cells(r, "A").Font.Bold = True
    r = r + 1
    qcSheet.Cells(r, "A").Resize(, 4).Value = Array("Worksheet Name", "QueryTable Name", "Command Text", "Connection String")
    r = r + 1
    
    For Each ws In wb.Worksheets
        If Not ws Is qcSheet Then
            qcSheet.Cells(r, "A").Value = ws.Name
            n = 0
            For Each qt In ws.QueryTables
                qcSheet.Cells(r + n, "B").Value = qt.Name
                qcSheet.Cells(r + n, "C").Value = qt.CommandText
                qcSheet.Cells(r + n, "D").Value = qt.Connection
                n = n + 1
            Next
            If n = 0 Then n = 1
            r = r + n
        End If
    Next
    
    ' 输出表格对象（ListObject）关联的连接信息
    r = r + 1
    qcSheet.Cells(r, "A").Value = "ListObjects (Table) Connections"
    qcSheet.Cells(r, "A").Font.Bold = True
    r = r + 1
    qcSheet.Cells(r, "A").Resize(, 5).Value = Array("Worksheet Name", "Table Name", "QueryTable Name", "Command Text", "Connection String")
    r = r + 1
    
    For Each ws In wb.Worksheets
        If Not ws Is qcSheet Then
            n = 0
            For Each listObj In ws.ListObjects
                qcSheet.Cells(r + n, "A").Value = ws.Name
                qcSheet.Cells(r + n, "B").Value = listObj.Name
                Set qt = Nothing
                On Error Resume Next
                Set qt = listObj.QueryTable
                On Error GoTo 0
                If Not qt Is Nothing Then
                    qtName = "Undefined"
                    On Error Resume Next
                    qtName = qt.Name
                    On Error GoTo 0
                    qcSheet.Cells(r + n, "C").Value = qtName
                    qcSheet.Cells(r + n, "D").Value = qt.CommandText
                    qcSheet.Cells(r + n, "E").Value = qt.Connection
                End If
                n = n + 1
            Next
            r = r + n
        End If
    Next
    
    ' 输出工作簿级全部连接的详细属性
    r = r + 1
    qcSheet.Cells(r, "A").Value = "Workbook Full Connection Details"
    qcSheet.Cells(r, "A").Font.Bold = True
    r = r + 1
    qcSheet.Cells(r, "A").Resize(, 4).Value = Array("Connection Name", "Command Text", "Full Connection String", "Split Connection Properties")
    r = r + 1
    
    n = 0
    For Each wbConn In wb.Connections
        qcSheet.Cells(r + n, "A").Value = wbConn.Name
        connProps = ""
        Select Case wbConn.Type
            Case xlConnectionTypeODBC
                qcSheet.Cells(r + n, "B").Value = wbConn.ODBCConnection.CommandText
                Dim odbcConnStr As String
                odbcConnStr = wbConn.ODBCConnection.Connection
                qcSheet.Cells(r + n, "C").Value = odbcConnStr
                ' 拆分连接字符串为单独属性行
                propArr = Split(odbcConnStr, ";")
                For i = LBound(propArr) To UBound(propArr)
                    If Trim(propArr(i)) <> "" Then
                        connProps = connProps & Trim(propArr(i)) & vbCrLf
                    End If
                Next
                qcSheet.Cells(r + n, "D").Value = connProps
            Case xlConnectionTypeOLEDB
                qcSheet.Cells(r + n, "B").Value = wbConn.OLEDBConnection.CommandText
                Dim oledbConnStr As String
                oledbConnStr = wbConn.OLEDBConnection.Connection
                qcSheet.Cells(r + n, "C").Value = oledbConnStr
                propArr = Split(oledbConnStr, ";")
                connProps = ""
                For i = LBound(propArr) To UBound(propArr)
                    If Trim(propArr(i)) <> "" Then
                        connProps = connProps & Trim(propArr(i)) & vbCrLf
                    End If
                Next
                qcSheet.Cells(r + n, "D").Value = connProps
            ' 如存在Power Query等其他类型连接，可在此补充对应Case分支
            Case Else
                qcSheet.Cells(r + n, "B").Value = "Unsupported Connection Type: " & wbConn.Type
        End Select
        n = n + 1
    Next
    
    ' 自动调整列宽方便查看
    qcSheet.Columns("A:E").AutoFit
End Sub


Private Function GetWbSheet(wb As Workbook, sheetName As String) As Worksheet
    Set GetWbSheet = Nothing
    On Error Resume Next
    Set GetWbSheet = wb.Worksheets(sheetName)
    On Error GoTo 0
End Function

• 出于安全机制，Excel会隐藏连接字符串中的密码字段，返回值为****，无法通过VBA直接读取明文密码
• 如果你使用Power Query（获取和转换）类型的连接，可根据连接类型补充Select Case分支，对应访问DataFeedConnection、TextConnection等对象的属性
• 代码默认开启单元格自动换行，拆分后的属性会逐行显示，和你需要提取的连接属性详情一致

内容的提问来源于stack exchange，提问作者ASH