Duyệt file (folder) trong 1 folder cho trước và tạo Hyperlink

One Response

1. hands says:

   13/01/2023 at 6:44 pm

   Tôi không cần ai cám ơn đâu. Cái tôi cần là test hộ. Rất nhiều lần tôi nhờ test hộ thì chả ai giúp tôi cả. Tại sao tôi nhờ test? Cái thứ nhất là xem tốc độ. Cái nữa là biết đâu code sai. Thường thì cái lỗi của người khác nhìn bao giờ cũng thấy như con voi còn lỗi của bản thân nó cứ như con kiến ấy. Vì thế con người ai cũng nhìn thấy rõ lỗi của người khác nhưng lỗi của bản thân sao khó thấy thế.
   —————-
   Tôi tự phát hiện ra trường hợp thiếu kết quả. Khi filename = "*" thì có đầy đủ kết quả. Khi vd. filename = "*.txt" và SubDir = TRUE thì kết quả trả về y như là SubDir = FALSE, tức chỉ có kết quả khớp từ thư mục đầu tiên. Trong code dưới những chỗ sửa hoặc thêm vào tôi đánh dấu mầu đỏ đỏ. Nhờ mọi người tiếp tục kiểm tra hộ
   ————
   Nhân tiện nhờ mọi người test hộ. Tôi muốn test chủ yếu cho trường hợp tìm các tập tin hoặc cả tập tin và thư mục, tìm cả ở các thư mục con. Kết quả trả về là tên, độ lớn và ngày tạo. Thư mục bắt đầu là "C:" Code của tôi không lấy các tập tin và thư mục có trong sọt rác – RECYCLE, RECYCLER Tóm lại là chạy code sub myTest. Module

   Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
   Private Const MAX_PATH As Long = 260
   Private Const INVALID_HANDLE_VALUE As Long = &HFFFFFFFF  '((Handle) - 1)
   
   Private Type FILETIME
       dwLowDateTime As Long
       dwHighDateTime As Long
   End Type
   
   Private Type SYSTEMTIME
       wYear As Integer
       wMonth As Integer
       wDayOfWeek As Integer
       wDay As Integer
       wHour As Integer
       wMinute As Integer
       wSecond As Integer
       wMilliseconds As Integer
   End Type
   
   Private Type WIN32_FIND_DATA
       dwFileAttributes As Long
       ftCreationTime As FILETIME
       ftLastAccessTime As FILETIME
       ftLastWriteTime As FILETIME
       nFileSizeHigh As Long
       nFileSizeLow As Long
       dwReserved0 As Long
       dwReserved1 As Long
       cFileName As String * MAX_PATH
       cAlternate As String * 14
   End Type
   
   Public Enum FIND_FILE_OPTION
       FileOnly = 1
       DirectoryOnly = 2
       AllFiles = 3
   End Enum
   
   Public Enum FIND_RESULT_OPTION
       frName = 1
       frNameSize = 3
       frNameDate = 5
       frNameSizeDate = 7
   End Enum
   
   Private Declare Function FileTimeToLocalFileTime Lib "kernel32.dll" (ByRef lpFileTime As FILETIME, ByRef lpLocalFileTime As FILETIME) As Long
   Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" (ByRef lpFileTime As FILETIME, ByRef lpSystemTime As SYSTEMTIME) As Long
   
   Private Declare Function GetTickCount Lib "kernel32" () As Long
   Private Declare Function FindClose Lib "kernel32.dll" (ByVal hFindFile As Long) As Long
   Private Declare Function FindFirstFileW Lib "kernel32.dll" (ByVal lpFileName As String, ByRef lpFindFileData As WIN32_FIND_DATA) As Long
   Private Declare Function FindNextFileW Lib "kernel32.dll" (ByVal hFindFile As Long, ByRef lpFindFileData As WIN32_FIND_DATA) As Long
   
   Private Const recycle = "RECYCLE"
   
   Function UTCtoSysTime(fTime As FILETIME) As String
   Dim LocalFileTime As FILETIME, SysTime As SYSTEMTIME
       If ((fTime.dwLowDateTime <> 0) Or (fTime.dwHighDateTime <> 0)) And _
         FileTimeToLocalFileTime(fTime, LocalFileTime) And FileTimeToSystemTime(LocalFileTime, SysTime) Then
           UTCtoSysTime = DateSerial(SysTime.wYear, SysTime.wMonth, SysTime.wDay) & " " _
               & TimeSerial(SysTime.wHour, SysTime.wMinute, 0)
       End If
   End Function
   
   Sub FindMatchedFilesExtW(arr, DirSize As Double, ByVal DirStart As String, ByVal filename As String, Optional ByVal res_option As FIND_RESULT_OPTION = frName, _
       Optional ByVal SubDir As Boolean = True, Optional ByVal find_option As FIND_FILE_OPTION = FileOnly)
   ' Arr: maŇng chýěa kęět quaŇ traŇ vęĚ laĚ maŇng 2 chięĚu
   ' SubDir: nęěu TRUE thiĚ tim caŇ trong caěc thý muňc con
   ' find_option = 3 (AllFiles) - tiĚm tâňp tin vaĚ thý muňc, 1 (FileOnly) - chiŇ tiĚm tâňp tin, 2 (DirectoryOnly) - chiŇ tiĚm thý muňc
   '    DirSize chi dung cho vai th, vd. filename = "*", find_option = FileOnly, SubDir = True
   '    ----------------------------------------
   '    vd. caěch duĚng
   '    FindMatchedFilesExtW arr, size, "C:", "*", frNameSizeDate, , FileOnly
   '    Application.ScreenUpdating = False
   '    Range("A1").Resize(UBound(arr) + 1, UBound(arr, 2) + 1).Value = arr
   '    Application.ScreenUpdating = True
   
   Dim FindData As WIN32_FIND_DATA
   Dim FindHandle As Long
   Dim validDir As Boolean, IsFile As Boolean, doAdd As Boolean
   Dim fName As String, k As Long, r As Long, c As Long, dSize As Double, size As Long
   Static level As Long
   On Error Resume Next
   
   If Right(DirStart, 1) <> "" Then DirStart = DirStart & ""
   
   [B][COLOR=#ff0000]If Not SubDir And (find_option = FileOnly) Then      [/COLOR][/B][COLOR=#ff0000][/COLOR][COLOR=#0000ff]<--- thay cho [/COLOR][COLOR=#ff0000]fName = StrConv(DirStart & filename, vbUnicode)[/COLOR]
   [B][COLOR=#ff0000]        fName = StrConv(DirStart & filename, vbUnicode)
       Else
           fName = StrConv(DirStart & "*", vbUnicode)
       End If[/COLOR][/B]
   
   FindHandle = FindFirstFileW(fName, FindData)
   
   If FindHandle <> INVALID_HANDLE_VALUE Then
           If res_option = frName Then
               size = 0
           ElseIf res_option = frNameSizeDate Then
               size = 2
           Else
               size = 1
           End If
           doAdd = SubDir Or (level = 0)
           Do
               fName = StrConv(FindData.cFileName, vbFromUnicode)
               k = InStr(1, fName, vbNullChar)
               fName = Left(fName, k - 1)
   
   validDir = (FindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY
               IsFile = Not validDir
   
   If IsFile Then DirSize = DirSize + FindData.nFileSizeLow
   
   If validDir Then validDir = (Left(fName, 1) <> ".") And (InStr(1, fName, recycle, vbTextCompare) <> 1)
   
   If validDir Then
                   If SubDir Or ((find_option > 1) And ((res_option And 2) = 2)) Then
                       level = level + 1
                       dSize = 0
                       FindMatchedFilesExtW arr, dSize, DirStart & fName, filename, res_option, SubDir, find_option
                       level = level - 1
                       DirSize = DirSize + dSize
                   End If
               End If
               [B][COLOR=#ff0000]If fName Like filename Then[/COLOR][/B]    [COLOR=#0000ff]<--- them[/COLOR]
                   If doAdd And ((validDir And (find_option > 1)) Or (IsFile And (find_option <> 2))) Then
                       If IsEmpty(arr) Then
                           ReDim arr(0 To size)
                       Else
                           ReDim Preserve arr(0 To UBound(arr) + size + 1)
                       End If
   
   arr(UBound(arr) - size) = DirStart & fName
                       If (res_option And 2) = 2 Then
                           If IsFile And (find_option <> 2) Then
                               arr(UBound(arr) - size + 1) = FindData.nFileSizeLow
                           Else
                               arr(UBound(arr) - size + 1) = dSize
                           End If
                       End If
   
   If (res_option And 4) = 4 Then arr(UBound(arr)) = UTCtoSysTime(FindData.ftCreationTime)
                   End If
               [B][COLOR=#ff0000]End If[/COLOR][/B]     [COLOR=#0000ff]<--- them[/COLOR]
           Loop Until FindNextFileW(FindHandle, FindData) = 0
           FindClose (FindHandle)
       End If
   
   If level = 0 Then
           ReDim resArr(0 To (UBound(arr) + 1)  (size + 1) - 1, 0 To size) As String
           For r = 0 To UBound(resArr)
               k = (size + 1) * r
               For c = 0 To size
                   resArr(r, c) = arr(k + c)
               Next c
           Next r
           arr = resArr
       End If
   End Sub
   
   Sub myTest()
   Dim t As Double, arr, size As Double
       Range("A:C").Clear
   
   t = Timer
       FindMatchedFilesExtW arr, size, "c:", "*", frNameSizeDate, , FileOnly
       If IsEmpty(arr) Then Exit Sub
       Debug.Print "siwtom code: " & UBound(arr) + 1 & " files (or folders) found!", , Format(Timer - t, "0.0") & "s"
       Debug.Print size
   
   Application.ScreenUpdating = False
       Range("A1").Resize(UBound(arr) + 1, UBound(arr, 2) + 1).Value = arr
       Application.ScreenUpdating = True
   End Sub

   Tôi không cần ai cám ơn đâu.

   Trời ơi, khiếp quá, mỗi cái ổ C: mà lên đến sấp sỉ 50.000 tệp . Cám ơn thầy . Nhưng nếu thày viết cho duyệt một thư mục bất kỳ nào đó khi cho đường dẫn thì hay quá.

   Bạn nói tới bài của tôi? Nếu thế thì duyệt thư mục nào thì cho DirStart = thư mục đó. Còn filename thì vd. filename = "*" – tất cả, hoặc filename = "*.txt" – chỉ các file TXT

   Emt test thử Debug.Print báo như vậy :
   siwtom code: 167313 files (or folders) found! 63.3s
   37828117695

   Em thấy ok,tất cả các file xxx, abc,xyz .. hidden cũng liệt kê ra hết __–__

   Ý nhà em là khi ta gọi sub Mytext thì xuất hiện hộp thoại để ta nhập đường dẫn cần duyệt vào đó thầy ạ ?

   Anh siwtom chẳng khi nào làm trọn vẹn 1 ứng dụng nào đâu. Ở trên chỉ là code dạng giải thuật, dùng thế nào là chuyện của bạn
   Bạn muốn có hộp gì đó thì bài 1 đấy còn gì

   trời ơi, nhà em tải về rồi, nhưng do nhà em vẫn dùng office 2003 "đồ cổ" nên không mở được đuôi .xlsm , không biết có cách nào để đọc không nữa, nhà em bó tay thày ạ.

   Tôi dùng đuôi xlsm là có lý do. Thử nghĩ bạn tìm trong ổ C được 80,000 file thì làm sao liệt kê trên file xls đây? (xls chỉ có 65536 dòng)
   Nếu muốn, tôi chuyển xlsm sang xls cho bạn —> xem ở bài 1 nhé

   Vả lại code của thày Wistom có cả dung lượng và thời gian khởi tạo . Nếu máy tự nhiên trục trặc, Có thể dùng code lọc thời gian để kiểm tra các tập tin khởi tạo trong thời gian trước đó .

   Thì code của tôi cũng có đầy đủ đấy thôi (Tên file, dung lượng, ngày tạo) tùy bạn chọn trên UserForm. Mặc khác còn tạo được Hyperlink trên sheet (cũng tùy bạn chọn luôn)

   Anh siwtom chẳng khi nào làm trọn vẹn 1 ứng dụng nào đâu. Ở trên chỉ là code dạng giải thuật, dùng thế nào là chuyện của bạn
   Bạn muốn có hộp gì đó thì bài 1 đấy còn gì

   Đúng thế. Đó chỉ là sub thôi. Tức "lấy" các tập tin và thư mục khớp. Còn "lấy" thư mục DirStart bằng cách nào hoặc mảng kết quả dùng làm việc khác hay để đập xuống sheet là tùy người dùng.
   Mà chọn thư mục bắt đầu thì trong code của ndu đã có rồi, cứ bắt chước thôi.
   Tất nhiên tôi test cho "C:" và tìm tất cả nên chắc chắn Arr <> Empty. Trong th tổng quát thì trước khi dùng Arr phải kiểm tra vì có thể với đk tìm kiếm thì không tìm thấy kất quả nào, tức Arr = Empty

   Với macro đơn giản, gọn nhẹ sau đây có thể đáp ứng yêu cầu của bạn

   FindMatchedFilesExtW ...
       If not IsEmpty(arr) Then ...

   bài này hay quá nhưng sao khi add vào thì nó chỉ có sheet 1 thôi nhỉ cái này em muốn add vào mà khi mở file excel nào cũng có cái addin này thì làm sao ạ

   Thì bạn lưu file thành Add-In đi, sẽ dùng được với bất cứ file nào trên máy tính của bạn mỗi khi khởi động Excel

   giờ em add được rồi, nhưng bây giờ khi mở file mới hì file Search_For_Files_Folders.xlsm nó cũng chạy ra luôn có cách nào không cho nó chạy ko ạ

   Vậy xin hỏi: BẠN ĐÃ THAO TÁC THẾ NÀO?

   dạ vaofile excel bình thường vẫn làm chọn file-options-addinn-manage(excel addin) goto (hộp addin mở ra)chọn Search_For_Files_Folders.xlsm –ok đóng lạitắt file excel đi
   nhưng khi mở file đó lại thì nó hiện thêm 1 file Search_For_Files_Folders.xlsm
   và file Search_For_Files_Folders.xlsm còn xếp trước file em muốn mở

   Cái chổ màu đỏ tôi vẫn không hiểu
   Khi hộp AddIn mở ra, bạn làm cách nào có thể chọn được kiểu file xlsm vậy? (trong khi nó chỉ cho phép bạn chọn kiểu xlam)
   Nếu bạn bấm nút Browse, cố tình chọn All Files (*.*) để có thể duyệt đến kiểu file xlsm thì bạn đã làm sai —> Quy định tạo Add-In và sử dụng nó phải thế này:
   – Đóng hết các file Excel đang mở
   – Mở file Search_For_Files_Folders.xlsm
   – Bấm nút Save As, khung Save As Type bạn chọn kiểu Excel Add-In (*.xlam). Bấm nút Save
   – Đóng file Search_For_Files_Folders.xlsm và không lưu
   – Khởi động Excel mới, mở hộp Excel AddIn (như bạn đã làm) rồi check vào "Search_For_Files_Folders" –> OK
   Vậy là xong

   Lấy link tất cả file trong folder theo điều kiện

   Hiện tại mình có file lấy link tất cà các file trong Folder nay muốn bổ sung thêm điều kiện
   Lấy tất cả các file theo điều kiện tại vùng I3:I1000 (Ý mình chỉ muốn lấy những link theo điều kiện này thôi)

   Sub ChonDia()
   With Application.FileDialog(msoFileDialogFolderPicker)
      If .Show Then
      Sheet1.TextBox1 = .SelectedItems(1)
      End If
   End With
   End Sub
   ------------------------------------------------------------------------------------------------
   Function FilesFoldersList(ByVal RootFolder As String, ByVal ListType As Boolean, _
                             ByVal Search As String, ByVal InSub As Boolean)
     'ListType = True: Get Files list
     'ListType = False: Get Folders list
     Dim sComm As String, tmp As String, str As String, tmpFile, Arr
     On Error Resume Next
     If Right(RootFolder, 1) <> "" Then RootFolder = RootFolder & ""
     str = """" & RootFolder & IIf(ListType, Search, "") & """"
   
   With CreateObject("Scripting.FileSystemObject")
       tmpFile = .GetTempName
       sComm = "DIR " & str & " /ON /B /A" & IIf(ListType, "-", "") & "D-S" & IIf(InSub, "/S", " ") & " >" & tmpFile
       CreateObject("Wscript.Shell").Run "cmd /u /c " & sComm, 0, True
       With .OpenTextFile(tmpFile, 1, , -2)
         tmp = Trim(.ReadAll)
         If Right(tmp, 2) = vbCrLf Then tmp = Left(tmp, Len(tmp) - 2)
         If Len(tmp) Then
           If InSub = False Then tmp = RootFolder & Replace(tmp, vbCrLf, vbCrLf & RootFolder)
           FilesFoldersList = Split(tmp, vbCrLf)
         End If
         .Close
       End With
     End With
     Kill tmpFile
   End Function
   -----------------------------------------------------------------------------------------------
   Sub Link()
   Dim Arr, i As Long, k As Long, Count As Long
   Dim Dic As Object
   On Error Resume Next
   Set Dic = CreateObject("Scripting.FileSystemObject")
       Arr = FilesFoldersList(Sheet1.TextBox1, True, "*" & [COLOR=#ff0000]Sheet1.Range("I2") & "*.*",[/COLOR] Sheet1.CheckBox1)
           Range("B9:G65536").Clear
           k = 1 - LBound(Arr)
           For i = LBound(Arr) To UBound(Arr)
           With Range("B9").Offset(i)
             .Offset(, 0) = i + k
             .Offset(, 1) = Dic.GetFile(Arr(i)).Name
             .Offset(, 2) = Int(Dic.GetFile(Arr(i)).Size / 1024)
             .Offset(, 3) = Dic.GetFile(Arr(i)).Type
             .Offset(, 4) = Dic.GetFile(Arr(i)).DateCreated
             .Offset(, 5).Hyperlinks.Add .Offset(, 5), Arr(i), , , "Click mo File"
           End With
           Next
   End Sub

   Mình chỉ cần tìm kiếm những file cần thôi
   điệu kiện ô chổ tô màu đỏ

   Sub ChonDia()
   With Application.FileDialog(msoFileDialogFolderPicker)
      If .Show Then
      Sheet1.TextBox1 = .SelectedItems(1)
      End If
   End With
   End Sub
   Function FilesFoldersList(ByVal RootFolder As String, ByVal ListType As Boolean, _
                             ByVal Search As String, ByVal InSub As Boolean)
     'ListType = True: Get Files list
     'ListType = False: Get Folders list
     Dim sComm As String, tmp As String, str As String, tmpFile, Arr
     On Error Resume Next
     If Right(RootFolder, 1) <> "" Then RootFolder = RootFolder & ""
     str = """" & RootFolder & IIf(ListType, Search, "") & """"
   
   With CreateObject("Scripting.FileSystemObject")
       tmpFile = .GetTempName
       sComm = "DIR " & str & " /ON /B /A" & IIf(ListType, "-", "") & "D-S" & IIf(InSub, "/S", " ") & " >" & tmpFile
       CreateObject("Wscript.Shell").Run "cmd /u /c " & sComm, 0, True
       With .OpenTextFile(tmpFile, 1, , -2)
         tmp = Trim(.ReadAll)
         If Right(tmp, 2) = vbCrLf Then tmp = Left(tmp, Len(tmp) - 2)
         If Len(tmp) Then
           If InSub = False Then tmp = RootFolder & Replace(tmp, vbCrLf, vbCrLf & RootFolder)
           FilesFoldersList = Split(tmp, vbCrLf)
         End If
         .Close
       End With
     End With
     Kill tmpFile
   End Function
   Sub Link()
   Dim Arr, i As Long, k As Long, Count As Long
   Dim Dic As Object
   On Error Resume Next
   Set Dic = CreateObject("Scripting.FileSystemObject")
       Arr = FilesFoldersList(Sheet1.TextBox1, True, [COLOR=#ff0000]"*" & Sheet1.Range("I2") & "*.*"[/COLOR], Sheet1.CheckBox1)
           Range("B9:G65536").Clear
           k = 1 - LBound(Arr)
           For i = LBound(Arr) To UBound(Arr)
           With Range("B9").Offset(i)
             .Offset(, 0) = i + k
             .Offset(, 1) = Dic.GetFile(Arr(i)).Name
             .Offset(, 2) = Int(Dic.GetFile(Arr(i)).Size / 1024)
             .Offset(, 3) = Dic.GetFile(Arr(i)).Type
             .Offset(, 4) = Dic.GetFile(Arr(i)).DateCreated
             .Offset(, 5).Hyperlinks.Add .Offset(, 5), Arr(i), , , "Click mo File"
           End With
           Next
   End Sub

   Bạn dùng thử File này.

   Reply