ادارة التعامل مع الملفات والمجلدات شخابيط: التحكم الشامل و الكامل فى إستعراض و إدارة التعامل مع الملفات والمجلدات

[ابو جودي]

السلام عليكم ورحمة الله وبركاته

اقدم اليكم مكتبة مرنة وشاملة و متقدمة لإدارة و التعامل مع الملفات والمجلدات قمت بكتابتها بشكل مرن وإحترافي بمعنى الكلمة
يحدد ما إذا كان المستخدم سيختار ملفًا أو مجلدًا
يحدد شكل الإخراج (المسار الكامل، الاسم فقط، أو الاسم مع الامتداد)
تصنيف الملفات حسب نوعها و تصفية الملفات المعروضة
اختيار متعدد أو فردي

اليكم الأكواد كاملة هديــــة لأخوانى وأحبابى

Option Compare Database
Option Explicit

' Global variables for file selection and allowed extensions
Public IsFolderMode As Boolean          ' Toggle folder selection mode
Public AllowedExtensions As Collection  ' Store allowed file extensions

' Enumeration for File Dialog Types
Public Enum FileDialogType
    FilePicker = 1                      ' Dialog for selecting files
    FolderPicker = 4                    ' Dialog for selecting folders
End Enum

' Enumeration for processing file path
Public Enum FileProcessingMode
    FullPath = 1                        ' Return the full file path
    NameWithoutExtension = 2            ' Return the file name without extension
    NameWithExtension = 3               ' Return the file name with extension
End Enum

' Enumeration for file categories
Public Enum FileCategory
    AccessFiles = 1                     ' Access Database files (accdb, mdb, accda, etc.)
    ExcelFiles = 2                      ' Excel files (xlsx, xls, xlsm, etc.)
    WordFiles = 3                       ' Word files (docx, doc, docm, etc.)
    ImageFiles = 4                      ' Images category (jpg, png, gif, bmp, tiff, etc.)
    AudioFiles = 5                      ' Audio category (mp3, wav, ogg, flac, etc.)
    VideoFiles = 6                      ' Video category (mp4, avi, mov, mkv, etc.)
    AcrobatFiles = 7                    ' Acrobat PDF files (pdf)
    TextFiles = 8                       ' Text files (txt, csv, log, md, etc.)
    PowerPointFiles = 9                 ' PowerPoint files (pptx, ppt, pptm, etc.)
    CompressedFiles = 10                ' Compressed files (zip, rar, 7z, tar, gz, etc.)
    CodeFiles = 11                      ' Code files (html, css, js, php, py, java, etc.)
    ExecutableFiles = 12                ' Executable files (exe, bat, cmd, apk, etc.)
    AllFiles = 13                       ' All file types (*.*)
End Enum

' Initialize the allowed extensions for a specific file category
Sub InitializeExtensions(ByVal Category As FileCategory)
    Set AllowedExtensions = New Collection
    Select Case Category
        ' Access Database files
        Case AccessFiles
            AddExtensions Array("accda", "accdb", "accde", "accdr", "accdt", "accdw", "mda", "mdb", "mde", "mdf", "mdw")

        ' Excel files
        Case ExcelFiles
            AddExtensions Array("xlsx", "xls", "xlsm", "xlsb", "xltx", "xltm")

        ' Word files
        Case WordFiles
            AddExtensions Array("docx", "doc", "docm", "dotx", "dotm", "rtf", "odt")

        ' Image files
        Case ImageFiles
            AddExtensions Array("jpg", "jpeg", "png", "gif", "bmp", "tiff", "tif", "ico", "webp", "heif", "heic")

        ' Audio files
        Case AudioFiles
            AddExtensions Array("mp3", "wav", "ogg", "flac", "aac", "m4a", "wma", "alac", "opus", "aiff")

        ' Video files
        Case VideoFiles
            AddExtensions Array("mp4", "avi", "mov", "mkv", "flv", "wmv", "webm", "mpeg", "mpg", "3gp", "ts")

        ' Acrobat PDF files
        Case AcrobatFiles
            AllowedExtensions.Add "pdf"

        ' Text files
        Case TextFiles
            AddExtensions Array("txt", "csv", "log", "md", "rtf")

        ' PowerPoint files
        Case PowerPointFiles
            AddExtensions Array("pptx", "ppt", "ppsx", "pps", "pptm", "potx", "potm")

        ' Compressed files (Archives)
        Case CompressedFiles
            AddExtensions Array("zip", "rar", "7z", "tar", "gz", "tar.gz", "tgz", "xz", "bz2")

        ' Code files
        Case CodeFiles
            AddExtensions Array("html", "css", "js", "php", "py", "java", "cpp", "c", "rb", "swift", "go", "ts")

        ' Executable files
        Case ExecutableFiles
            AddExtensions Array("exe", "bat", "cmd", "msi", "apk", "app", "dmg", "jar")

        ' All file types
        Case AllFiles
            AllowedExtensions.Add "*.*"

        Case Else
            MsgBox "Invalid category provided!", vbCritical
    End Select
