VBA 制作文件&文件夹搜索工具

GUI

This WorkBook 代码：

Private Sub Workbook_Open()

    Dim i As Integer
    
    i = 3
    
    If HadOtherExcel Then
    
        ThisWorkbook.Windows(1).Visible = False
    
    Else
    
        Application.Visible = False ' 隐藏整个 Excel 应用程序
        
    End If
    
    Do While i > 0
        
        Application.Wait Now + TimeValue("00:00:01")
        
        On Error GoTo ErrorHandler
        
            UserForm1.Show vbModeless
            
            Exit Do
            
ErrorHandler:
        
        i = i - 1
        
        
    Loop
    
    
    ThisWorkbook.Saved = True ' 防止未保存的提示
    

    
End Sub

 

Function HadOtherExcel() As Boolean

    Dim Wb As Workbook
    
    Dim IsOpen As Boolean
    
    IsOpen = False
    
    ' 遍历所有已经打开的工作簿
    For Each Wb In Workbooks
        ' 检查是否有其他工作簿已经打开
        
        If Wb.Name <> ThisWorkbook.Name Then
        
            IsOpen = True
            
            Exit For
            
        End If
        
    Next Wb
    
    HadOtherExcel = IsOpen

End Function

 

 

 

UserForm1 代码：

Dim FPList() As Variant

Dim FolderCount As Long

Dim FirstFlag As Boolean

Function StrFind(Str1 As Variant, Str2 As String) As Boolean

    Dim Pos As Integer

    StrFind = False
    
    Pos = InStr(1, Str1, Str2, vbTextCompare)

    If Pos > 0 Then

        StrFind = True
    
    End If

End Function

 

Function IsValidFolderPath(ByVal folderPath As String) As Boolean

    Dim isValid As Boolean
    
    isValid = False
    
    On Error GoTo ErrorHandler
    
    ' 检查文件夹路径是否为空
    If folderPath <> "" Then
    
        ' 检查文件夹是否存在
        If Dir(folderPath, vbDirectory) <> "" Then
        
            ' 检查是否是一个文件夹
            If (GetAttr(folderPath) And vbDirectory) = vbDirectory Then
            
                isValid = True
                
            End If
            
        End If
        
    End If
    
    IsValidFolderPath = isValid
    
ErrorHandler:
    
    IsValidFolderPath = isValid
    
    
End Function

 

Private Sub UserForm1_Initialize()

    ListBox1.MultiColumn = True
    
    ListBox1.ScrollBars = fmScrollBarsHorizontal

    ' Me.Icon = LoadPicture("C:\Mike\SmallToolBox_Ico\Picture_2.ico")

    ' 初始化 UserForm 时设置进度条的最小值和最大值
    ' Me.ProgressBar1.Min = 0
    
    ' Me.ProgressBar1.Max = 100
    
    
End Sub

Sub UpdateProgressBar(ByVal Per As Long, ByVal Str As String)

    ' 更新进度条的值
    Me.ProgressBar1.Value = Per
    
    ' 更新进度信息标签
    Me.Label1.Caption = Str
        
    ' 强制刷新界面，以便立即显示更新
    DoEvents
        
    
End Sub

 

Function IsArrayEmpty(arr As Variant) As Boolean
    
    On Error GoTo ErrorHandler
    
    IsArrayEmpty = False
    
    Dim ArrayLength As Long

    ArrayLength = UBound(arr) - LBound(arr) + 1
    
    Exit Function
    
    
ErrorHandler:

    IsArrayEmpty = True
    
    Resume Next
    
    
End Function

 

Sub SetFilePathList(ByVal Path As String)

    Dim FileFolderList As Variant

    If Right(Path, 1) <> "\" Then
    
        Path = Path & "\"
        
    End If

    If Dir(Path, vbDirectory) <> "" Then
        
        FileFolderList = GetFileAndFolder(Path)
        
        Call InitBar
        
        ListBox1.List = FileFolderList
        
        Dim Count As Long
        
        Count = 0
        
        For Each Content In FileFolderList
        
            ReDim Preserve FPList(Count)
        
            FPList(Count) = Content
            
            Count = Count + 1
        
        Next Content
        
    
    End If

 

End Sub

 

Sub InitBar()

    Label5.Caption = "" ' 清空进度条标题
        
    Label3.Width = 0 ' 复位进度条
        
    Call MainPer("Init", 0) ' 复位子文件夹编号
        
    FirstFlag = False ' 复位，这是读取文件夹第一层级的标志位。
        
    DoEvents

End Sub

 

