Option ExplicitSub OpenFolder() '打开文件夹Dim Swfolder, fs As ObjectOn Error Resume Next Set fs = CreateObject("Scripting.FileSystemObject") If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then Set Swfolder = fs.GetFolder(Selection.Value) If Swfolder Is Nothing Then MsgBox "文件夹不存在" & Chr(13) & _ "请检查所选单元格内容！", vbExclamation, "不正经的机械仙人" Else Shell "explorer " & Swfolder.Path, vbNormalFocus End If Else MsgBox "请选择单一单元格！", vbExclamation, "不正经的机械仙人" End If Set Swfolder = Nothing Set fs = NothingEnd SubSub SearchSwFiles() '搜索文件Dim Rng As Range, Usedrng As Range, fs As FileSystemObjectDim Swpath As String, SearchSubfolder As Boolean, opt As ByteDim DrwFile As String opt = MsgBox("是否搜索子文件夹？", vbQuestion + vbYesNoCancel, "不正经的机械仙人") If opt = vbYes Then SearchSubfolder = True ElseIf opt = vbNo Then SearchSubfolder = False Else Exit Sub End If With Application.ActiveSheet If .Cells(2, 2) = "" Then MsgBox "未在[B2]单元格输入搜索文件夹!", vbExclamation, "不正经的机械仙人" Exit Sub ElseIf Right(.Cells(2, 2), 1) = "\" Then .Cells(2, 2) = Left(.Cells(2, 2), Len(.Cells(2, 2)) - 1) '统一格式 End If Swpath = .Cells(2, 2) Set fs = CreateObject("Scripting.FileSystemObject") If Not fs.FolderExists(Swpath) Then .Range("A2").Value = "文件夹不存在×" MsgBox "文件夹不存在!", vbExclamation, "不正经的机械仙人" Exit Sub Else .Range("A2").Value = "√" End If Set Usedrng = Intersect(.UsedRange, .Range("C:C")) For Each Rng In Usedrng If Rng.Value <> "" And Rng.Row > 2 Then .Cells(Rng.Row, 1) = .Cells(Rng.Row, 2) & "\" & .Cells(Rng.Row, 3) & .Cells(Rng.Row, 4) End If Next SearchSwFiles_rec fs.GetFolder(Swpath), SearchSubfolder, 3 Set Usedrng = Intersect(.UsedRange, .Range("A:A")) '刷新其余未匹配到的单元格 For Each Rng In Usedrng If Rng.Value = .Cells(Rng.Row, 2) & "\" & .Cells(Rng.Row, 3) & .Cells(Rng.Row, 4) Then If Dir(Rng.Value) <> "" Then .Cells(Rng.Row, 5) = fs.GetFile(Rng.Value).DateLastModified Rng.ClearContents Else Rng.Value = "文件不存在!" End If DrwFile = .Cells(Rng.Row, 2) & "\" & .Cells(Rng.Row, 3) & ".SLDDRW" If Dir(DrwFile) <> "" Then .Cells(Rng.Row, 6) = fs.GetFile(DrwFile).DateLastModified Else .Cells(Rng.Row, 6) = "无工程图" End If End If Next MsgBox "文件已经搜索完毕!", vbInformation, "不正经的机械仙人" End With Set fs = Nothing Application.StatusBar = FalseEnd SubPrivate Sub SearchSwFiles_rec(Swpath As Folder, SearchSubfolder As Boolean, Seqe As Long)On Error Resume NextDim Swfile As file, TmpSwpath As Folder, fs As New FileSystemObjectDim SwFtype As String, SwFname As String, DrwFile As StringDim Posn As Long, Posnb As Long, FullSwFname As String With Application.ActiveSheet Err.Clear: Posn = Seqe Application.StatusBar = "正在搜索: " & Swpath.Path For Each Swfile In Swpath.Files SwFname = Swfile.Name SwFtype = Mid(SwFname, InStrRev(SwFname, ".")) If (UCase(SwFtype) = ".SLDPRT" Or UCase(SwFtype) = ".SLDASM") And Left(Swfile.Name, 1) <> "~" Then Posnb = 0: FullSwFname = Swfile.Path Posnb = WorksheetFunction.Match(FullSwFname, .Range("A:A"), 0) If Posnb = 0 Then '加入表中' Do Until .Cells(Posn, 3) = "" Posn = Posn + 1 Loop .Cells(Posn, 1) = "新文件!" .Cells(Posn, 2) = Swpath.Path .Cells(Posn, 3) = Left(SwFname, InStrRev(SwFname, ".") - 1) .Cells(Posn, 4) = SwFtype .Cells(Posn, 5) = Swfile.DateLastModified DrwFile = .Cells(Posn, 2) & "\" & .Cells(Posn, 3) & ".SLDDRW" If Dir(DrwFile) <> "" Then .Cells(Posn, 6) = fs.GetFile(DrwFile).DateLastModified Else .Cells(Posn, 6) = "无工程图" End If Err.Clear Else .Cells(Posnb, 1).ClearContents .Cells(Posnb, 5) = Swfile.DateLastModified DrwFile = .Cells(Posnb, 2) & "\" & .Cells(Posnb, 3) & ".SLDDRW" If Dir(DrwFile) <> "" Then .Cells(Posnb, 6) = fs.GetFile(DrwFile).DateLastModified Else .Cells(Posnb, 6) = "无工程图" End If End If End If Next If SearchSubfolder Then For Each TmpSwpath In Swpath.SubFolders SearchSwFiles_rec TmpSwpath, True, Posn Next End If End With Set fs = NothingEnd Sub
