ابو جودي

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

ههههههه انا جاوبت فى سرى ينفع لا بلاش هزار لحسن حد يزعق لى انا بالفعل حضرتت الاجابة وفى آخر لحظة تراجعت عن عمل المشاركة ورفع المرفق السبب: بكل صراحة لم أكن راضيا عنها جارى العمل على تعديل اكواد لتكون الإجابة شاملة و كافية و وافيه بقدر الإمكان للإقتراب قدر الإمكان من أقرب درجات الكمال لأكون راض عن المشاركة

العفو يحثنا ديننا الحنيف على طلب العلم حتى الممات دائما نتعلم ونطلب العلم وان شاء الله وان طال الطريق يسهله الله تعالى علينا بفضله ثم بفضل وكرم اساتذتنا العظماء الذين نتعلم منهم طرق الافكار والحلول جزاكم الله خيرا على دعواتكم الطيبة واسال الله تعالى ان يرزقكم بركتها وفضلها وكل المسلمون ان شاء الله

هلا والله.. والله اشتقنا يا اهلا بمفاجئاتك انت لازم تطلع عنيننا يا استاذنا الغالى انا قلت كتبت الكود على حسب المشكلات اللى واجهتنى وفتها بس ولا يهمك انت تأمر من عيونى بس استبدل الدالة التالية Private Sub AnalyzeDateParts(strPartOne As String, strPartTwo As String, strPartThree As String, _ ByRef intDay As Integer, ByRef intMonth As Integer, ByRef intYear As Integer) ' This subroutine analyzes the lengths of the date parts to determine their roles as day, month, or year. ' Depending on the format of the input string, it assigns the appropriate values to intYear, intMonth, and intDay. If Len(strPartOne) = 4 Then ' Year is first (Format: YYYY-MM-DD or YYYY-DD-MM) intYear = CInt(strPartOne) If CInt(strPartTwo) > 12 Then ' Format: YYYY-DD-MM intDay = CInt(strPartTwo) intMonth = CInt(strPartThree) Else ' Format: YYYY-MM-DD intMonth = CInt(strPartTwo) intDay = CInt(strPartThree) End If ElseIf Len(strPartThree) = 4 Then ' Year is last (Format: DD-MM-YYYY) intYear = CInt(strPartThree) intMonth = CInt(strPartTwo) intDay = CInt(strPartOne) ElseIf Len(strPartTwo) = 4 Then ' Year is in the middle (Format: DD-YYYY-MM or MM-YYYY-DD) intYear = CInt(strPartTwo) If CInt(strPartOne) > 12 Then intDay = CInt(strPartOne) intMonth = CInt(strPartThree) ElseIf CInt(strPartThree) > 12 Then intDay = CInt(strPartThree) intMonth = CInt(strPartOne) Else intDay = CInt(strPartOne) intMonth = CInt(strPartThree) End If Else ' All parts are small numbers (Format: D-M-YY) intDay = CInt(strPartOne) intMonth = CInt(strPartTwo) intYear = CInt(strPartThree) ' Confirm year is in the correct range ' If the year is provided as a two-digit number, it will be treated as a year in the 2000s. If intYear < 100 Then intYear = intYear + 2000 End If End If End Sub واستبدل السطر الخاص بالمصفوفة المصفوفة القديمة بالمصفوفة الاتية SymbolsToRemove = Array("(", ")", "?", "*", " ", "!", "-", "#", "@", "+", "\", "/", "//", ".", "_", "--", "|", ",", Chr(227), Chr(34)) المرفق بعد التعديلات RectifyDate (V 2).accdb

بعد اذن استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @jjafferr فعلا الموضوع مهم وملح جدا جدا لمن يقع فى هذه الورطة خاصة مع كثرة عدد السجلات التى تحتوى على صيغ تواريخ مختلفة وبالاخص لو كانت بها مشاكل اثراء للموضوع صادفنى هذه المشكلة ذات مرة فى العمل وهذه هى الوظيفة التى قمت بكتابتها للتعامل مع مختلف الصيغ والتسيقات حسب المشاكل التى واجهتها آن ذاك Function RectifyDateFormat(inputString As String) As Variant ' Enable error handling ' This line sets up an error handling routine. If an error occurs in the code that follows, ' execution will jump to the ErrorHandler label, allowing for controlled error management. On Error GoTo ErrorHandler ' Remove leading and trailing spaces ' This line uses the Trim function to eliminate any spaces at the beginning and end of the input string. ' This is important for ensuring that the date format is clean and free of unnecessary spaces ' which could lead to incorrect parsing of date parts later in the function. inputString = Trim(inputString) ' Replace Indian numerals with standard numerals ' This block replaces Indian numerals (Unicode character codes from 1632 to 1641) with standard Arabic numerals (0-9). ' The loop iterates through the Unicode range for Indian numerals and replaces each occurrence ' in the input string with its equivalent standard numeral by calculating its index. Dim i As Integer For i = 1632 To 1641 inputString = Replace(inputString, ChrW(i), CStr(i - 1632)) Next i ' Replace non-standard symbols with hyphens ' This section defines an array of symbols that are considered non-standard for date formatting. ' The goal is to standardize the date input by replacing these symbols with hyphens, ' making it easier to parse the date parts later on. Dim SymbolsToRemove As Variant SymbolsToRemove = Array("(", ")", "?", "*", " ", "!", "\", "/", "//", ".", "_", "--", "|", ",", Chr(227), Chr(34)) inputString = ReplaceSymbols(inputString, SymbolsToRemove) ' Remove leading and trailing hyphens ' This line first replaces any occurrence of double hyphens (--) with a single hyphen (-). ' After replacing, Trim is used to remove any spaces around the string. ' This ensures that any malformed input resulting in multiple hyphens is corrected before further processing. inputString = CleanHyphens(inputString) ' Split the input string into date parts ' This line splits the cleaned input string into an array of date parts using the hyphen (-) as a delimiter. ' The result is stored in strDateParts, which will contain the individual components of the date (day, month, year). Dim strDateParts() As String strDateParts = Split(inputString, "-") ' Ensure the input contains exactly three parts ' This condition checks if the upper bound of the strDateParts array is not equal to 2. ' In VBA, the array index starts from 0, so an array with exactly three elements will have ' an upper bound of 2 (i.e., elements at index 0, 1, and 2). ' If the input does not contain exactly three parts, the function returns Null ' to indicate an invalid date format, and exits the function to prevent further processing. If UBound(strDateParts) <> 2 Then RectifyDateFormat = Null Exit Function End If ' Assign the split parts to variables, ensuring they are trimmed ' This line assigns the individual parts of the date from the strDateParts array ' to three separate variables (strPartOne, strPartTwo, strPartThree). ' The Trim function is used to remove any leading or trailing whitespace from each part. ' This ensures that any extra spaces do not affect the subsequent processing of date parts. Dim strPartOne As String, strPartTwo As String, strPartThree As String strPartOne = Trim(strDateParts(0)): strPartTwo = Trim(strDateParts(1)): strPartThree = Trim(strDateParts(2)) ' Debug output for each part ' This line outputs the individual parts of the date to the immediate window for debugging purposes. ' Debug.Print "Part One: " & strPartOne & " | Part Two: " & strPartTwo & " | Part Three: " & strPartThree ' Ensure that the parts can be converted to numbers ' This conditional statement checks if each of the date parts (strPartOne, strPartTwo, strPartThree) ' can be converted to a numeric value. It uses the IsNumeric function to evaluate whether ' each part is a valid number. If any of the parts cannot be converted to a number, it indicates ' an invalid date format. In this case, the function returns Null to signify that the input is not a valid date, ' and exits the function to prevent further processing. If Not IsNumeric(strPartOne) Or Not IsNumeric(strPartTwo) Or Not IsNumeric(strPartThree) Then RectifyDateFormat = Null Exit Function End If ' Declare integer variables for the day, month, and year ' These declarations create integer variables to hold the day, month, and year components of the date. ' These will be used for further processing and validation of the date before returning the formatted result. Dim intDay As Integer, intMonth As Integer, intYear As Integer ' Analyze the parts to determine their roles ' This block of code evaluates the lengths of the date parts to determine their roles as day, month, or year. ' Depending on the format of the input string, it assigns the appropriate values to intYear, intMonth, and intDay. AnalyzeDateParts strPartOne, strPartTwo, strPartThree, intDay, intMonth, intYear ' Validate the final values ' This conditional checks if the final values for day, month, and year are valid. ' If any value is outside the expected range, the function returns Null to indicate an invalid date. If Not IsValidDate(intDay, intMonth, intYear) Then RectifyDateFormat = Null Exit Function End If ' Create the date and format it ' This line creates a date using the DateSerial function, which takes year, month, and day as parameters. ' The resulting date is then formatted as a string in the "dd/mm/yyyy" format. ' The formatted date string is assigned to the function's return value, RectifyDateFormat. RectifyDateFormat = Format(DateSerial(intYear, intMonth, intDay), "dd/mm/yyyy") Exit Function ' This line exits the function normally. ' If no errors occur, the code will not reach the ErrorHandler section. ErrorHandler: ' Handle errors gracefully ' If an error occurs in the preceding code, this line sets the return value of the function to Null, ' indicating that the date format correction failed due to an error. RectifyDateFormat = Null End Function Private Function ReplaceSymbols(inputString As String, SymbolsToRemove As Variant) As String ' This function iterates through an array of symbols that should be replaced with hyphens. ' Each symbol in the SymbolsToRemove array is checked, and if it's not a hyphen, ' it is replaced in the input string with a hyphen. Dim strSymbol As Variant For Each strSymbol In SymbolsToRemove If strSymbol <> "-" Then inputString = Replace(inputString, strSymbol, "-") End If Next strSymbol ReplaceSymbols = inputString End Function Private Function CleanHyphens(inputString As String) As String ' This function replaces double hyphens with a single hyphen and trims the input string. inputString = Trim(Replace(inputString, "--", "-")) ' Remove leading hyphens ' This loop checks if the first character of the input string is a hyphen. ' If it is, the hyphen is removed by taking the substring starting from the second character. Do While Left(inputString, 1) = "-" inputString = Mid(inputString, 2) Loop ' Remove trailing hyphens ' This loop checks if the last character of the input string is a hyphen. ' If it is, the hyphen is removed by taking the substring up to the second-to-last character. Do While Right(inputString, 1) = "-" inputString = Left(inputString, Len(inputString) - 1) Loop CleanHyphens = inputString End Function Private Sub AnalyzeDateParts(strPartOne As String, strPartTwo As String, strPartThree As String, _ ByRef intDay As Integer, ByRef intMonth As Integer, ByRef intYear As Integer) ' This subroutine analyzes the lengths of the date parts to determine their roles as day, month, or year. ' Depending on the format of the input string, it assigns the appropriate values to intYear, intMonth, and intDay. If Len(strPartOne) = 4 Then ' Year is first (Format: YYYY-MM-DD) intYear = CInt(strPartOne) intMonth = CInt(strPartTwo) intDay = CInt(strPartThree) ElseIf Len(strPartThree) = 4 Then ' Year is last (Format: DD-MM-YYYY) intYear = CInt(strPartThree) intMonth = CInt(strPartTwo) intDay = CInt(strPartOne) ElseIf Len(strPartTwo) = 4 Then ' Year is in the middle (Format: DD-YYYY-MM or MM-YYYY-DD) intYear = CInt(strPartTwo) If CInt(strPartOne) > 12 Then intDay = CInt(strPartOne) intMonth = CInt(strPartThree) ElseIf CInt(strPartThree) > 12 Then intDay = CInt(strPartThree) intMonth = CInt(strPartOne) Else intDay = CInt(strPartOne) intMonth = CInt(strPartThree) End If Else ' All parts are small numbers (Format: D-M-YY) intDay = CInt(strPartOne) intMonth = CInt(strPartTwo) intYear = CInt(strPartThree) ' Confirm year is in the correct range ' If the year is provided as a two-digit number, it will be treated as a year in the 2000s. If intYear < 100 Then intYear = intYear + 2000 End If End If End Sub Private Function IsValidDate(intDay As Integer, intMonth As Integer, intYear As Integer) As Boolean ' This function checks if the provided day, month, and year are valid. ' It verifies that the month is between 1 and 12 and that the day is appropriate ' for the given month and year (not exceeding 31 for any month). IsValidDate = (intMonth >= 1 And intMonth <= 12) And _ (intDay >= 1 And intDay <= 31) And _ (intYear >= 1900 And intYear <= 2100) End Function وللتجربة لكل الحالات تقريبا من داخل المحرر '************************************************************************************************************************************* ' Sub: TestRectifyDateFormat ' Purpose: This subroutine tests the RectifyDateFormat function with various input date strings ' to ensure that the function handles different formats and returns the expected results. ' ' Usage: Call TestRectifyDateFormat to run the tests and print the results to the debug output. ' '********************************************************************** ' Author: officena.net™ , Mohammed Essam © , soul-angel@msn.com ® ' Date: October 2024 '********************************************************************** Sub TestRectifyDateFormat() Dim testDate As String Dim result As Variant ' Test various date formats testDate = "30/11/2009" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "2012-06-25" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "21/6/2015م" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = """ 9/1/2014""" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "30\11\2009" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "5/1999/26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "25/1999/6" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "5/1994/ 26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "5 1995 26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "6 1996 26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result End Sub RectifyDate.accdb

السلام عليكم ورحمة الله تعالى وبركاته تم تلافى الكثير من المشاكل وتم تحديث النسخة اليوم اليكم الاصدار الجديد ان شاء الله فى رأس الموضوع أو يمكنكم تحميل التعديل الاخيــر من >>---> تحميل التحديث للإصدار الأخير

ممكن توضيح اكثر يعنى اى قصدك من اضافة اى بيانات من مصدر خارجى ؟؟؟؟

فهم السؤال هو شطر الجواب ان لم يكن ثلثى الجواب والى الان لم يستطيع احد فهم السؤال المشكلة عند حضرتك فى عدم توضيح السؤال بشكل كاف وعدم وضع تصورات بشكل واف يا حبذا لو تضع النتيجة المطلوبة لاكثر من سجل

طيب وبعد التحليل للمرفق ومن غير اى اكواد ممكن جملة الاستعلام دى تحل لك كل مشاكلك SELECT Table1.code, Table1.test, Table1.result, Table2.Cal, Nz([result], 0)/Nz([Cal], 1) AS FinalCalc FROM Table1 INNER JOIN Table2 ON Table1.code = Table2.code; وما اخدت بالى من موضوع التقريب لو اردنا استخدام التقريب تكون جملة الاستعلام بالشكل التالى SELECT Table1.code, Table1.test, Table1.result, Table2.Cal, IIf(Nz([result], 0) <> 0 And Nz([Cal], 1) <> 0, Round(Nz([result], 0) / Nz([Cal], 1), 3), Nz([result], 0) / Nz([Cal], 1)) AS FinalCalc FROM Table1 INNER JOIN Table2 ON Table1.code = Table2.code; وهذا هو المرفق انظر الى الاستعلام مباشرة وغير القيم فى الحقل Cal تظهر لك النتيجة المرجوة مباشرة فى الحقل FinalCalc دا اذا كنت قدرت افهم انت عاوز ايه Cal error.accdb

انا حاولت اكثر من ساعة احاول افهم هو عاوز ايه ومقدرتش افهم والله على العمود طبعا انا اتفق تماما مع رأى استاذى الجليل و ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل ولأنه لم نفهم الية العمل او فكرة صاحب المسألة هذه فكرتى وظيفة ثغنونه وبنت حلال تعمل كل ده Function GetDLookupResult(code1 As Long, code2 As Long) As Double Dim result1 As Variant Dim result2 As Variant ' Retrieve the value from Table1 based on the passed values result1 = DLookup("result", "Table1", "[code] = " & code1) result2 = DLookup("result", "Table1", "[code] = " & code2) ' Check if the values are not null to avoid errors If IsNull(result1) Or IsNull(result2) Then GetDLookupResult = 0 ' Or return a blank value or an error message Exit Function End If ' Calculate the final result GetDLookupResult = result1 / result2 End Function مرر القيم التى تريد اليها بالشكل التالى من خلال زر الامر Dim finalResult As Double finalResult = GetDLookupResult(33, 36) Me.C = finalResult

جزاك الله خيرا الله يرحم والديك وكل المسلمين يارب

طيب من واقع مرفع حضرتك الاخير يا استاذ @UserUser2 ممكن نمشى خطوة خطوة اولا لما نفتح النموذج حضرتك عاوز تكتب ايه فى مربع النص ؟ وطبعا بناء على ما سوف يتم كتابته فى مربع النص نبتدى نفكر فى الكود على زر الامر خلينا بس نمشى خطوة تلو الاخرى لان لحد دلوقتى محدش قادر يفهم حضرتك عاوز تعمل ايه

فى الواقع يا استاذى الجليل و معلمى القدير و والدى الحبيب استاذ @jjafferr الخسارة الفعلية والحقيقية لنا نحن طلاب العلم من غياب اساتذتنا العظماء اركان هذا الصرح الشامخ والفضل كل الفضل لكم من بعد رب العزة سبحانه وتعالى شكر الله لكم حسن حلمكم وكرم اخلاقكم فى نقل خبراتكم وتعليمكم روعايتكم لنا ... جزاكم الله تعالى عنى وعن كل طلاب العلم كل الخير ويعلم الله انه منذ وقت انضمامى الى هذا الصرح الشامخ اول ما ابحث عنه عندما ادخل المنتدى ردود ومشاركات حضرتك واستاذى الجليل و ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل والاستاذ @أبو إبراهيم الغامدي والاستاذ @رمهان و الاستاذ @أبا عمر والاستاذ @SEMO.Pa3x و الاستاذ @أبو آدم وغيرهم الكثير الذين تعلمت انا شخصيا ولازلت حتى الان اتعلم من مشاركتهم حتى ولو كانت قديمه منهم من طال غيابه ومنهم من يدخل حسبما يسمح وقته اسأل الله تعالى لكل اساتذتى العظماء الذين ذكرتهم والذين لم اذكرهم ولكل من تعلمنا منهم وعلى ايديهم بكل حرف حسنه وان يضاعف لهم من فضله الكريم اضعافا مضاعفة واسأله ان يُكتب لهم فى موزاين اعمالهم علم ينتفع به وصدقة جارية الى يوم الدين ان شاء الله ... اللهم امين امين امين احبكم فى الله

اعتذر على التأخير اتفضل يا سيدى تم تحويل القاعدة للتنسيق 2000 بامتداد mdb الاكواد تعمل على النواتان 32 , 64 بيت Security(Enable-Disable Shift Key).zip

يا دكتور ممكن المرفق علشان افهم واشوف تم استدعاء الدالة امتى وفين لان وظيفة الدالة حفظ السجل الحالى بالتالى اى مستخدم اخر المفروض عند عمل سجل جديد وتوليد رقم فاتورة يتعامل مع سجل جديد غير السجل الذى تم حفظه وبالتالى لن يحدث اى تعارض

تم اضافة اصدار جديد لتنقيح وتفادى بعض الاخطاء بتاريخ 22/09/2024 - ضبط اسهم زيادة او نقصان الشهور والسنوات تبعا لترتيب واجهة ترتيب التواريخ ( يمين / يسار ) - ضبط الفتح التلقائى لقائمة السنوات او الشهور لاغلاقها اذا كانت مفتوحة بدلا من اعادة فتح القائمة مرة اخرى عند تكرارا الضغط رقم الاصدار الجديد 4 يمكن تحميل مرفق الاصدار الجديد من رأس الموضوع او من هنا Handler - calendar (V4).accdb

طيب فى حلين اولا الحل البسيط عمل دالة للحفظ وتتم مباشرة بعد توليد رقم الفاتورة Private Sub DoSave() On Error GoTo ErrorHandler ' Check if there are unsaved changes If Me.Dirty Then ' Save the current record DoCmd.RunCommand acCmdSaveRecord End If ' Exit the sub normally Exit Sub ErrorHandler: ' Handle the error and display a message with the error number and description MsgBox "Error occurred while saving the record: " & Err.Number & " - " & Err.Description, vbCritical, "Error" ' Resume to the end of the sub after handling the error Resume ExitHandler ExitHandler: ' End of the sub Exit Sub End Sub الحل الثانى مشاركة لاستاذى الجليل و معلمى القدير و و الدى الحبيب الستاذ @jjafferr اليك الموضوع كاملا

السلام عليكم ورحمة الله تعالى وبركاته طبعا قد يقول البعض ان الموضوع اتهرس فى ميت فيلم عربى قبل كده لكن على كل حال تم تدارك الكثير من المشاكل ومعالجتها بشكل احترافى - اخفاء اطار لاكسس بالشكل الطبيعى والتقليدى لعرض النموذج كاملا - اخفاء اطار الاكسس وعمل شفافية للنموذج لاظهار صور png او حسب خيال المسخدم - تم ضبط كواد التوسيط للنماذج والتقارير باحترافية ويعمل التوسيط مع الخاصية Pop Up فى اى وضع كانت فى حالة عدم استخدام الاخفاء - تم حل مشكلة عدم ظهور التقاربر عند الاخفاء بتكبير التقرير تلقائيا عند استخدام كود الاخفاء - امكانبة التصغير للتطبيق بجوار الساعة ( System Try ) - عند التصغير بجوار الساعة ممكن الضغط كليك يمين على الايقونة لتظهر قائمة اختيارات - تم ضبط كود تغير ايقونة الاكسس باحترافية وبشكل تلقائى من المسار المحدد او فى حالة عدم وجود الايقونة ترجع ايقونة الاكسس - تم التعامل مع الاكواد بحرفية تامة للعمل على بيئات الأنوية المختلفة سواء كانت 32 , 64 اترككم مع تجربة شيقة ملاحظة هامة : ارضاء للجميع ولاضفاء اكبر قدر ممكن من المرونة المرفق يحتوى على قاعدتان الاولى : تم تجميع كل الاكواد والدوال فى وحدة نمطية عامة واحدة وكلاس موديول واحد لسهولة الاستفادة منها ونقلهم الى اى قاعدة الثانية : فصل اكواد كل وظيفة على حدة فى مديول خاص بها تم اضافة تعديل وتحديث جديد بتاريخ 11/10/2024 رقم اصدار التعديل الاخيــر : 4.8 center and Hid and Tray Minimizer V 30.zip center and Hid and Tray Minimizer V 4.8.rar

مبدئيا اعمل وحدة نمطية جديدة وسميها مثلا: basInputBoxWithMask ضع الاكواد الاتية بالوحدة النمطية Option Compare Database Option Explicit '********************************************************************** ' Module: MaskedInputBox ' Purpose: This module provides functionality to create an InputBox ' with masked input, displaying characters as asterisks (*) ' typically used for password entry. ' ' API Declarations: ' - CallNextHookEx: Passes the hook information to the next hook procedure in the current hook chain. ' - GetModuleHandle: Retrieves a module handle for the specified module. ' - SetWindowsHookEx: Installs a hook procedure into the hook chain. ' - UnhookWindowsHookEx: Removes a hook procedure installed in a hook chain. ' - SendDlgItemMessage: Sends a message to a control in a dialog box. ' - GetClassName: Retrieves the name of the class to which the specified window belongs. ' - GetCurrentThreadId: Retrieves the thread identifier of the calling thread. ' ' Constants: ' - EM_SETPASSWORDCHAR: Used to specify the character to be displayed when text is entered in a password field. ' - WH_CBT: Hook type for monitoring and modifying Computer-Based Training (CBT) events. ' - HCBT_ACTIVATE: Hook code that is sent when a window is about to be activated. ' - HC_ACTION: Indicates a valid action has taken place, allowing processing to continue. ' ' Author: Officena.net, Mohammed Essm, soul-angel@msn.com ' Date: August 2024 '********************************************************************** #If VBA7 Or Win64 Then Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As Any) As LongPtr Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long #Else Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Any) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long #End If ' Constants to be used in our API functions Private Const EM_SETPASSWORDCHAR = &HCC Private Const WH_CBT = 5 Private Const HCBT_ACTIVATE = 5 Private Const HC_ACTION = 0 #If VBA7 Or Win64 Then Private hHook As LongPtr #Else Private hHook As Long #End If '********************************************************************** ' Function: NewProc ' Purpose: This function is the hook procedure that processes CBT ' events, specifically to mask input characters in an InputBox. ' Inputs: ' - lngCode: The code of the event (Long). ' - wParam: A handle to the window related to the event (Long). ' - lParam: Pointer to an event-specific structure (Long). ' Returns: - LongPtr: The result from the next hook procedure or 0 if handled. ' Notes: ' - Only processes events with code >= HC_ACTION. ' - Checks for dialog box activation and sets the password character. ' ' Author: Officena.net, Mohammed Essm, soul-angel@msn.com ' Date: August 2024 '********************************************************************** Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPtr Dim strClassName As String Dim lngBuffer As Long Dim result As Long ' Proceed only if the message code is an action code If lngCode < HC_ACTION Then NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam) Exit Function End If ' Get the class name of the window being activated strClassName = String$(256, " ") lngBuffer = 255 If lngCode = HCBT_ACTIVATE Then result = GetClassName(wParam, strClassName, lngBuffer) ' Check if the class name is a dialog box ("#32770") If Left$(strClassName, result) = "#32770" Then ' Set the character for password masking SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0 End If End If ' Call the next hook in the chain and return its value NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam) End Function '********************************************************************** ' Function: InputBoxDK ' Purpose: Displays an InputBox with masked input, showing each character ' as an asterisk (*) instead of the actual character. ' Inputs: ' - Prompt: The prompt string displayed in the InputBox (String). ' - Optional Title: The title of the InputBox window (String). ' - Optional Default: The default string displayed in the InputBox (String). ' - Optional XPos: The x-coordinate of the InputBox (Long). ' - Optional YPos: The y-coordinate of the InputBox (Long). ' - Optional HelpFile: The name of the Help file for the InputBox (String). ' - Optional Context: The Help context number for the InputBox (Long). ' Returns: - String: The string entered by the user in the InputBox. ' Notes: ' - Hooks into the CBT events to mask the input as the user types. ' - The hook is removed after the InputBox is closed to prevent resource leaks. ' ' Author: Officena.net, Mohammed Essm, soul-angel@msn.com ' Date: August 2024 '********************************************************************** Public Function InputBoxDK(Prompt As String, Optional Title As String, Optional Default As String, Optional XPos As Long, Optional YPos As Long, Optional HelpFile As String, Optional Context As Long) As String On Error GoTo ExitProperly Dim lngModHwnd As LongPtr Dim lngThreadID As Long ' Get the current thread ID and module handle lngThreadID = GetCurrentThreadId lngModHwnd = GetModuleHandle(vbNullString) ' Set the hook for CBT (Computer-Based Training) to monitor and modify dialog box creation hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID) ' Show the InputBox InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context) ExitProperly: ' Ensure the hook is removed to prevent resource leaks If hHook <> 0 Then UnhookWindowsHookEx (hHook) End Function بالنسبة للنموذج دى الاكواد وطبعا لا انصح باستخدام اللغة العربية داخل المحرر Option Compare Database Option Explicit Private Sub Command4_Click() DoCmd.GoToRecord , , acNewRec End Sub '********************************************************************** ' Subroutine: Checkbox_AfterUpdate ' Purpose: Toggles the InputMask property of a password input field based on the state of a checkbox. ' When the checkbox is checked, the password is displayed as plain text; ' when unchecked, the password is masked with the "Password" mask. ' Inputs: ' - None (uses the current state of the form's controls). ' Outputs: ' - None (modifies the InputMask property of the "pass" control). ' Notes: ' - This subroutine assumes that "Checkbox" is a control on the form and is tied to ' the user's action of toggling the checkbox. ' - If the checkbox is checked (True), the password will be shown in plain text. ' - If unchecked (False), the password will be masked. ' ' Author: Officena.net, Mohammed Essm, soul-angel@msn.com ' Date: August 2024 '********************************************************************** Private Sub Checkbox_AfterUpdate() ' Check the value of the checkbox and update the InputMask of the "pass" field accordingly If Me.Checkbox.Value = True Then Me.pass.InputMask = "" ' Show the password as plain text Else Me.pass.InputMask = "Password" ' Mask the password with the "Password" input mask End If End Sub '********************************************************************** ' Subroutine: jop_AfterUpdate ' Purpose: Validates the job role entered by the user and enforces role-specific constraints. ' If the job role is "مستخدم" (User), it checks if the maximum allowed number of ' users has been reached. If so, it prompts for a password to allow adding more users. ' Inputs: ' - None (uses the current state of the form's controls). ' Outputs: ' - None (may prevent form submission based on validation checks). ' Notes: ' - The subroutine assumes "jop" is a control on the form where the user selects their job role. ' - If the job role is not "محاسب" (Accountant) or "مستخدم" (User), an error message is shown, ' and the action is canceled. ' - If the job role is "مستخدم", the subroutine checks the number of existing users in the database. ' If there are already 3 users, the subroutine prompts for a password before allowing more users to be added. ' - The password required to add more users is hardcoded as "123". This should be secured in a production environment. ' ' Author: Officena.net, Mohammed Essm, soul-angel@msn.com ' Date: August 2024 '********************************************************************** Private Sub jop_BeforeUpdate(Cancel As Integer) Dim db As DAO.Database Dim rs As DAO.Recordset Dim UserCount As Integer Dim PasswordInput As String ' Get the current database Set db = CurrentDb() ' Validate the job role entered by the user If Me.jop.Value <> "محاسب" And Me.jop.Value <> "مستخدم" Then MsgBox "برجاء إدخال كلمة محاسب أو مستخدم فقط.", vbExclamation, "قيمة غير صحيحة" Cancel = True Exit Sub End If ' If the job role is "مستخدم", check the number of existing users If Me.jop.Value = "مستخدم" Then Set rs = db.OpenRecordset("SELECT COUNT(*) AS CountOfUsers FROM tblUsers WHERE jop = 'مستخدم'") UserCount = rs!CountOfUsers ' If the maximum number of users has been reached, prompt for a password If UserCount >= 3 Then PasswordInput = InputBoxDK("لقد تم إدخال 3 سجلات لمستخدمين. يرجى إدخال كلمة السر لإضافة مستخدم جديد:") ' Validate the entered password If PasswordInput = "" Or PasswordInput <> "123" Then MsgBox "كلمة السر غير صحيحة. لا يمكن إضافة مستخدم جديد.", vbExclamation Cancel = True End If End If rs.Close Set rs = Nothing End If ' Clean up Set db = Nothing End Sub

مش تقول يا دكتور ان انت عاوز كلمة السر مع inputbox

اعتذر للتأخير يا دكتور اقرأ مقال مايكروسوفت ده الدنيا هتوضح اكثر وهتكون مدرك كمان للتغيرات التى يجب ان تحدث لعمل التوافقية لكل نواة https://learn.microsoft.com/ar-sa/office/client-developer/shared/compatibility-between-the-32-bit-and-64-bit-versions-of-office

فى خاضية اسمها input mask للحقل فى الجدول كل ما عليك انك تغيرها وتخليها : Password وبرضو ده موجود فى خصائص مربع النص فى النموذج كمان لو اردت اضافة مرع اختيار check box بحيث لما تخليه صح يظهر الباسور ولما تغيره يظهر النجوم تانى افترض ان مربع الاختيار ده اسمه: Checkbox وافترض ان مربع نص الذى يستخدم لكلمة المرور اسمه: pass استخد الكود التالي فى حدث بعد التحديث ل checkbox Private Sub Checkbox_AfterUpdate() If Me.Checkbox.Value = True Then: Me.pass.InputMask = "": Else: Me.pass.InputMask = "Password" End Sub

يا رجل يا طيب انت غيرت التصميم و أخرجته بهذا الابداع دا غير الوقت وبذل الجهد لمرات عديدة فى التجربة مرارا وتكرارا واكتشاف المشاكل و الاخطاء الى ان تم علاجها جميعا تقريبا بفضل الله ثم جهد ومتابعة حضرتك جزاكم الله خيرا يا طيب 😚

اى برامج يتم تصميمها بالشكل الطبيعى تعمل على النواتان يا دكتور بدون اى مشاكل اما الاكواد والتى تعتمد الربط الديناميكى Dynamic Link Libraries اى التى تعتمد على ما نسميه بملفات DLL بناء على دوال API أى Application Programming Interface يعنى واجهة برمجة التطبيقات مثلا مثل Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long هى التى تحتاج الى معاملة من نوع خاص لاعادة صياغتها لتعمل على النواتان وهذا ما تناوله استاذى القدير و معلمى الجليل الاستاذ @jjafferr فى موضوعه

السلام عليكم ورحمة الله تعالى وبركاته • هدية اليوم هى منتقى التواريخ تم الانتهاء من البرمجة والتطوير بالتعاون مع الاستاذ @Moosak ابداع وروعة وجمال تنسيق التصميم قام به اخى الحبيب و استاذى الجليل الاستاذ @Moosak كل الشكر والتقدير والامتنان على تعبه وحرصه على ان يخرج التطبيق بهذه الافكار الى النور فى ابهى صورة بهذا الشكل مميزات التطبيق وجود جدولين الجدول الاول : tblHolidaySettings هذا الجدول وظيفته هى التأشير على ايام العطلات الاسبوعية تبعا للمؤسسة وبذلك يتم تلوين ايام العطلات لتكون مميزة باللون الاحمر وهذا مثال لاختيار يوميى الجمعة والسبت الجدول الثانى : هذا الجدول وظيفتة اضافة تواريخ العطلات الرسمية للدولة و وصف العطلة عند الانتهاء من تسجيل كل العطلات الرسمية للدولة فى الجدول وبعد فتح منتقى التواريخ تبعا لكل شهر تظهر قائمة بالاعياد والمناسبات الرسمية ويتم تغيير لون خلفية اليوم ليكون معروفا من خلال النظر انه عطلة رسمية وبمجرد التحرك من الاسهم فى لوحة المفاتيح للمرور على الايام او اختيار اليوم بضغطة زر واحدة من الفأرة يتم ظهور وصف العطلة الرسمية فى اسفل مربعات الايام كما بالشكل التالى لاختار اليوم اما بالنقر مرتين على رقم اليوم او تحريك علامة الدائرة الزرقاء لتحديد اليوم من خلال ازرار الاسهم من لوحة المقاتيح ثم الضغط على زر اختيار والموجود بالاسفل يسار النموذج زر الامر المسمى اليوم الحالى ينقل فورا الدائرة الزرقاء الى رقم اليوم الذى يوافق تاريخ اليوم يمكن تغيير اتجاه ترتيب الارقام لتبدأ من اليمين الى اليسار او العكس من خلال الزر الموجود بجوار زر اليوم الحالى : ⇋ طريقة استدعاء الدالة لتعمل مع اى مربع نص يستخدم لادخال و كتابة التواريخ تكون كالاتى عمل زر امر بجوار مربع النص وفى منشئ التعبير لحدث النقر لهذا الزر يتم استدعاء الدالة بالشكل التالى على ان يتم تغير الوصف و اسم مربع النص تبعا لاغراض التصميم =CalendarFor([اسم مربع النص فى النموذج],"اكتب الوصف الدال على مربع نص التاريخ :") ملاحظة الوصف الذى سوف يتم كتابته اثناء استدعاء الدالة سوف يطهر فى اعلى يمين النموذج تحت زر الامر الغاء وان كان مربع النص الخاص بالتاريخ يحتوى بالفع على تاريخ سوف تجد هذا التاريخ ايضا تحت هذا الوصف وشرح الوظائف المختلفة للازرار من لوحة المفاتيح التى يمكن التعامل معها بسهولة موجود فى الزر اعلى اليسار " ؟ " اتمنى لكم تجربة شيقة واتمنى ان اكون قدمت اليكم شيئا عمليا ويعود عليكم بالنفع تم اضافة اصدار جديد لتنقيح وتفادى بعض الاخطاء بتاريخ 22/09/2024 - ضبط اسهم زيادة او نقصان الشهور والسنوات تبعا لترتيب واجهة ترتيب التواريخ ( يمين / يسار ) - ضبط الفتح التلقائى لقائمة السنوات او الشهور لاغلاقها اذا كانت مفتوحة بدلا من اعادة فتح القائمة مرة اخرى عند تكرارا الضغط رقم الاصدار الجديد 4 Handler - calendar (V3).zip Handler - calendar (V4).accdb