End Sub

' Add an array of extensions to the AllowedExtensions collection
Private Sub AddExtensions(ByVal ExtensionsArray As Variant)
    Dim Extension As Variant
    For Each Extension In ExtensionsArray
        AllowedExtensions.Add Extension
    Next Extension
End Sub

' Display a file or folder dialog and return the selected files
Function GetFiles(Optional ByVal Extensions As Collection = Nothing, Optional ByVal SingleFile As Boolean = False) As Collection
    Dim FileDialog As Object
    Dim FolderDialog As Object
    Dim SelectedFiles As New Collection
    Dim FolderPath As String
    Dim FilterString As String

    On Error GoTo ErrorHandler

    ' Build the file dialog filter
    FilterString = BuildFilterString(Extensions)

    If Not IsFolderMode Then
        ' File selection dialog
        Set FileDialog = Application.FileDialog(FileDialogType.FilePicker)
        With FileDialog
            .Title = "Select File(s)"
            .AllowMultiSelect = Not SingleFile
            .Filters.Clear
            .Filters.Add "Allowed Files", FilterString
            If .Show = -1 Then
                AddSelectedFilesToCollection FileDialog, SingleFile, SelectedFiles
            End If
        End With
    Else
        ' Folder selection dialog
        Set FolderDialog = Application.FileDialog(FileDialogType.FolderPicker)
        With FolderDialog
            .Title = "Select Folder"
            If .Show = -1 Then
                FolderPath = .SelectedItems(1)
                SelectedFiles.Add FolderPath
            End If
        End With
    End If

    ' Return the selected files or folder
    If SelectedFiles.Count > 0 Then
        Set GetFiles = SelectedFiles
    Else
        MsgBox "No files or folder selected.", vbExclamation
        Set GetFiles = Nothing
        Exit Function
    End If

CleanUp:
    Set FileDialog = Nothing
    Set FolderDialog = Nothing
    Exit Function

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbCritical
    Resume CleanUp
End Function

' Build the file dialog filter string
Private Function BuildFilterString(ByVal Extensions As Collection) As String
    Dim Filter As String
    Dim Extension As Variant
    If Not Extensions Is Nothing Then
        For Each Extension In Extensions
            Filter = Filter & "*." & Extension & ";"
        Next Extension
        If Len(Filter) > 0 Then Filter = Left(Filter, Len(Filter) - 1)
    Else
        Filter = "*.*"
    End If
    BuildFilterString = Filter
End Function

' Add selected files to the collection
Private Sub AddSelectedFilesToCollection(ByVal Dialog As Object, ByVal SingleFile As Boolean, ByRef FilesCollection As Collection)
    Dim Index As Long
    If SingleFile Then
        FilesCollection.Add Dialog.SelectedItems(1)
    Else
        For Index = 1 To Dialog.SelectedItems.Count
            FilesCollection.Add Dialog.SelectedItems(Index)
        Next Index
    End If
End Sub

