用于查找具有连接的工作簿的宏 vba 代码

Question

我正在尝试扫描文件夹和子文件夹以查找其中包含连接字符串和 sql 命令的工作簿，但我不知道该怎么做。下面的代码是我所拥有的（到目前为止），但我被卡住了。我对宏很陌生，所以我不知道我做的是否正确。基本上，我在新工作簿中想要的列标题是文件路径、连接字符串和 SQL 命令。连接字符串和 SQL 命令可以在数据 -> 连接下找到。现在下面的代码没有写任何东西，所以当你运行它时，它会打开一个新的工作簿，但里面没有任何东西。请帮帮我。 :(

Sub ReadDataFromAllWorkbooksInFolder()

    Dim FolderName As String ' folder name
    Dim wbName As String ' full name of folder and workbook.
    Dim r As Long 'row number counter
    ' Dim cValue As Variant ' not needed
    Dim wbList() As String 'list of excel workbooks
    Dim wbCount As Integer 'number of excel workbooks
    Dim i, j As Integer 'counters

    ' Start Folder
    FolderName = "C:\Users\lchua\"
    ' create list of workbooks in foldername and put them in the spreadsheet
    wbCount = 0
    wbName = Dir(FolderName & "\" & "*.xls") 'I CAN'T FIGURE OUT HOW TO DO IT IN SUBDIRECTORIES :(    
    While wbName <> ""  'Create list of files and directories
        wbCount = wbCount + 1
        ReDim Preserve wbList(1 To wbCount)
        wbList(wbCount) = FolderName & wbName
        wbName = Dir
    Wend

    If wbCount = 0 Then Exit Sub
    r = 0
    Workbooks.Add ' Creates a new workbook to put data into
    Application.ScreenUpdating = False ' turn off the screen updating
    For i = 1 To wbCount
        Set wb = Workbooks.Open(wbList(i), True, True)
        If wb.Connections.Count > 0 Then
            numconnections = wb.Connections.Count
            For j = 1 To numconnections
            ' read information into spreadsheet
                Query = ActiveWorkbook.Connections(j).ODBCConnection.CommandText
                ConnectionString = ActiveWorkbook.Connections(j).ODBCConnection.Connection
            Next j
        End If
        wb.Close False ' close the source workbook without saving any changes
        Set wb = Nothing ' free memory
'        r = r + 1
'        cValue = GetInfoFromClosedFile(FolderName, wbList(i), "Sheet1", "A1")
'        Cells(r, 1).Formula = wbList(i)
'        Cells(r, 2).Formula = cValue
    Next i
End Sub

Answer 1

相信看完之后你会爱上VBA.

你想要达到的效果，会有4个部分（Subs）：

用于列出工作簿的所有 Connection 和 CommandText（如果有）
获取文件夹中所有 Excel 文件名称的子程序
递归到每个子文件夹的子文件夹
上面要启动的主 Sub

考虑下面的代码：

Private Const FILE_FILTER = "*.xl*"
Private Const sRootFDR = "C:\Users\lchua\" ' Root Folder

Private oFSO As Object ' For FileSystemObject
Private oRng As Range, N As Long ' Range object and Counter

Sub Main()
    Application.ScreenUpdating = False
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    N = 0
    With ThisWorkbook.Worksheets("Sheet1")
        .UsedRange.ClearContents ' Remove previous contents
        .Range("A1:D1").Value = Array("Filename", "Connections", "Connection String", "Command Text")
        Set oRng = .Range("A2") ' Initial Cell to start storing results
    End With
    ListFolder sRootFDR
    Application.ScreenUpdating = True
    Set oRng = Nothing
    Set oFSO = Nothing
    MsgBox N & " Excel files has been checked for connections."
End Sub

Private Sub ListFolder(ByVal sFDR As String)
    Dim oFDR As Object
    ' List the files of this Directory
    ListFiles sFDR, FILE_FILTER
    ' Recurse into each Sub Folder
    For Each oFDR In oFSO.GetFolder(sFDR).SubFolders
        ListFolder oFDR.Path & "\" ' Need '\' to ensure the file filter works
    Next
End Sub

Private Sub ListFiles(ByVal sFDR As String, ByVal sFilter As String)
    Dim sItem As String
    sItem = Dir(sFDR & sFilter)
    Do Until sItem = ""
        N = N + 1 ' Increment Counter
        oRng.Value = sFDR & sItem
        CheckFileConnections oRng.Value ' Call Sub to Check the Connection settings
        Set oRng = oRng.Offset(1) ' Move Range object to next cell below
        sItem = Dir
    Loop
End Sub

Private Sub CheckFileConnections(ByVal sFile As String)
    Dim oWB As Workbook, oConn As WorkbookConnection
    Dim sConn As String, sCMD As String
    Application.StatusBar = "Opening workbook: " & sFile
    Set oWB = Workbooks.Open(Filename:=sFile, ReadOnly:=True)
    With oWB
        oRng.Offset(0, 1).Value = .Connections.Count ' 1 column to right (B)
        For Each oConn In .Connections
            If Len(sConn) > 0 Then sConn = sConn & vbLf
            If Len(sCMD) > 0 Then sCMD = sCMD & vbLf
            sConn = sConn & oConn.ODBCConnection.Connection
            sCMD = sCMD & oConn.ODBCConnection.CommandText
        Next
        oRng.Offset(0, 2).Value = sConn ' 2 columns to right (C)
        oRng.Offset(0, 3).Value = sCMD ' 3 columns to right (D)
    End With
    oWB.Close False ' Close without saving
    Set oWB = Nothing
    Application.StatusBar = False
End Sub

我的测试文件夹不包含任何有连接的工作簿，所以输出是：

您应该根据您的 Sheet 更改存储这些信息的位置。您可能想注释掉 MsgBox。希望它不会在连接相关时出错。

用于查找具有连接的工作簿的宏 vba 代码

Macro vba code to find workbooks with connection

vba

excel

database-connection

connection-string

sqlcommand