Sub SearchPath(ByVal EventType As Integer)

    Dim FilePathList As Variant
    
    Dim SearchContent As String
    
    Dim FilePathList_New() As String
    
    Dim Count As Long
    
    Dim Content As Variant
    
    Count = 0
    
    ' FilePathList = ListBox1.List
    
    FilePathList = FPList
    
    If IsArrayEmpty(FilePathList) Then
        
        Exit Sub
        
    Else
    
        If (EventType = 2) And (UBound(FilePathList) + 1 > 10000) Then
    
            Exit Sub
        
        End If
        
    End If
    
    Call SearchPer("正在搜索 .......")
    
    SearchContent = TextBox2.Value
    
    If SearchContent = "" Then
    
        ListBox1.Clear
        
        ListBox1.List = FPList
        
        Call SearchPer("")
        
        Exit Sub
    
    End If
        
    For Each Content In FilePathList
    
        If StrFind(Content, SearchContent) Then
        
            ReDim Preserve FilePathList_New(Count)
            
            FilePathList_New(Count) = Content
                
            Count = Count + 1
        
        End If
    
    Next Content
    
    Call InitBar ' 初始化进度条
    
    If Not IsArrayEmpty(FilePathList_New) Then
    
        ListBox1.Clear
    
        ListBox1.List = FilePathList_New
        
    Else
    
        ' MsgBox ("啥玩意没搜到！！！！！！！！！！！")
        ListBox1.Clear
        
    End If
    
    Call SearchPer("")
    
    

End Sub

