SolidWorks*Excel+VBA-打个招呼

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