用户注册



邮箱:

密码:

用户登录


邮箱:

密码:
记住登录一个月忘记密码?

发表随想


还能输入:200字
云代码 - vb代码库

excel2007/2010 遍历文件功能

2018-08-23 作者:layman666举报

[vb]代码库

FileSearch 物件已從 2007 Microsoft Office 程式中去除(這麼好用的功能也拿掉了,真是給他..00XX),詳細的說明請參考
KB935402說明,在說明中微軟有提示可以使用Dir 函式或 FileSystemObject
類別來搜索檔案,今天就依這個提示來做一個類似Application.FileSearch的功能,可以設定是否搜尋子資料夾,詳細說明請參考程式碼….



Dim strArr() As String, rCount As Integer
Sub App_FileSearch()
'設定要搜尋檔案的關鍵字
'如果要列出所有檔案請設定為String = ""
Const keyword As String = "*.xls" '搜尋xls檔案
    'App_SearchSubFolder(keyword, True) '搜尋包含子資料夾
    'App_SearchSubFolder(keyword, False) '搜尋不包含子資料夾
    Call App_SearchSubFolder(keyword, True)
    If UBound(strArr) > 0 Then
        '以超連結的方式列出檔案
        For i = 0 To UBound(strArr)
            If strArr(i) <> "" Then
                ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 3, "A"), _
                        Address:=strArr(i), TextToDisplay:=strArr(i)
            End If
        Next i
    Else
        MsgBox "未發現檔案"
    End If
End Sub
Function App_SearchSubFolder(keyword As String, rSearchSubFolders As Boolean)
Dim fd As Object
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    '開啟Excel內建的資料夾瀏覽方塊
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then
        rLookIn = fd.SelectedItems(1)
    Else
        MsgBox "未選取資料夾": Exit Function
    End If
    rFilename = Dir$(rLookIn & "\" & keyword)
    rCount = 0
    '建立動態陣列
    ReDim Preserve strArr(rCount)
    '第一階資料夾
    Do While rFilename <> vbNullString
        strArr(rCount) = rLookIn & "\" & rFilename
        rCount = rCount + 1
        ReDim Preserve strArr(rCount)
        rFilename = Dir$()
    Loop
    If rSearchSubFolders Then    '判斷是否搜尋子資料夾
        '搜尋第二階以後的子資料夾
        Call App_NextSubFolder(fso.GetFolder(rLookIn), keyword)
    End If
    Set fd = Nothing
    Set fso = Nothing
End Function

Private Sub App_NextSubFolder(ByRef Folder As Object, _
        ByRef keyword As String)
Dim SubFolder As Object
    For Each SubFolder In Folder.SubFolders
        rFilename = Dir$(SubFolder.Path & "\" & keyword)
        Do While rFilename <> vbNullString
            strArr(rCount) = SubFolder.Path & "\" & rFilename
            rCount = rCount + 1
            ReDim Preserve strArr(rCount)
            rFilename = Dir$()
        Loop
        Call App_NextSubFolder(SubFolder, keyword)
    Next
End Sub


分享到:
更多

网友评论    (发表评论)


发表评论:

评论须知:

  • 1、评论每次加2分,每天上限为30;
  • 2、请文明用语,共同创建干净的技术交流环境;
  • 3、若被发现提交非法信息,评论将会被删除,并且给予扣分处理,严重者给予封号处理;
  • 4、请勿发布广告信息或其他无关评论,否则将会删除评论并扣分,严重者给予封号处理。