Function GetFileAndFolder(Path As Variant)
    
    Dim FileFolderList() As String
    
    Dim FileFolderList_Sub() As String

    Dim FSO As Object
    
    Dim Folders As Object
    
    Dim SubFolder As Variant
    
    Dim SubFolders() As String
    
    Dim FileFolder_Sub As Variant
    
    Dim SubFolder_Name As Variant
    
    Dim File As Variant
    
    Dim i As Long
    
    Dim Count As Long
    
    Dim Per As Long
    
    Dim BarStr As String
    
    If IsArrayEmpty(FileFolderList) Then
    
        Count = 0
        
    Else
    
        Count = UBound(FileFolderList) - LBound(FileFolderList)
        
    End If
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Set Folders = FSO.GetFolder(Path)
    
    i = 0
    
    For Each SubFolder In Folders.SubFolders
        
        ReDim Preserve FileFolderList(Count)
        
        ReDim Preserve SubFolders(i)
        
        FileFolderList(Count) = SubFolder.Path
        
        SubFolders(i) = SubFolder.Path
        
        i = i + 1
        Count = Count + 1
    
    Next SubFolder
    
    
    If Not FirstFlag Then
    
        FolderCount = i
        
        FirstFlag = True
        
        Call MainPer("主文件夹第一层级信息读取完毕", 5)
        
    End If
    
    
    i = 0
    
    For Each File In Folders.Files
        
        ReDim Preserve FileFolderList(Count)
        
        FileFolderList(Count) = File.Path
        
        i = i + 1
        Count = Count + 1
    
    Next File
    
    
    If Not IsArrayEmpty(SubFolders) Then
    
        For Each SubFolder_Name In SubFolders
        
            LastBackslashIndex = InStrRev(SubFolder_Name, "\")
    
            If LastBackslashIndex > 0 Then
            
                SPath = Left(SubFolder_Name, LastBackslashIndex)
                
            Else
            
                SPath = SubFolder_Name
                
            End If
            
            If SPath = Path Then
            
                Call MainPer("", 0)
                
            End If
    
            FileFolderList_Sub = GetFileAndFolder(SubFolder_Name)
            
            If Not IsArrayEmpty(FileFolderList_Sub) Then
            
                For Each FileFolder_Sub In FileFolderList_Sub
            
                    ReDim Preserve FileFolderList(Count)
            
                    FileFolderList(Count) = FileFolder_Sub
                
                    Count = Count + 1
            
                Next FileFolder_Sub
            End If
            
            If Flag = 1 Then
            
                Per1_Count = Per1_Count + 1
                
            End If
    
        Next SubFolder_Name
    
    End If
    
    
    GetFileAndFolder = FileFolderList
    
    

End Function

 

Function SelectPath()

    SelectPath = ""

    With Application.FileDialog(msoFileDialogFolderPicker)
    
        .Title = "请选取需要被检索讯息的文件夹"
        
        .AllowMultiSelect = False
        
        If .Show = -1 Then
        
            SelectPath = .SelectedItems(1)
        
        Else
    
            Exit Function
        
        End If
        
    End With

End Function

 

Private Sub CheckBox1_Click()

    If CheckBox1.Value = True Then
    
        If HadOtherExcel Then
        
            ThisWorkbook.Windows(1).Visible = True
            
        Else
    
            Application.Visible = True
            
        End If
            
    Else
        
        If HadOtherExcel Then
        
            ThisWorkbook.Windows(1).Visible = False
            
        Else
    
            Application.Visible = False
            
        End If
        
    
    End If
    

End Sub

 

Private Sub CommandButton1_Click()

    Dim SelectedPath As String
    
    SelectedPath = SelectPath()

    If SelectedPath = "" Then
    
        Exit Sub
        
    Else
    
        ListBox1.Clear
        
        TextBox2.Value = ""
        
        DoEvents
    
        TextBox1.Value = SelectedPath
        
    End If
    
    SetFilePathList (SelectedPath)
    

End Sub

 

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

    If KeyCode <> 13 Then  ' 按的不是 Enter 键就退出
    
        Exit Sub
        
    End If

    Dim Path As String
    
    Path = TextBox1.Value
    
    SetFilePathList (Path)
    

End Sub

 

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    Dim SelectedPath As String
    
    Dim Path As String
    
    Dim ShellResult As Variant
    
    ' 获取所选路径
    SelectedPath = ListBox1.Value
    
    If Right(SelectedPath, 1) <> "\" Then
    
        Path = SelectedPath & "\"
        
    End If
    
    If Not IsValidFolderPath(Path) Then
    
        Path = Left(SelectedPath, InStrRev(SelectedPath, "\"))
        ' 使用 Shell 函数打开路径
        ' 打开文件夹并选中文件
        ' ShellResult = Shell("explorer.exe """ & Path & """", vbNormalFocus)
        ShellResult = Shell("explorer.exe /select," & SelectedPath, vbNormalFocus)

    Else
    
        ShellResult = Shell("explorer.exe """ & Path & """", vbNormalFocus)

    End If
    
    
    
End Sub

 

 

Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    ' 判断是否按下了 Enter 键（键码为 13）
    If KeyCode = 13 Then
        ' 运行你的代码
        SearchPath (1)
         
    End If
    
End Sub

Private Sub TextBox2_Change()

    SearchPath (2)

End Sub

 

Private Sub UserForm_Terminate()
    
    If Application.Visible = False Then

        ThisWorkbook.Close SaveChanges:=False
        
    End If
    
End Sub

Private Sub UserForm1_MouseWheel(ByVal Ctrl As MSForms.ReturnBoolean, ByVal CancelDefault As MSForms.ReturnBoolean)

    If Ctrl Then
    
        Me.ListBox1.TopIndex = Me.ListBox1.TopIndex - (Ctrl * 3)
        
        CancelDefault = True
        
    End If
    
    
End Sub

 

Sub Sleep(Seconds As Double)

    Application.Wait Now + TimeValue("00:00:0" & Seconds)
    
End Sub

 

Sub MainPer(ByVal Title As String, ByVal Per_In As Long)

    Static Per As Double
    
    Dim TitleStr As String
    
    If Title = "Init" Then
        
        Per = 0
        
        Exit Sub
    
    End If
    
    If Per_In = 0 Then
    
        Per = Per + 1
        
        TitleStr = "共 " & Str(FolderCount) & " 个子文件夹，正在读取第 " & Str(Per) & " 个中的信息 ......"
        
        Label3.Width = 760.2 * 95 / 100 / FolderCount * Per + (760.2 * 5 / 100)
        
    Else

        TitleStr = Title
        
        Label3.Width = 760.2 * Per_In / 100
    
    End If
    
    
    Label5.Caption = TitleStr
    
    DoEvents

End Sub

 

Sub SearchPer(ByVal Title As String)
        
    Label5.Caption = Title
    
    DoEvents

End Sub

 

Sub SubPer(ByVal Title As String, ByVal Per As Long)

    Label6.Caption = Title
    
    Label4.Width = 370 * Per / 100

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    ' 当用户试图关闭窗体时
    If CloseMode = vbFormControlMenu Then
        
        If (Application.Visible = False And Not HadOtherExcel) Or (ThisWorkbook.Windows(1).Visible = False And HadOtherExcel) Then
        
            ' 设置 Excel 应用程序为可见
            Application.Visible = True
            
            ThisWorkbook.Windows(1).Visible = True
            
            Unload UserForm1
            
            If HadOtherExcel Then
            
                ThisWorkbook.Close SaveChanges:=False
            
            Else
            
                Application.Quit
                
            End If
            
        
        End If
        
    End If
    
End Sub

 

Function HadOtherExcel() As Boolean

    Dim Wb As Workbook
    
    Dim IsOpen As Boolean
    
    IsOpen = False
    
    ' 遍历所有已经打开的工作簿
    For Each Wb In Workbooks
        ' 检查是否有其他工作簿已经打开
        
        If Wb.Name <> ThisWorkbook.Name Then
        
            IsOpen = True
            
            Exit For
            
        End If
        
    Next Wb
    
    HadOtherExcel = IsOpen

End Function