' Function to check if the file extension is allowed
Function IsAllowedExtension(ByVal strExt As String, ByVal colExtensions As Collection) As Boolean
    Dim varExt As Variant
    If colExtensions Is Nothing Or colExtensions.Count = 0 Then
        IsAllowedExtension = True ' Allow all extensions if colExtensions is Nothing or empty
        Exit Function
    End If

    For Each varExt In colExtensions
        If LCase(strExt) = LCase(varExt) Then
            IsAllowedExtension = True
            Exit Function
        End If
    Next varExt

    IsAllowedExtension = False
End Function

' Subroutine to select a folder and retrieve all files based on allowed extensions
Sub SelectFilesInFolder(ByVal FileCategoryType As FileCategory)
    Dim SelectedFiles As Collection         ' Collection to hold the selected files
    Dim FolderPath As String                ' Folder path selected by the user
    Dim CurrentFileName As String           ' Current file name during folder iteration
    Dim FileExtension As String             ' File extension for the current file
    Dim FilteredFiles As New Collection     ' Collection to hold filtered files
    Dim FileItem As Variant                 ' Variable to iterate through filtered files

    
    On Error GoTo ErrorHandler  ' Handle errors if they occur
    
    ' Enable folder selection mode
    IsFolderMode = True

    ' Initialize allowed extensions for the specified file category
    InitializeExtensions FileCategoryType

    ' Prompt user to select a folder
    Set SelectedFiles = GetFiles(Nothing, False) ' Pass Nothing for extensions as folder mode doesn't filter by type

    ' Check if a folder was selected
    If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then
        ' Get the first (and only) selected folder path
        FolderPath = SelectedFiles(1)

        ' Start iterating through all files in the selected folder
        CurrentFileName = Dir(FolderPath & "\*.*") ' Retrieve the first file in the folder
        Do While CurrentFileName <> ""
            ' Extract file extension and convert it to lowercase
            FileExtension = LCase(Split(CurrentFileName, ".")(UBound(Split(CurrentFileName, "."))))

            ' Check if the file extension is allowed and add it to the filtered collection
            If IsAllowedExtension(FileExtension, AllowedExtensions) Then
                FilteredFiles.Add FolderPath & "\" & CurrentFileName
            End If

            ' Retrieve the next file in the folder
            CurrentFileName = Dir
        Loop

        ' If there are filtered files, display their paths
        If FilteredFiles.Count > 0 Then
            For Each FileItem In FilteredFiles
                Debug.Print "Selected File: " & FileItem
            Next FileItem
        Else
            MsgBox "No files found matching the allowed extensions.", vbExclamation
        End If
    Else
        MsgBox "No folder selected.", vbExclamation
    End If

Exit Sub

' Error handler to catch and display error 91 (and other errors if any)
ErrorHandler:
    If Err.Number = 91 Then
        Exit Sub
    Else
        MsgBox "An unexpected error occurred: " & Err.Description, vbCritical
    End If
    Resume Next
End Sub

Sub SelectFolderPath()

    On Error GoTo ErrorHandler  ' Handle errors if they occur
    ' Collection to hold the selected files
    Dim colFiles As Collection
    
    IsFolderMode = True ' Set folder mode to true for folder selection
    
    Set colFiles = GetFiles(Nothing, False) ' Pass Nothing for colExtensions as we are dealing with folders
    
    On Error Resume Next
    If Not colFiles Is Nothing And colFiles.Count > 0 Then
        PrintFilePaths colFiles
    Else
        MsgBox "No folder selected.", vbExclamation
    End If
    
Exit Sub

' Error handler to catch and display error 91 (and other errors if any)
ErrorHandler:
    If Err.Number = 91 Then
        Exit Sub
    Else
        MsgBox "An unexpected error occurred: " & Err.Description, vbCritical
    End If
    Resume Next
End Sub

' Subroutine to demonstrate single file selection with specific extensions
Sub SelectSingleFile(ByVal FileCategoryType As FileCategory)
    On Error GoTo ErrorHandler  ' Handle errors if they occur
    
    ' Collection to hold the selected files
    Dim SelectedFiles As Collection
    
    ' Set file selection mode
    IsFolderMode = False
    
    ' Initialize allowed extensions for the specified file category
    InitializeExtensions FileCategoryType

    ' Prompt user to select a single file with allowed extensions
    Set SelectedFiles = GetFiles(AllowedExtensions, True)

    ' Print selected file path(s)
    PrintFilePaths SelectedFiles
    
