الاقسام

السلام عليكم ورحمة الله وبركاته اقدم اليكم مكتبة مرنة وشاملة و متقدمة لإدارة و التعامل مع الملفات والمجلدات قمت بكتابتها بشكل مرن وإحترافي بمعنى الكلمة يحدد ما إذا كان المستخدم سيختار ملفًا أو مجلدًا يحدد شكل الإخراج (المسار الكامل، الاسم فقط، أو الاسم مع الامتداد) تصنيف الملفات حسب نوعها و تصفية الملفات المعروضة اختيار متعدد أو فردي اليكم الأكواد كاملة هديــــة لأخوانى وأحبابى 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  

لما عرضت مقترح الاشتراك المفتوح .. حسب الحضور  على صاحبي قال لي : يمكن يحصل تلاعب  .. وهو ان المشترك لا يسجل حضور .. وبكذا اشتراكه يبقى كما هو لا ينقص  صاحبي على قدر امكانياته .. لا يوجد  باب آلي يفتح عند التوقيع ومشروعه في الهواء الطلق .. لا يوجد ابواب

المفترض أنه عضو ذهبي أي يتم احتساب ايام الحضور فقط وهذا يعني أنه غير مقترن بتاريخ من / إلى ❗ هذه النقطة لها سلوكان ، الأول أن تكون مدة التعويض اختيارية حسب قرار الإدارة . أو الثاني وهو احتساب ايام التعويض ثلث مدة الإجازة ويجبر الكسر لأقرب عدد صحيح أو من خلال معادلة :- من 1 الى 3 = تعويض 1 يوم من 4 الى 6 = تعويض 2 يوم أكثر من 7 = تعويض 3 أيام ... إلخ. سأجعل الموضوع أكثر وضوحاً بمرفق بسيط وبيانات مختصرة وهمية .. مجرد اقتراحات 😇 .

بارك الله فيك اخي جاري تجربته

وعليكم السلام ورحمة الله تعالى وبركاته  بطريقة أخرى  Sub TaxCivil() Dim Irow&, lastRow&, lastCol&, i&, j&, k&, WS As Worksheet, dest As Worksheet, tmp As Double, _ OnRng As Variant, r As Variant, headers As Variant, n As Double, civil As String Set WS = Sheets("المعلومات") Set dest = Sheets("الموظفين") Application.ScreenUpdating = False Irow = dest.Cells(dest.Rows.Count, 3).End(xlUp).Row lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row lastCol = WS.Cells(2, WS.Columns.Count).End(xlToLeft).Column OnRng = dest.Range("A2:E" & Irow).Value r = WS.Range(WS.Cells(3, 1), WS.Cells(lastRow, lastCol)).Value headers = WS.Range(WS.Cells(2, 3), WS.Cells(2, lastCol)).Value dest.Range("E2:E" & Irow).ClearContents For i = 1 To UBound(OnRng, 1) n = OnRng(i, 3): civil = OnRng(i, 4) tmp = 0 If n = 0 Or Trim(civil) = "" Then GoTo SkipRow For j = 1 To UBound(r, 1) If n >= r(j, 1) And n <= r(j, 2) Then For k = 1 To UBound(headers, 2) If headers(1, k) = civil Then tmp = r(j, k + 2) Exit For End If Next k Exit For End If Next j OnRng(i, 5) = IIf(tmp > 0, tmp, "غير محدد") SkipRow: Next i dest.Range("A2").Resize(UBound(OnRng, 1), 5).Value = OnRng Application.ScreenUpdating = True End Sub   ضريبة.xlsb