代码之家 › 专栏 › 技术社区 › user4683138

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

sqlcommand connection-string database-connection excel vba

user4683138 · 技术社区 · 10 年前

我正在尝试扫描文件夹和子文件夹中包含连接字符串和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

1 回复 | 直到 10 年前

PatricK 10 年前

我相信在这之后你会爱上VBA。

对于您想要实现的目标,将有4个部分(子部分):

列出所有子项联系和 命令文本 工作簿(如果有)
Sub获取文件夹中所有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

我的测试文件夹不包含任何具有连接的工作簿,因此输出为:
Output

您应该根据工作表更改存储这些信息的位置。你可能想评论一下 MsgBox 。希望它不会在连接相关时出错。