Exit Sub

' Error handler to catch and display error 91 (and other errors if any)
ErrorHandler:
    If Err.Number = 91 Then
        Exit Sub
    Else
        MsgBox "An unexpected error occurred: " & Err.Description, vbCritical
    End If
    Resume Next
End Sub

' Subroutine to demonstrate multiple file selection with specific extensions
Sub SelectMultipleFiles(ByVal FileCategoryType As FileCategory)
    On Error GoTo ErrorHandler  ' Handle errors if they occur
  
    ' Collection to hold the selected files
    Dim SelectedFiles As Collection

    ' Set file selection mode
    IsFolderMode = False

    ' Initialize allowed extensions for the specified file category
    InitializeExtensions FileCategoryType

    ' Prompt user to select multiple files with allowed extensions
    Set SelectedFiles = GetFiles(AllowedExtensions, False)

    ' Print selected file path(s)
    PrintFilePaths SelectedFiles

Exit Sub

' Error handler to catch and display error 91 (and other errors if any)
ErrorHandler:
    If Err.Number = 91 Then
        Exit Sub
    Else
        MsgBox "An unexpected error occurred: " & Err.Description, vbCritical
    End If
    Resume Next
End Sub

' Subroutine to print file paths from a collection
Sub PrintFilePaths(ByVal Files As Collection)
    ' Variable to iterate through filtered files
    Dim FileItem As Variant

    ' Check if the collection is valid and contains files
    If Not Files Is Nothing And Files.Count > 0 Then
        For Each FileItem In Files
            Debug.Print "Selected File: " & FileItem
        Next FileItem
    Else
        MsgBox "No files were selected or matched the allowed extensions.", vbExclamation
    End If
End Sub


' Subroutine to process file paths, extract name, name without extension, and extension
Sub ProcessFilePaths(ByVal colFiles As Collection)
    ' Variable to iterate through the collection
    Dim varFilePath As Variant
    
    ' Variable to hold the current file path as a string
    Dim strFilePath As String
    
    ' Variables to hold extracted components of the file path
    Dim fileName As String
    Dim fileNameWithoutExt As String
    Dim fileExt As String

    ' Check if the collection is not empty or Nothing
    If Not colFiles Is Nothing Then
        ' Loop through each file path in the collection
        For Each varFilePath In colFiles
            ' Assign the current file path to a string variable
            strFilePath = varFilePath

            ' Extract the file name from the full path
            fileName = GetFileNameFromPath(strFilePath)

            ' Extract the file name without the extension
            fileNameWithoutExt = GetFileNameWithoutExtension(strFilePath)

            ' Extract the file extension (including the dot)
            fileExt = GetFileExtension(strFilePath)

'            ' Print the extracted information to the Immediate Window (Ctrl+G in VBA Editor)
'            Debug.Print "Full Path: " & varFilePath
'            Debug.Print "File Name: " & fileName
'            Debug.Print "File Name Without Extension: " & fileNameWithoutExt
'            Debug.Print "File Extension: " & fileExt
'            Debug.Print "------------------------------"
        Next varFilePath
    Else
        ' Show a message box if the collection is empty or Nothing
        MsgBox "No files found.", vbInformation
    End If
End Sub


' Function to extract the file name (including extension) from a full file path
Function GetFileNameFromPath(FilePath As String) As String
    ' Check if the file path is empty
    If Len(FilePath) = 0 Then
        GetFileNameFromPath = "" ' Return an empty string if no path is provided
        Exit Function
    End If

    ' Search for the last backslash in the file path
    Dim pos As Long
    pos = InStrRev(FilePath, "\") ' Find the position of the last backslash

    ' If no backslash is found, check for forward slash (e.g., for web paths)
    If pos = 0 Then
        pos = InStrRev(FilePath, "/") ' Find the position of the last forward slash
    End If

    ' Extract and return the file name
    If pos > 0 Then
        GetFileNameFromPath = Mid(FilePath, pos + 1) ' Return everything after the last separator
    Else
        GetFileNameFromPath = FilePath ' If no separator is found, return the full path
    End If
End Function


' Function to extract the file name without its extension from a full file path
Function GetFileNameWithoutExtension(FilePath As String) As String
    ' Check if the file path is empty
    If Len(FilePath) = 0 Then
        GetFileNameWithoutExtension = "" ' Return an empty string if no path is provided
        Exit Function
    End If

    ' Search for the last backslash in the file path
    Dim posBackslash As Integer
    posBackslash = InStrRev(FilePath, "\") ' Find the position of the last backslash

    ' If no backslash is found, check for forward slash (e.g., for web paths)
    If posBackslash = 0 Then
        posBackslash = InStrRev(FilePath, "/") ' Find the position of the last forward slash
    End If

    ' Extract the file name (with extension)
    Dim fileName As String
    If posBackslash > 0 Then
        fileName = Mid(FilePath, posBackslash + 1) ' Extract the file name
    Else
        fileName = FilePath ' If no separator, the full path is considered the file name
    End If

    ' Search for the last dot in the file name to identify the extension
    Dim posDot As Integer
    posDot = InStrRev(fileName, ".") ' Find the position of the last dot

    ' Remove the extension if a dot is found
    If posDot > 0 Then
        GetFileNameWithoutExtension = Left(fileName, posDot - 1) ' Return the name without the extension
    Else
        GetFileNameWithoutExtension = fileName ' If no dot, return the full file name
    End If
End Function


' Function to extract the file extension (including the dot) from a full file path
Function GetFileExtension(FilePath As String) As String
    ' Check if the file path is empty
    If Len(FilePath) = 0 Then
        GetFileExtension = "" ' Return an empty string if no path is provided
        Exit Function
    End If

    ' Search for the last dot in the file path
    Dim posDot As Integer
    posDot = InStrRev(FilePath, ".") ' Find the position of the last dot

    ' Extract and return the file extension
    If posDot > 0 Then
        GetFileExtension = Mid(FilePath, posDot) ' Return everything after (and including) the last dot
    Else
        GetFileExtension = "" ' If no dot is found, return an empty string
    End If
End Function


' Subroutine to save file paths or details into a database table
' Parameters:
'   - SelectedFiles: Collection of selected file paths.
'   - TableName: Name of the database table where data will be saved.
'   - FieldName: Name of the field in the table to store the file information.
'   - ProcessingMode: Determines how the file paths will be processed before saving. Default is FullPath.
Sub SaveFileDetailsToTable(SelectedFiles As Collection, TableName As String, FieldName As String, Optional ByVal ProcessingMode As FileProcessingMode = FullPath)
    
    On Error GoTo ErrorHandler  ' Handle errors if they occur
    Dim varFilePath As Variant
    Dim ProcessedValue As String

    ' Check if the SelectedFiles collection is valid and contains files
    If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then
        ' Loop through each file in the collection
        For Each varFilePath In SelectedFiles
            ' Determine how the file path should be processed based on ProcessingMode
            Select Case ProcessingMode
                Case FullPath
                    ' Use the full file path as the value to save
                    ProcessedValue = CStr(varFilePath)
                Case NameWithoutExtension
                    ' Extract and use the file name without its extension
                    ProcessedValue = GetFileNameWithoutExtension(CStr(varFilePath))
                Case NameWithExtension
                    ' Extract and use the file name including its extension
                    ProcessedValue = GetFileNameFromPath(CStr(varFilePath))
                Case Else
                    ' Default to using the full file path
                    ProcessedValue = CStr(varFilePath)
            End Select

            ' Construct the SQL statement to insert the processed value into the specified table and field
            Dim SQL As String
            SQL = "INSERT INTO [" & TableName & "] ([" & FieldName & "]) VALUES ('" & Replace(ProcessedValue, "'", "''") & "')"
            
            ' Execute the SQL statement to save the data into the database
            CurrentDb.Execute SQL, dbFailOnError
        Next varFilePath
    Else
        ' Display a message if no files were found in the collection
        MsgBox "No files found.", vbInformation
    End If

Exit Sub

' Error handler to catch and display error 91 (and other errors if any)
ErrorHandler:
    If Err.Number = 91 Then
        Exit Sub
    Else
        MsgBox "An unexpected error occurred: " & Err.Description, vbCritical
    End If
    Resume Next
    
End Sub

' Test method to demonstrate saving file details to a table
' This subroutine selects files and saves their names without extensions into a database table
Sub TestSaveResults()
    Dim SelectedFiles As Collection

    ' Set mode to file selection mode
    IsFolderMode = False

    ' Initialize allowed extensions for the specific category (e.g., images in this case)
    InitializeExtensions ImageFiles

    ' Prompt the user to select files based on the allowed extensions
    Set SelectedFiles = GetFiles(AllowedExtensions, False)

    ' Save the selected file names (without extensions) into the table "tblMedia" in the "fieldName" column
    SaveFileDetailsToTable SelectedFiles, "tblMedia", "fieldName", NameWithoutExtension
End Sub


' Test the functionality of retrieving a folder path
Sub TestGetFolderPath()
    ' Call the Select Folder function to get the folder path
    SelectFolderPath
End Sub

' Test the functionality of selecting files in a folder based on the specified file category
Sub TestSelectFilesInFolder()
    ' Call the SelectFilesInFolder function to select audio files from a folder
    SelectFilesInFolder AudioFiles
End Sub

' Test the functionality of selecting a single file based on the specified file category
Sub TestSelectSingleFile()
    ' Call the SelectSingleFile function to select a single audio file
    SelectSingleFile AudioFiles
End Sub

' Test the functionality of selecting multiple files based on the specified file category
Sub TestSelectMultipleFiles()
    ' Call the SelectMultipleFiles function to select multiple audio files
    SelectMultipleFiles AudioFiles
End Sub

 

[Foksh]

ما شاء الله ، هذا يحتاج سهرة ومخمخة وحبتين بنادول ههههههههه

حبذا لو دعمتنا بملف مرفق ليتمتع به أمثالي في كيفية التعامل والاستدعاء والتفاهم مع الكود 

 

 

[ابو جودي]

27 دقائق مضت, Foksh said:

ما شاء الله ، هذا يحتاج سهرة ومخمخة وحبتين بنادول ههههههههه

حبذا لو دعمتنا بملف مرفق ليتمتع به أمثالي في كيفية التعامل والاستدعاء والتفاهم مع الكود 

طيب فعلا والله مش فاضى الان غصب عنى  ابشر بعد ان انتهى من عملى سوف اضع المرف ان لم يسبقنى اليه احد

لكن الجزء الاخير خالص من الكود هو الزتونه

' Test the functionality of retrieving a folder path
Sub TestGetFolderPath()
    ' Call the Select Folder function to get the folder path
    SelectFolderPath
End Sub

' Test the functionality of selecting files in a folder based on the specified file category
Sub TestSelectFilesInFolder()
    ' Call the SelectFilesInFolder function to select audio files from a folder
    SelectFilesInFolder AudioFiles
End Sub

' Test the functionality of selecting a single file based on the specified file category
Sub TestSelectSingleFile()
    ' Call the SelectSingleFile function to select a single audio file
    SelectSingleFile AudioFiles
End Sub

' Test the functionality of selecting multiple files based on the specified file category
Sub TestSelectMultipleFiles()
    ' Call the SelectMultipleFiles function to select multiple audio files
    SelectMultipleFiles AudioFiles
End Sub

 

[zero1111330566]

ممكن اذا سمحت عمل برنامج للاكواد وشكرا 

[Moosak]

سلمت يمناك حبيبنا الغالي ... تحفة فنية من واحد هو ذاته تحفة 🌼🌷🌹

والمكتبة عاااااامرة بإسمك الكريم في جميع جنباتها 😁✌

[gavan]

يااااااااااااااااااااااا سلام والله احتاج اسبوع كامل لشرح الكود

شكرا على المجهود الجبار , لو تكرمت بملف مرفق نكون ممنونين 

تحياتي الحارة