البحث في الموقع

السلام عليكم ورحمة الله وبركاته اليوم اقدم لك وظيفة مُطَهَّرُ النُّصُوصِ الْعَرَبِيَّةِ غاية فى الروعة ومكتوبة بعناية واحترافية للحصول على اكبر قدر ممكن من الدقة فى الاداء والمرونة فى التناول عند الاستدعاء حيث أن الكود يعالج النصوص العربية بطريقة مرنة مع التركيز على ازالة المسافات وتنظيف النص و إزالة التشكيل و توحيد الاحرف ومعالجتها يعتمد الكود خيارين للعمل (إزالة المسافات أو التطبيع "توحيد الاشكال المختلفة للاحرف" ) مما يجعله قابلاً للتخصيص بناءً على الحاجة على سبيل المثال النص الاصلى والذى نريد معالجته : "تَجْرِبَةُ إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 101" الحالات التى يمكن الحصول عليها من معالجة النص السابق هى ازالة المسافات فقط وتنظيف النص مع الابقاء على الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم 101 ازالة المسافات وتنظيف النص مع الابقاء على الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم 101 ازالة المسافات وتنظيف النص مع ازالة الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم ازالة المسافات فقط وتنظيف النص مع ازالة الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم الكود ' Function: ArabicTextSanitizer ' Purpose: Sanitizes Arabic text by removing non-Arabic characters, optionally normalizing the text, ' removing diacritics (harakat), and optionally removing numeric characters or spaces. ' Parameters: ' inputText (String): The Arabic text to be sanitized. It can contain Arabic characters, non-Arabic characters, ' diacritics, and numeric values. ' normalize (Boolean): Optional. If True, the text will be normalized by replacing specific Arabic characters ' with their standardized equivalents (default is True). ' RemoveNumbers (Boolean): Optional. If True, numeric characters (0-9) will be removed from the text (default is True). ' removeSpaces (Boolean): Optional. If True, all spaces in the text will be removed (default is False). ' Returns: ' String: The sanitized Arabic text with optional normalization, removal of numbers, and spaces. ' ' Example Use Cases: ' 1. Remove spaces only and clean the text while keeping numbers without normalization: ' ' Removes spaces from the text while keeping numbers and without normalizing the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, False, True) ' ' 2. Remove spaces and clean the text while keeping numbers and normalizing: ' ' Normalizes the text and removes spaces, while keeping numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, False, True) ' ' 3. Remove spaces and clean the text while removing numbers and normalizing: ' ' Normalizes the text, removes spaces, and removes numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, True, True) ' ' 4. Remove spaces only and clean the text while removing numbers without normalization: ' ' Removes spaces and numbers, but does not normalize the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, True, True) ' Public Function ArabicTextSanitizer(inputText As String, Optional normalize As Boolean = True, Optional RemoveNumbers As Boolean = True) As String On Error GoTo ErrorHandler ' Ensure the input is valid (non-empty and not null) If Nz(inputText, "") = "" Then ArabicTextSanitizer = "" Exit Function End If ' Initialize the sanitizedText with the trimmed input Dim sanitizedText As String sanitizedText = Trim(inputText) ' Step 1: Normalize the text if requested If normalize Then ' Define character replacement pairs for normalization Dim charReplacementPairs As Variant charReplacementPairs = Array( _ Array(ChrW(1573), ChrW(1575)), _ Array(ChrW(1571), ChrW(1575)), _ Array(ChrW(1570), ChrW(1575)), _ Array(ChrW(1572), ChrW(1608)), _ Array(ChrW(1574), ChrW(1609)), _ Array(ChrW(1609), ChrW(1610)), _ Array(ChrW(1577), ChrW(1607)), _ Array(ChrW(1705), ChrW(1603)), _ Array(ChrW(1670), ChrW(1580))) ' Apply replacements for character normalization Dim pair As Variant For Each pair In charReplacementPairs sanitizedText = Replace(sanitizedText, pair(0), pair(1)) Next ' Step 2: Remove diacritics (harakat) from the text Dim diacritics As String diacritics = ChrW(1600) & ChrW(1611) & ChrW(1612) & ChrW(1613) & ChrW(1614) & ChrW(1615) & ChrW(1616) & ChrW(1617) & ChrW(1618) Dim i As Integer For i = 1 To Len(diacritics) sanitizedText = Replace(sanitizedText, Mid(diacritics, i, 1), "") Next End If ' Step 3: Retain only Arabic characters, spaces, and optionally numbers Dim tempChars() As String Dim charIndex As Long Dim intChar As Integer Dim finalResultText As String ' Iterate through each character in the sanitized text For i = 1 To Len(sanitizedText) intChar = AscW(Mid(sanitizedText, i, 1)) ' Check for Arabic characters (range for Arabic characters and spaces) If intChar = 32 Or _ (intChar >= 1569 And intChar <= 1594) Or _ (intChar >= 1601 And intChar <= 1610) Or _ (intChar >= 1648 And intChar <= 1649) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 ' Optionally, check for numbers if RemoveNumbers is False ElseIf Not RemoveNumbers And (intChar >= 48 And intChar <= 57) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 End If Next ' Step 4: Join the valid characters into a final result text finalResultText = Join(tempChars, "") ' Step 5: Remove extra spaces (multiple consecutive spaces replaced with a single space) finalResultText = Replace(finalResultText, " ", " ") ' Improved space replacement Do While InStr(finalResultText, " ") > 0 finalResultText = Replace(finalResultText, " ", " ") Loop ' Step 6: Remove special characters (if needed) finalResultText = Replace(finalResultText, "*", "") finalResultText = Replace(finalResultText, "#", "") finalResultText = Replace(finalResultText, "@", "") finalResultText = Replace(finalResultText, ",", "") ' Return the sanitized text If Len(Trim(Nz(finalResultText, ""))) = 0 Then ArabicTextSanitizer = vbNullString Else ArabicTextSanitizer = finalResultText End If Exit Function ErrorHandler: Debug.Print "Error in ArabicTextSanitizer: " & Err.Description ArabicTextSanitizer = "" End Function وهذه الوظيفة تبين اشكال وطرق الاستدعاء المختلفة ' Subroutine: TestArabicTextSanitizer ' Purpose: Demonstrates and validates the functionality of the ArabicTextSanitizer function. ' It shows various test cases for sanitizing Arabic text with diacritics, non-Arabic characters, and numbers. Sub TestArabicTextSanitizer() ' Declare input and result variables Dim inputArabicText As String Dim result As String ' Example input text with diacritics, non-Arabic characters, and numbers inputArabicText = "تَجْرِبَةُ * فَاحِصِهِ # @ , لِعَمَلٍ أَلِكَوَّدِ فِىَّ شَتِّيَّ 3ألْإِشْكآل " & _ "إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 5 و الْمَكَانِ رَقْمٌ 100100ِ لمعرفة كيف سيعمل ها ألكود" ' Display the original input Arabic text Debug.Print "Input Arabic Text: " & inputArabicText ' Test case 1: Remove diacritics without normalization ' This case removes diacritics (harakat) without altering normalization or removing numbers result = ArabicTextSanitizer(inputArabicText, False, False) Debug.Print "Filtered Arabic Text (case 1 - Remove diacritics without normalization): " & result ' Test case 2: Normalize and remove diacritics ' This case normalizes the text (e.g., converting similar Arabic characters) and removes diacritics result = ArabicTextSanitizer(inputArabicText, True, False) Debug.Print "Normalized Arabic Text and Removed Diacritics (case 2): " & result ' Test case 3: Remove numbers as well (Optional argument set to True to remove numbers) ' This case normalizes the text and removes both diacritics and numbers result = ArabicTextSanitizer(inputArabicText, True, True) Debug.Print "Text without Numbers and Normalized (case 3): " & result ' Test case 4: Just remove diacritics without normalization or removing numbers ' This case removes diacritics and numbers, but does not normalize the text result = ArabicTextSanitizer(inputArabicText, False, True) Debug.Print "Text without Diacritics and Numbers (case 4): " & result End Sub واخيرا اليكم مرفق للتجربة Arabic Text Sanitizer.accdb

اداة البحث هذه قمت بمحاولة تجميع الافكار فيها بعناية وبترتيبها لمحاولة الوصول الى اقصى درجات الكفائة والمرونة الممكنة اولا : تعرية وتطهير النص والتحكم فى ذلك حسب الحاجة كما سبق التنويه عن هذه الجزئية فى هذا الموضوع ثانيا : التحكم فى اعداد مصادر البيانت :- (مصدر البيانات"جدول /استعلام" - الحقولالبحث المخصصة - امكانية اضافة حقل او اكثر يعتمد على تطهير النصوص ثالثا : آلية البحث بحيث يمكن البحث من خلال ( الكلمة تبدأ بـ - تنتهى بـ - يتضمن الكلمة فى امكان - او متطابق تماما او لو عدد الكلمات كثير يمكن كتابة جزء من كل كلمة فى نفس السجل ولا يشترط الترتيب ) مثال : نريد البحث فى السجل قيمة هذا السجل : 26675 فوزي عبد الحميد ابو الفتوح محمد سعده لو تم اختيار من إعدادت البحث : يحتوى على اكثر من كلمة او جزء من كلمه يفصل بينهم مسافة من إعدادت البحث ثم كتبنا فى مربع البحث : عب فت سع 66 نحصل على النتيجة اثناء كتابة الكود تم عمل جدول باسم : tblSearchSettings بحيث يتم حفظ الاعدادت الخاصة بعملية البحث والفرز والتصفية تم وضع القيم الافتراضية لاجراء عمليات البحث والفرز والتصفية المتعددة على اكمل وجهة فى حالة حذف الجدول الخاص باعدادت البحث كما انها تمثل مرونة قصوى لكل مستخدم على حدى فى حالة استخدام شبكة محلية يستطيع كل مستخدم الاحتفاظ بالاعدادت التى تناسبه دون التأثير على الاخرين اخيرا المرفق واترككم مع التجربة Search Utility V 3.0.2.accdb

السلام عليكم ورحمة الله تعالى وبركاته طبعا قد يقول البعض ان الموضوع اتهرس فى ميت فيلم عربى قبل كده لكن على كل حال تم تدارك الكثير من المشاكل ومعالجتها بشكل احترافى - اخفاء اطار لاكسس بالشكل الطبيعى والتقليدى لعرض النموذج كاملا - اخفاء اطار الاكسس وعمل شفافية للنموذج لاظهار صور 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

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

السلام عليكم ورحمة الله تعالى وبركاته اليوم اقدم لكم هدية صغيرة ولكن النفع من ورائها عظيم جدا قد ينتج عن الكود اخطاء عند كتابة الكود قد نحتاج تتبع نتائج الكود قد محتاج معرفة القيم التى يعيدهها الكود قد نكتب استعلام مثلا زنقطع الاسطر ونضيف متغيرات نمرر منها قيما الى الاستعلام ونريد معرفة كبف سوف يراه الحاسوب فى النهاية وقد وقد و ........ الخ وهناك الكثير والكثير وما ذطرته هو فقط على سبيل المثال وليس الحصر اتتنى فكرة وهى كتابة كود فى موديول ليسهل الامور على مصممى قواعد البيانات فيضفى المرونة فى التعامل وكذا الاحترافية التامة مع هذا الامر وهو استخدام: Debug.Print وحتى لا اطيل عليكم اليكم الاكواد Option Compare Database Option Explicit '********************************************************************** ' Function: DebugPrint ' Purpose: Prints a message to the Immediate Window in the VBA editor and optionally logs it to a file. ' Inputs: ' Message - The message to be printed (String). ' Optional AddNewLine - A Boolean flag to add a new line after printing (default is True). ' Optional Prefix - A string to prefix the message (default is ""). ' Optional Suffix - A string to suffix the message (default is ""). ' Optional LogToFile - A Boolean flag to enable logging to a file (default is False). ' Optional FilePath - The path of the file where the log should be saved (default is ""). ' Returns: Nothing - The function performs a print and/or log operation. ' Notes: ' - The function sends the message to the Immediate Window. ' - If AddNewLine is True, a newline is added after the message. ' - Prefix and Suffix can be used to format the message. ' - LogToFile enables logging the message to a specified file. ' - Error handling is included to manage issues with file operations. '********************************************************************** ' Author: Officena.net , Mohammed Essm , soul-angel@msn.com ' Date: August 2024 '********************************************************************** Sub DebugPrint(ByVal Message As String, Optional ByVal AddNewLine As Boolean = True, _ Optional ByVal Prefix As String = "", Optional ByVal Suffix As String = "", _ Optional ByVal LogToFile As Boolean = False, Optional ByVal FilePath As String = "") Dim fullMessage As String Dim fileNum As Integer ' Construct the full message with prefix and suffix fullMessage = Prefix & Message & Suffix ' Print the message to the Immediate Window Debug.Print fullMessage ' Optionally add a newline after printing If AddNewLine Then Debug.Print "" ' Adds an empty line for separation End If ' Log the message to a file if specified If LogToFile And FilePath <> "" Then On Error GoTo ErrorHandler fileNum = FreeFile Open FilePath For Append As #fileNum Print #fileNum, fullMessage Close #fileNum On Error GoTo 0 End If Exit Sub ErrorHandler: ' Handle any errors that occur during file operations Debug.Print "Error occurred while logging to file: " & Err.Description On Error GoTo 0 End Sub ' Example 1: Print a simple message Rem Call DebugPrint("This is a simple message") ' Example 2: Print a message with a prefix and suffix, without adding a new line Rem DebugPrint("Error encountered!", AddNewLine:=False, Prefix:="Error: ", Suffix:=" [Check details]") ' Example 3: Print a message and log it to a file Rem DebugPrint("Logging this message to a file.", LogToFile:=True, FilePath:="C:\path\to\your\logfile.txt") ' Example 4: Print multiple messages with automatic new lines and logging Rem DebugPrint("Starting process...") Rem DebugPrint("Process in progress...") Rem DebugPrint("Process completed successfully!", LogToFile:=True, FilePath:="C:\path\to\your\logfile.txt") '--------------------------------------------------------------------------------------------------------------------------------------- '********************************************************************** ' Subroutine: OpenImmediateWindow ' Purpose: Opens the Immediate Window in the VBA editor and prepares it for input. ' Inputs: None ' Returns: Nothing ' Notes: ' - The Immediate Window is activated and ready for input. ' - This subroutine uses the SendKeys method to send keystrokes. ' - Error handling is included to manage potential issues with SendKeys. '********************************************************************** ' Author: Officena.net , Mohammed Essm , soul-angel@msn.com ' Date: August 2024 '********************************************************************** Public Sub OpenImmediateWindow() Dim shell As Object On Error GoTo ErrorHandler ' Create an instance of WScript.Shell to send keystrokes Set shell = CreateObject("WScript.Shell") With shell ' Send Ctrl+G to open the Immediate Window .SendKeys "^g ", True ' Send Tab to navigate if needed .SendKeys "{TAB}", True End With Application.VBE.MainWindow.Visible = True DoEvents 'this frees up the OS to repaint the screen Exit Sub ' Clean up Set shell = Nothing ErrorHandler: ' Handle any errors that occur during SendKeys operations Debug.Print "Error occurred while opening the Immediate Window: " & Err.Description On Error GoTo 0 End Sub '********************************************************************** ' Function: ClearImmediateWindowContent ' Purpose: Clears the content of the Immediate Window in the VBA Editor. ' Details: ' This function searches for an open Immediate Window within the VBE. ' If found, it sends keystrokes to clear the content using the WScript.Shell object. ' Inputs: None ' Returns: Void ' Error Handling: ' Includes basic error handling to inform the user in case of an issue. ' Notes: ' - This function assumes that there is only one Immediate Window open. ' - The function does not create a new Immediate Window if one is not found. '********************************************************************** Public Function ClearImmediateWindowContent() On Error GoTo ErrorHandler Dim totalVBEWindows As Long Dim currentWindowIndex As Long Const IMMEDIATE_WINDOW_TYPE As Long = 5 ' Type constant for Immediate Window Dim shell As Object ' Create an instance of WScript.Shell to send keystrokes Set shell = CreateObject("WScript.Shell") totalVBEWindows = Application.VBE.Windows.Count ' Get the number of open windows ' Iterate through all open windows For currentWindowIndex = 1 To totalVBEWindows ' Check if the current window is the Immediate Window If Application.VBE.Windows.Item(currentWindowIndex).Type = IMMEDIATE_WINDOW_TYPE Then Application.VBE.Windows.Item(currentWindowIndex).SetFocus ' Set focus to the Immediate Window ' Ensure the Immediate Window is active If Application.VBE.ActiveWindow.Type = IMMEDIATE_WINDOW_TYPE Then With shell ' Send Ctrl+G to activate the Immediate Window .SendKeys "^g", True ' Send Ctrl+A to select all content .SendKeys "^a", True ' Send Delete to clear selected content .SendKeys "{DEL}", True ' Send Backspace to ensure content is cleared .SendKeys "{BKSP}", True End With Exit Function ' Exit after clearing the content End If Exit For ' Exit the loop if Immediate Window is found and focused End If Next currentWindowIndex ' Clean up Set shell = Nothing Exit Function ErrorHandler: MsgBox "Error occurred while trying to clear the Immediate Window. Error: " & Err.Description, vbCritical ' Clean up Set shell = Nothing End Function '********************************************************************** ' Function: GetDesktopPath ' Purpose: Returns the path to the Desktop for the current user. ' Details: ' This function retrieves the path to the Desktop folder using Windows API functions. ' Inputs: None ' Returns: String - The full path to the Desktop folder. ' Notes: ' - This function uses Windows API to get the Desktop path. ' - Ensure you have error handling to manage unexpected issues. '********************************************************************** Public Function GetDesktopPath() As String Dim strDesktopPath As String Dim objShell As Object On Error GoTo ErrorHandler ' Create an instance of Shell object Set objShell = CreateObject("Shell.Application") ' Get the Desktop folder path strDesktopPath = objShell.NameSpace(&H10&).Self.Path ' Return the path GetDesktopPath = strDesktopPath Exit Function ErrorHandler: MsgBox "Error occurred while retrieving the Desktop path. Error: " & Err.Description, vbCritical GetDesktopPath = "" End Function بالمناسبة لا داعى للقلق من وجود واستخدام "SendKeys" داخل الاكود لانه تم التعامل معها بحرفية تامة كى لا تأثر على حالة الـ Num Lock ImmediateWindowHelper.accdb

السلام عليكم ورحمة الله تعالى وبركاته المصدر و الموضوع الاساسى : فى هذه المشاركة لأستاذى القدير و معلمى الجليل و والدى الحبيب الاستاذ جعفر ( @jjafferr ) بعد اذن استاذى الجليل و معلمى القدير وحتي تعم الفائدة أقتبس من الموضوع الأساسى بعض المقتطفات و التى هى الأساس : هناك 3 انواع من هذه القوائم : الثابته ، والمؤقته ، والمؤقته التي تحتاج الى كود. الثابته: وهي التي عندما نعملها ، تصبح مستقله عن الكود ، وتُحفظ وتبقى في قاعدة البيانات بعد إغلاقها ، ويمكننا ان نستوردها في قاعدة بيانات اخرى عندما نستورد احد/جميع كائنات قاعدة البيانات الآخرى ، بإستخدام : . ونختارها في النموذج : . او التقرير : هذا مثال لعمل الكود الاساس لعمل قائمة قطع/نسخ/لصق : ومن هنا يبدأ موضوعى المتواضع بإعادة هيكلة وبناء وتطوير وإضافة الاكواد حسب فهمى المتواضع وأفكارى البسيطة والضئيلة الشرح :اولا الاكواد فى الموديول :basCommandBarsConfiguration Option Compare Database Option Explicit ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Constants for button states and control types Public Const BUTTON_STATE_DOWN As Integer = -1 ' BUTTON_STATE_DOWN: Indicates that a button is in a pressed or activated state. ' This value is used to reflect the button's pressed status. Public Const BUTTON_STATE_UP As Integer = 0 ' BUTTON_STATE_UP: Indicates that a button is in its default, unpressed state. ' This value is used to reflect the button's normal, unpressed status. Public Const CONTROL_TYPE_BUTTON As Integer = 1 ' CONTROL_TYPE_BUTTON: Represents a button control type in a command bar or menu. ' Used to add buttons to a command bar or menu with various functionalities. Public Const CONTROL_TYPE_EDIT As Integer = 2 ' CONTROL_TYPE_EDIT: Represents an editable control type, such as a text box. ' Used to add an editable text field to a command bar or menu. Public Const CONTROL_TYPE_COMBOBOX As Integer = 4 ' CONTROL_TYPE_COMBOBOX: Represents a combo box control type in a command bar or menu. ' A combo box allows users to select from a list of predefined options or enter a custom value. Public Const CONTROL_TYPE_POPUP As Integer = 5 ' CONTROL_TYPE_POPUP: Represents a popup menu or sub-menu control type. ' Used to create a dropdown menu or context menu in a command bar. Public Const BAR_TYPE_POPUP As Integer = 5 ' BAR_TYPE_POPUP: Represents a popup menu bar type. ' Used to create a command bar that behaves as a popup menu (e.g., appears on right-click or when invoked). ' Variables for CommandBar and Controls Public commandBar As Object ' Represents the custom command bar (popup menu) object Public commandButton As Object ' Represents each button/control added to the command bar Public commandBarName As String ' Name of the custom command bar Public CtrlFilterPopup As Object ' Represents the popup control for text filters '================================================================================ ' Procedure : AddButtonToCommandBar ' Purpose : Adds a button to a command bar with specified properties. ' Parameters: ' - btn: The button object to be added to the command bar. ' - type: The type of control (button). ' - id: The ID of the button. ' - caption: The caption text for the button. ' - beginGroup (optional): Boolean to indicate if a separator should be added before the button. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to add a button to the command bar Private Sub AddButtonToCommandBar(ByRef controls As Object, _ ByVal controlType As Integer, _ ByVal faceId As Integer, _ ByVal caption As String, _ Optional ByVal beginGroup As Boolean = False) On Error Resume Next Set commandButton = controls.Add(controlType, faceId, , , False) If Not commandButton Is Nothing Then With commandButton .caption = caption .faceId = faceId .beginGroup = beginGroup End With End If On Error GoTo 0 End Sub '================================================================================ ' Procedure : AddFilterControls ' Purpose : Adds filter controls to the provided controls collection in a filter popup. ' Parameters: ' - controls: The controls collection to which the filter controls will be added. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to add filter controls to the filter popup Private Sub AddFilterControls(ByRef controls As Object) With controls .Add CONTROL_TYPE_BUTTON, 10077, , , False .Add CONTROL_TYPE_BUTTON, 10078, , , False .Add CONTROL_TYPE_BUTTON, 10079, , , False .Add CONTROL_TYPE_BUTTON, 12696, , , False .Add CONTROL_TYPE_BUTTON, 10080, , , False .Add CONTROL_TYPE_BUTTON, 10081, , , False .Add CONTROL_TYPE_BUTTON, 10082, , , False .Add CONTROL_TYPE_BUTTON, 10083, , , False .Add CONTROL_TYPE_BUTTON, 12697, , , False .Add CONTROL_TYPE_BUTTON, 10058, , , False .Add CONTROL_TYPE_BUTTON, 10069, , , False .Add CONTROL_TYPE_BUTTON, 10070, , , False End With End Sub '================================================================================ ' Procedure : ClipboardActionsSortFilterCommandBar ' Purpose : Creates and configures a custom command bar with ClipboardActions (cut, copy, paste), sort, and filter options. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to create and configure the copy, sort, and filter command bar Public Sub ClipboardActionsSortFilterCommandBar() On Error GoTo ErrorHandler ' Handle errors ' Define the name of the custom command bar commandBarName = "ClipboardActionsSortFilterCommandBar" ' Ensure this matches the name you are checking ' Delete the existing command bar with the same name, if any On Error Resume Next Set commandBar = CommandBars(commandBarName) If Not commandBar Is Nothing Then commandBar.Delete End If If Err.Number <> 0 Then Err.Clear ' Create a new command bar Set commandBar = CommandBars.Add(Name:=commandBarName, Position:=BAR_TYPE_POPUP, Temporary:=False) With commandBar ' Add buttons to the command bar Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 21, "Cut") Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 19, "Copy") Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 22, "Paste") Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 210, "Sort Ascending", True) Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 211, "Sort Descending") Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 640, "Filter By Selection", True) Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 3017, "Filter Excluding Selection") Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 605, "Remove Filter/Sort") ' Add Filter For button with a popup menu Set CtrlFilterPopup = .controls.Add(Type:=CONTROL_TYPE_POPUP, Temporary:=False) If Not CtrlFilterPopup Is Nothing Then CtrlFilterPopup.caption = "Text Filters" ' Ensure CtrlFilterPopup is a CommandBarPopup If TypeName(CtrlFilterPopup) = "CommandBarPopup" Then ' Remove any existing controls For Each commandButton In CtrlFilterPopup.controls commandButton.Delete Next commandButton ' Add new controls to CtrlFilterPopup Call AddFilterControls(CtrlFilterPopup.controls) End If End If ' Add Close Form/Report button Set commandButton = .controls.Add(Type:=CONTROL_TYPE_BUTTON, ID:=923, Temporary:=False) If Not commandButton Is Nothing Then commandButton.beginGroup = True commandButton.caption = ChrW(1573) & ChrW(1594) & ChrW(1604) & ChrW(1575) & ChrW(1602) ' Close commandButton.OnAction = "CloseCurrentItem" ' Action to call the CloseCurrentItem subroutine End If End With ' Clean up Set commandBar = Nothing Set commandButton = Nothing Set CtrlFilterPopup = Nothing Exit Sub ErrorHandler: ' MsgBox "An error occurred: " & Err.Description, vbExclamation ' Debug.Print "An error occurred in cmb_Copy_Sort_Filter : " & Err.Number & " | " & Err.Description Resume Next End Sub '================================================================================ ' Procedure : ClipboardActionsSortCommandBar ' Purpose : Creates and configures a custom command bar with ClipboardActions (cut, copy, paste), and sorting options. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to create and configure the custom command bar Public Sub ClipboardActionsSortCommandBar() On Error GoTo ErrorHandler ' Handle errors ' Define the name of the custom command bar commandBarName = "ClipboardActionsSortCommandBar" ' Name for the custom command bar ' Delete the existing command bar with the same name, if any On Error Resume Next Set commandBar = CommandBars(commandBarName) If Not commandBar Is Nothing Then commandBar.Delete End If If Err.Number <> 0 Then Err.Clear ' Add a new command bar (popup menu) with the specified name Set commandBar = CommandBars.Add(Name:=commandBarName, Position:=BAR_TYPE_POPUP, Temporary:=False) With commandBar ' Add buttons to the command bar using the new subroutine ' Add Cut button Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 21, ChrW(1602) & ChrW(1589)) ' Add Copy button Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 19, ChrW(1606) & ChrW(1587) & ChrW(1582)) ' Add Paste button Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 22, ChrW(1604) & ChrW(1589) & ChrW(1602)) ' Add Sort Ascending button Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 210, ChrW(1578) & ChrW(1585) & ChrW(1578) & ChrW(1610) & ChrW(1576) & ChrW(32) & ChrW(1578) & ChrW(1589) & ChrW(1575) & ChrW(1593) & ChrW(1583) & ChrW(1610), True) ' Add Sort Descending button Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 211, ChrW(1578) & ChrW(1585) & ChrW(1578) & ChrW(1610) & ChrW(1576) & ChrW(32) & ChrW(1578) & ChrW(1606) & ChrW(1575) & ChrW(1586) & ChrW(1604) & ChrW(1610), True) ' Add Close Form/Report button Set commandButton = .controls.Add(Type:=CONTROL_TYPE_BUTTON, ID:=923, Temporary:=False) If Not commandButton Is Nothing Then commandButton.beginGroup = True commandButton.caption = ChrW(1573) & ChrW(1594) & ChrW(1604) & ChrW(1575) & ChrW(1602) ' Close commandButton.OnAction = "CloseCurrentItem" ' Action to call the CloseCurrentItem subroutine End If End With ' Clean up Set commandBar = Nothing Set commandButton = Nothing Exit Sub ErrorHandler: ' MsgBox "An error occurred: " & Err.Description, vbExclamation ' Debug.Print "An error occurred in cmb_CustomMenu : " & Err.Number & " | " & Err.Description Resume Next End Sub '================================================================================ ' Procedure : ClipboardActionsCommandBar ' Purpose : Creates and configures a custom command bar with ClipboardActions (cut, copy, paste). '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to create and configure the copy command bar Public Sub ClipboardActionsCommandBar() On Error GoTo ErrorHandler ' Handle errors ' Define the name of the custom command bar commandBarName = "ClipboardActionsCommandBar" ' Delete the existing command bar with the same name, if any On Error Resume Next Set commandBar = CommandBars(commandBarName) If Not commandBar Is Nothing Then commandBar.Delete End If If Err.Number <> 0 Then Err.Clear ' Add a new command bar (popup menu) with the specified name Set commandBar = CommandBars.Add(Name:=commandBarName, Position:=BAR_TYPE_POPUP, Temporary:=False) With commandBar ' Add buttons to the command bar Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 21, ChrW(1602) & ChrW(1589)) ' Cut Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 19, ChrW(1606) & ChrW(1587) & ChrW(1582)) ' Copy Call AddButtonToCommandBar(.controls, CONTROL_TYPE_BUTTON, 22, ChrW(1604) & ChrW(1589) & ChrW(1602)) ' Paste End With ' Clean up Set commandBar = Nothing Exit Sub ErrorHandler: ' MsgBox "An error occurred: " & Err.Description, vbExclamation ' Debug.Print "An error occurred in SCM_Copy : " & Err.Number & " | " & Err.Description Resume Next End Sub '================================================================================ ' Procedure : ReportContextMenuCommandBar ' Purpose : Creates and configures a custom report command bar with various ' printing, setup, and export options for reports. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to create and configure the custom report command bar Public Sub ReportContextMenuCommandBar() On Error GoTo ErrorHandler ' Handle errors Dim exportSubMenu As Object ' New variable for sub-menu handling ' Define the command bar name commandBarName = "ReportContextMenuCommandBar" ' Delete the existing command bar with the same name, if any On Error Resume Next Set commandBar = CommandBars(commandBarName) If Not commandBar Is Nothing Then commandBar.Delete End If If Err.Number <> 0 Then Err.Clear ' Create the shortcut menu Set commandBar = CommandBars.Add(Name:=commandBarName, Position:=BAR_TYPE_POPUP, Temporary:=False) ' Ensure commandBar was created successfully If commandBar Is Nothing Then MsgBox "Failed to create command bar.", vbExclamation Exit Sub End If With commandBar.controls ' Add the Print command Call AddButtonToCommandBar(.Add(Type:=CONTROL_TYPE_BUTTON, ID:=2521), CONTROL_TYPE_BUTTON, 2521, "Quick Print") ' Add the Select Pages command Call AddButtonToCommandBar(.Add(Type:=CONTROL_TYPE_BUTTON, ID:=15948), CONTROL_TYPE_BUTTON, 15948, "Select Pages") ' Add the Page Setup command Call AddButtonToCommandBar(.Add(Type:=CONTROL_TYPE_BUTTON, ID:=247), CONTROL_TYPE_BUTTON, 247, "Page Setup") ' Add the Email Report as an Attachment command Call AddButtonToCommandBar(.Add(Type:=CONTROL_TYPE_BUTTON, ID:=2188), CONTROL_TYPE_BUTTON, 2188, "Email Report as an Attachment", True) ' Add the Save as PDF/XPS command Call AddButtonToCommandBar(.Add(Type:=CONTROL_TYPE_BUTTON, ID:=12499), CONTROL_TYPE_BUTTON, 12499, "Save as PDF/XPS") ' Add Export to Word and Excel commands as sub-items of the PDF/XPS button If .Count >= 5 Then ' Add sub-menu for PDF/XPS button Set exportSubMenu = .Item(5).controls.Add(Type:=CONTROL_TYPE_POPUP, Temporary:=False) exportSubMenu.caption = "Export Options" ' Add Export to Word Set commandButton = exportSubMenu.controls.Add(Type:=CONTROL_TYPE_BUTTON, ID:=11725, Temporary:=False) If Not commandButton Is Nothing Then commandButton.caption = "Export to Word..." commandButton.faceId = 42 End If ' Add Export to Excel Set commandButton = exportSubMenu.controls.Add(Type:=CONTROL_TYPE_BUTTON, ID:=11723, Temporary:=False) If Not commandButton Is Nothing Then commandButton.caption = "Export to Excel…" commandButton.faceId = 263 End If End If ' Add the Close Report command Call AddButtonToCommandBar(.Add(Type:=CONTROL_TYPE_BUTTON, ID:=923), CONTROL_TYPE_BUTTON, 923, "Close Report", True) End With ' Clean up Set commandBar = Nothing Set commandButton = Nothing Set exportSubMenu = Nothing Exit Sub ErrorHandler: ' MsgBox "An error occurred: " & Err.Description, vbExclamation ' Debug.Print "An error occurred in CreateReportShortcutMenu : " & Err.Number & " | " & Err.Description Resume Next End Sub '================================================================================ ' Procedure : CloseCurrentItem ' Purpose : Closes the currently active form or report in the application. If no form ' or report is active, it displays a message to the user. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to close the currently active form or report Public Sub CloseCurrentItem() On Error GoTo ErrorHandler Dim obj As Object Dim activeItemName As String Dim isFormActive As Boolean Dim isReportActive As Boolean ' Check if an active form is open and close it isFormActive = False For Each obj In Forms If obj.Name = Screen.ActiveForm.Name Then activeItemName = obj.Name isFormActive = True Exit For End If Next obj If isFormActive Then DoCmd.Close acForm, activeItemName Exit Sub End If ' Check if an active report is open and close it isReportActive = False For Each obj In Reports If obj.Name = Screen.ActiveReport.Name Then activeItemName = obj.Name isReportActive = True Exit For End If Next obj If isReportActive Then DoCmd.Close acReport, activeItemName Exit Sub End If ' If no form or report is active, display a message MsgBox "There is no active form or report to close.", vbExclamation Exit Sub ErrorHandler: ' MsgBox "An error occurred: " & Err.Description, vbExclamation ' Debug.Print "An error occurred: " & Err.Number & " | " & Err.Description Resume Next End Sub '================================================================================ ' Procedure : DeleteAllCommandBars ' Purpose : Deletes all custom (non-built-in) command bars. '================================================================================ ' Author: www.officena.net , Mohammed Essam, soul-angel@msn.com, July 2024. ' Subroutine to Deletes all custom command bars. Public Sub DeleteAllCommandBars() On Error GoTo ErrorHandler ' Handle errors Dim i As Integer Dim cmdBar As Object Dim cmdBarsCount As Integer ' Get the count of command bars cmdBarsCount = CommandBars.Count ' Iterate through all command bars in reverse order For i = cmdBarsCount To 1 Step -1 On Error Resume Next ' Ignore errors if they occur during deletion Set cmdBar = CommandBars(i) If Not cmdBar Is Nothing Then ' Check if the command bar is not built-in or default If Not cmdBar.BuiltIn Then cmdBar.Delete Debug.Print "CommandBar '" & cmdBar.Name & "' has been deleted." End If End If On Error GoTo ErrorHandler ' Restore error handling Next i ' Clean up Set cmdBar = Nothing Exit Sub ErrorHandler: ' Display a more specific error message ' MsgBox "An error occurred while trying to delete command bars: " & Err.Description, vbExclamation ' Debug.Print "An error occurred in DeleteAllCommandBars: " & Err.Number & " | " & Err.Description Resume Next End Sub الثوابت : BUTTON_STATE_DOWN: قيمة ثابتة تستخدم للإشارة إلى أن الزر في حالة ضغط أو تفعيل ويستخدم هذا لإظهار حالة الزر عند الضغط عليه BUTTON_STATE_UP: قيمة ثابتة تستخدم للإشارة إلى أن الزر في حالته الطبيعية أو غير المضغوط عليها يستخدم هذا لإظهار حالة الزر عند عدم الضغط عليه CONTROL_TYPE_BUTTON: قيمة ثابتة تستخدم لتمثيل نوع التحكم "زر" في شريط الأوامر : ( قائمة السياق ) CONTROL_TYPE_EDIT: قيمة ثابتة تستخدم لتمثيل نوع التحكم "محرر" مثل صندوق النص يستخدم لإضافة حقل نص قابل للتعديل في شريط الأوامر : ( قائمة السياق ) CONTROL_TYPE_COMBOBOX: قيمة ثابتة تستخدم لتمثيل نوع التحكم "قائمة منسدلة" القائمة المنسدلة تسمح للمستخدمين بالاختيار من قائمة محددة مسبقا أو إدخال قيمة مخصصة CONTROL_TYPE_POPUP: قيمة ثابتة تستخدم لتمثيل نوع التحكم "قائمة منبثقة" أو "قائمة فرعية" تُستخدم لإنشاء قائمة منسدلة أو قائمة سياقية في شريط الأوامر BAR_TYPE_POPUP: قيمة ثابتة تُستخدم لتمثيل نوع شريط الأوامر المنبثق. يُستخدم لإنشاء شريط أدوات يظهر عند النقر بالزر الأيمن أو عند استدعائه -------------- المتغيرات : commandBar: يمثل كائن شريط الأوامر المخصص (قائمة السياق) commandButton: يمثل كل زر/تحكم يتم إضافته إلى شريط الأوامر commandBarName: اسم شريط الأوامر المخصص CtrlFilterPopup: يمثل التحكم المنبثق للفلاتر النصية -------------- الدوال : دالة : AddButtonToCommandBar الغرض: إضافة زر إلى شريط الأوامر مع الخصائص المحددة المعلمات: controls: مجموعة التحكمات التي سيتم إضافة الزر إليها controlType: نوع التحكم (زر في هذه الحالة) faceId: معرف الأيقونة للزر caption: نص التسمية للزر beginGroup (اختياري): منطق لبدء مجموعة جديدة مع الزر، مما يضيف فاصلًا قبله -------------- دالة : AddFilterControls الغرض: إضافة عناصر التحكم بالفلاتر إلى مجموعة التحكمات المحددة في قائمة منبثقة للفلاتر المعلمات: controls: مجموعة التحكمات التي سيتم إضافة عناصر الفلاتر إليها -------------- دالة : ClipboardActionsSortFilterCommandBar الغرض: إنشاء وتكوين شريط أوامر مخصص يتضمن خيارات الحافظة (قص، نسخ، لصق)، والفرز، والفلاتر العملية: إنشاء شريط أوامر جديد ( قائمة السياق ) إضافة أزرار للقص، النسخ، اللصق، الفرز، والفلاتر إضافة قائمة منبثقة للفلاتر النصية إضافة زر لإغلاق النموذج/التقرير -------------- دالة : ClipboardActionsSortCommandBar الغرض: إنشاء وتكوين شريط أوامر جديد ( قائمة السياق ) يتضمن خيارات الحافظة (قص، نسخ، لصق), والفرز العملية: إنشاء شريط أوامر جديد إضافة أزرار للقص، النسخ، اللصق، والفرز إضافة زر لإغلاق النموذج/التقرير -------------- دالة : ClipboardActionsCommandBar الغرض: إنشاء وتكوين شريط أوامر مخصص يتضمن خيارات الحافظة (قص، نسخ، لصق) العملية: إنشاء شريط أوامر جديد إضافة أزرار للقص، النسخ، واللصق -------------- دالة : ReportContextMenuCommandBar الغرض: إنشاء وتكوين شريط أوامر مخصص لقائمة السياق الخاصة بالتقرير، يتضمن خيارات الطباعة، الإعداد، والتصدير العملية: إنشاء شريط أوامر جديد إضافة أزرار لطباعة، اختيار الصفحات، إعداد الصفحة، إرسال التقرير بالبريد الإلكتروني كمرفق، حفظ كـ PDF/XPS إضافة خيارات تصدير إلى Word و Excel كعناصر فرعية لزر PDF/XPS إضافة زر لإغلاق التقرير -------------- دالة : CloseCurrentItem الغرض: إغلاق النموذج أو التقرير النشط حاليا في التطبيق العملية: التحقق مما إذا كان هناك نموذج نشط وإغلاقه التقق مما إذا كان هناك تقرير نشط وإغلاقه -------------- دالة : DeleteAllCommandBars الغرض: حذف جميع أشرطة الأوامر المخصصة (غير المدمجة) في التطبيق العملية: الحصول على عدد أشرطة الأوامر: يتم الحصول على عدد أشرطة الأوامر الحالية باستخدام CommandBars.Count التكرار من آخر شريط أوامر إلى أول شريط أوامر (من النهاية إلى البداية) لضمان عدم حدوث أخطاء أثناء الحذف حذف أشرطة الأوامر: إذا لم يكن الشريط مدمجًا (أي أنه شريط مخصص) يتم حذف الشريط -------------- واخيرا استدعاء الدالة عند تحميل النموذج أو التقرير: استدعاء دالة: Call RoutineNameCustomCommandBar يتم استدعاء دالة مع تغيير RoutineNameCustomCommandBar باسم الدالة الخاصة بإنشاء وتكوين شريط الأوامر المخصص حيث تقوم بإنشاء أو تعديل شريط الأوامر (CommandBar) الخاص بالنموذج أو التقرير تعيين خاصية ShortcutMenuBar: Me.ShortcutMenuBar = RoutineNameCustomCommandBar يتم تعيين خاصية ShortcutMenuBar للنموذج أو التقرير إلى اسم شريط الأوامر الذي تم إنشاؤه أو تعديله أثناء استدعاء الدالة المخصصة بهذه الطريقة يتم ربط شريط الأوامر المخصص بقائمة الاختصارات (shortcut menu) للنموذج أو التقرير الحالي ارقام جميع الصور الموجودة في الاكسس والتى نستخدمها كمعلمة فى faceId معرف الأيقونة للزر المصادر: الموضوع الاساسى فى هذا المنتدى لأستاذى القدير و معلمى الجليل و والدى الحبيب الاستاذ جعفر https://www.officena.net/ib/topic/99557-القائمة-المختصرة-shortcut-menu/#comment-603366 http://dev-soln.com/access-shortcut-right-click-tool/ https://www.experts-exchange.com/articles/12904/Understanding-and-using-CommandBars-Part-II-Creating-your-own.html https://filedb.experts-exchange.com/incoming/2014/02_w06/833359/CommandBars-II.mdb https://www.experts-exchange.com/articles/18341/CommandBars-Part-III-Using-Built-in-Shortcut-Menus.html http://www.skrol29.com/us/vtools.php CommandBarsConfiguration.accdb

تحويل الوقت والتاريخ المحلى الي التوقيت عن التوقيت العالمي الموحد (UTC) عرض تاريخ و اوقات دول او مدن مختلفة في نفس الوقت بناء على فرق الوقت بينعم ولين التوقيت العالمي الموحد جدول tblTimeZones والذى يتكون من الحقول ShowInForm : اختيار البلدان للعرض في النموذج CountryName : اسماء المدن و البلدان TimeDifference : فرق التوقيت عن التوقيت العالمي الموحد (UTC) الفارق الزمني (بالساعات، مع إشارة "+" أو "-") DaylightSavingTime : التوقيت الصيفي اولا اكواد الوحدة النمطية Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function GetSystemTimeAPI Lib "kernel32" Alias "GetSystemTime" (lpSystemTime As SYSTEMTIME) As Long #Else Private Declare Function GetSystemTimeAPI Lib "kernel32" Alias "GetSystemTime" (lpSystemTime As SYSTEMTIME) As Long #End If Private Type SYSTEMTIME ' Structure for SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Public Function GetUTC() As Date ' Function to get the current UTC time Dim utctime As Date Dim sysTime As SYSTEMTIME Call GetSystemTime(sysTime) utctime = DateSerial(sysTime.wYear, sysTime.wMonth, sysTime.wDay) + TimeSerial(sysTime.wHour, sysTime.wMinute, sysTime.wSecond) GetUTC = utctime End Function Private Function GetSystemTime(lpSystemTime As SYSTEMTIME) As Long ' Declaration to get system time GetSystemTime = GetSystemTimeAPI(lpSystemTime) End Function هذه الدوال توفر الحصول على الوقت الحالي بالتوقيت العالمي (UTC) SYSTEMTIME هو هيكل يستخدم لتخزين التاريخ والوقت GetSystemTimeAPI هى احد دوال API لـ Windows وظيفتها الحصول على الوقت العالمي (UTC) GetUTC هى دالة تستدعي الدالة GetSystemTimeAPI للحصول على الوقت الحالي بالتوقيت العالمي (UTC) ويتم اعادته كقيمة تاريخ/وقت طيب بعد ذلك الاكواد داخل النموذج النموذج يعرض توقيتات متعددة لدول مختلفة بناء على الاعدادات الموجودة في الجدول tblTimeZone Const FormatDisplayDate As String = "dd/mm/yyyy" Const FormatDisplayTime As String = "hh:mm:ss AM/PM" Const CountDisplayCountry As Integer = 5 Private Sub Form_Load() ' Set the form's timer interval to update every 1 second Me.TimerInterval = 1000 ' Call the function to update times and dates UpdateTimes End Sub Private Sub Form_Timer() ' Call the function to update times and dates when the timer event occurs UpdateTimes End Sub Private Sub UpdateTimes() On Error GoTo ErrorHandler Dim rs As DAO.Recordset Dim utctime As Date Dim i As Integer ' Get the current UTC time utctime = GetUTC() ' Debug.Print "UTC Time: "; utctime ' Open the recordset to fetch data from the tblTimeZones table Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblTimeZones WHERE ShowInForm = True") ' Check if recordset is not empty If Not rs.EOF Then rs.MoveFirst i = 1 ' Loop through each record in the recordset and update the form fields Do While Not rs.EOF And i <= CountDisplayCountry ' Limiting to 5 fields as per your requirement ' Assign values to form fields for each country If FieldExists("txtCountry" & i) Then Me("txtCountry" & i) = rs!CountryName Me("txtTimeDifference" & i) = rs!TimeDifference Me("chkDaylightSavingTime" & i) = rs!DaylightSavingTime ' Adjust time and date based on daylight saving time Dim localTime As Date If rs!DaylightSavingTime Then localTime = DateAdd("h", rs!TimeDifference + 1, utctime) Else localTime = DateAdd("h", rs!TimeDifference, utctime) End If Me("txtTime" & i) = Format(localTime, FormatDisplayTime) Me("txtDate" & i) = Format(localTime, FormatDisplayDate) End If rs.MoveNext i = i + 1 Loop Else ' Display a message if no records found for countries to display 'MsgBox "No countries found to display in the form.", vbExclamation, "No Records" Exit Sub End If ' Close the recordset rs.Close Set rs = Nothing Exit Sub ExitHandler: Exit Sub ErrorHandler: Select Case Err.Number Case 2465 ' Can't find the Object Resume ExitHandler Case Else MsgBox "Error in UpdateTimes: " & Err.Number & vbCrLf & Err.Description, vbExclamation 'Debug.Print Err.Number & " " & Err.Description Resume ExitHandler End Select End Sub Private Function FieldExists(fieldName As String) As Boolean ' Check if a field exists in the form On Error Resume Next FieldExists = (Me(fieldName).Name <> "") On Error GoTo 0 End Function الاعلان عن الثوابت Const FormatDisplayDate : للتحكم فى شكل تسيق التاريخ الذى سوف يتم عرضه Const FormatDisplayTime : للتحكم فى شكل تسيق الوقت الذى سوف يتم عرضه Const CountDisplayCountry : تحديد عدد الدول التى نريد عرض اوقاتها فى النموذج والذى على اساسة ايضا عدد العناصر فى النموذج لهذه البيانات Form_Load: عند تحميل النموذج، يتم تعيين الفاصل الزمني للمؤقت إلى ثانية واحدة ثم يتم استدعاء الدالة UpdateTimes Form_Timer: يتم استدعاء الدالة UpdateTimes كل ثانية لتحديث التوقيتات UpdateTimes وظيفة هذه الدالة هي الحصول على الوقت الحالي بالتوقيت العالمي (UTC) باستخدام الدالة GetUTC فتح مجموعة السجلات من الجدول tblTimeZones لجلب البيانات بناؤ على شرط أن يكون الحقل ShowInForm مضبوطًا على True في حلقة تكرارية يتم تحديث البيانات في العناصر في النموذج بناء على بيانات السجلات مع الأخذ بعين الاعتبار التوقيت الصيفي إذا كان مفعلاً يتم التعامل مع الأخطاء باستخدام كتلة ErrorHandler لضمان عدم تعطل البرنامج بسبب الأخطاء FieldExists: دالة للتحقق مما إذا كان عنصر معين موجودا في النموذج جدول tblTimeZones يحتوي على بيانات عن بلدان مختلفة بما في ذلك فرق التوقيت والتوقيت الصيفي وما إذا كانت البيانات يجب عرضها حيث يتم عرض البلدان المحددة فقط من خلال (ShowInForm = True) في النموذج العناصر فى النموذج كالاتى txtCountry1, txtCountry2, txtCountry3, txtCountry4, txtCountry5 المفروض يتم جلب اسماء البلدان من الجدول هنا ----------------------------------- txtTime1, txtTime2, txtTime3, txtTime4, txtTime5 المفروض يتم عرض التوقيت المحلى لكل بلد هنا ----------------------------------- txtTimeDifference1, txtTimeDifference2, txtTimeDifference3, txtTimeDifference4, txtTimeDifference5 المفروض يتم جلب الفرق في التوقيت لكل بلد هنا ----------------------------------- chkDaylightSavingTime1, chkDaylightSavingTime2, chkDaylightSavingTime3, chkDaylightSavingTime4, chkDaylightSavingTime5 المفروض يتم عرض ان كان التوقيت الصيفي مفعلا ام لا هنا ----------------------------------- txtDate1, txtDate2, txtDate3, txtDate4, txtDate5 المفروض يتم عرض التاريخ طبقا للتوقيت المحلى لكل بلد هنا ----------------------------------- المفروض كل ذلك يحدث من خلال الكود بمجرد فتح النموذج بطريقة الية والشرط طبعا هو جلب البيانات بناء على البلدان المختارة عرض بيناتها من خلال اختيارها من الحقل ShowInForm واخيرا المرفقات المرفق الاول وهو الاساس والذى تم استعراض الافكار والاكواد السابقة طبقا له المرفق الثانى فقط تم اضافة عدد نماذج لساعات على ان تكون نماذج فرعية TimeZones.zip TimeZones UP 2.zip

السلام عليكم ورحمة الله تعالى وبركاته اعرف ان الفكرة نوعا ما ليست جديدة كليا ولكن انا قمت بتطوير الفكرة بقدر الإمكان وفق رؤيتي القاصرة المرفق والفكرة مازالت قيد التجربة والتطوير لذلك اطلب العفو والسماح في حال وقوع أي أخطاء في انتظار آرائكم وارحب بإضافة الأفكار طبعا و يحبذا لو يتم تطبيق عمليا على المرفق مباشرة وإعادة رفعه من جديد OfficenaSQL2VBA.accdb

السلام عليكم ورحمة الله وبركاته الموضوع ترفيهي نوعا ما : حنين الى الماضي بصراحة كنت احب هذه اللعبة جدا جدا جدا وانا صغير راودتني فكرة تصميم اللعبة من خلال الاكسس وهذه تجربتي اتمني ان تنال رضاكم PuzzleGame.zip

هل من الممكن تصدير المكتبات المستخدمة في المشروع الى جهاز آخر (أثناء عملية التثبيت مثلاً - على فرض أن المشروع تم تحزيمه بدقة ) حتى لو اختلفت فيه نسخة الأوفيس ؟ كون أن المكتبات هي ملفات معظمها Dll .... الخ من صيغ !!

السلام عليكم ورحمة الله تعالى وبركاته طبعا لن اضع افكارى صريحة لتطبيق فكرة محددة لا أنوى أن اعطيكم سمكا بل انوى أن أعلمكم الصيد ... لذلك سوف اضع الاكواد والافكار على وجه العموم وعلى سبيل الشرح ليس الا وليدل كل منكم بدلوه فى التطبيق وليستحضر بنات افكاره كما يترأى له 1- الحماية عن طريق اضافة بيانات الحماية فى الريجسترى نستخدم الأكواد الاتية فى وحدة نمطيه التطبيق فى القاعدة المرفقة .. تم وضع بعض التلميحات على الأكواد Public Const MyRegPath As String = "HKEY_CURRENT_USER\Software\Officena.net" Public Const MyRegKey As String = "Judy" Public Const myStringValue As String = "محمد" Public Const myValueData As String = "ابو جودى" 'returns True if the registry key i_RegKey was found 'and False if not Function RegKeyExists(i_RegKey As String) As Boolean Dim myWS As Object On Error GoTo ErrorHandler 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'try to read the registry key myWS.RegRead i_RegKey 'key was found RegKeyExists = True Exit Function ErrorHandler: 'key was not found RegKeyExists = False End Function Function RegKeyRead(i_RegKey As String) As String Dim myWS As Object On Error Resume Next 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'read key from registry RegKeyRead = myWS.RegRead(i_RegKey) End Function Function RegKeySave(i_RegKey As String, _ i_Value As String, _ Optional i_Type As String = "REG_SZ") Dim myWS As Object 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'write registry key myWS.RegWrite i_RegKey, i_Value, i_Type End Function Function RegKeyDelete(i_RegKey As String) As Boolean Dim myWS As Object On Error GoTo ErrorHandler 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'delete registry key myWS.RegDelete i_RegKey 'deletion was successful RegKeyDelete = True Exit Function ErrorHandler: 'deletion wasn't successful RegKeyDelete = False End Function يتبع.. القاعدة المرفقة 01-Dealing with the registry.accdb

السلام عليكم ورحمة الله وبركاته التطبيق اهداء الى منتدانا الحبيب ورواد المنتدى العمل حتى يخرج بهذه الصورة يعلم الله وحده الجهد المبذول به اسال الله تعالى ان يتقبل هذا العمل صدقة جارية الى ما شاء الله تعالى ms access becomes an authorized e-invoicing solution provider in Saudi Arabia by www.officena.net Start your e-invoicing journey حسب متطلبات هيئة الزكاة والضريبة والجمارك السعودية يتم قراءة الرمز الناتج ان شاء الله عبر القارىء الرسمي الخاص بالهيئة ( تطبيق جوال ) حمل من هنا : التطبيق الرسمي لهيئة الزكاة والضريبة والجمارك يتم قراءة الرمز الناتج ان شاء الله عبر قارىء خاص ( تطبيق جوال ) حمل من هنا : تطبيق قرائة رمز الاستجابة طبقات لمتطلبات هيئة الزكاة والضريبة والجمارك التطبيق المقدم لكم تمت تجربته وهو متوافق مع النواتين 32 , 64 تم تصميم الاكواد داخل روتين عام ليسهل التعامل معها بكل سهولة ممكنة حاولت جاهدا جمع الاكواد المستخدمة فى موديول ليسهل نقله يتم التعامل مع الروتين باسناد فقط اسماء الحقول من النموذج المستخدم والتى يمكن تغير اسمائها تبعا لتصميمك كالاتى Call CreateInvoice(ID, SellerName, VatNo, TimeStamp, InvoiceWithVat, VatTotal) ID >>-----> اسم الحقل الدال على رقم الفاتورة وهذا ليتم تسمية ملف رمز الاستجابة الناتج بناء عليه SellerName >>-----> اسم الحقل الدال على اسم البائع VatNo >>-----> اسم الحقل الدال على الرقم الضريبي TimeStamp >>-----> اسم الحقل الدال على الوقت وتاريخ انشاء الفاتورة InvoiceWithVat >>-----> اسم الحقل الدال على القيمة الاجمالية للفاتورة VatTotal >>-----> اسم الحقل الدال على القيمة الاجمالية لمبلغ الضريبة فقط بعد تشفير البيانات يتم اسناد الشفرة الى متغير عام باسمstrHashCode والذى من خلاله يت حفظ البيانات المشفرة داخل الجدول تبعا لكل سجل ---------------------------------------------- الية العمل بعد اسناد اسماء الحقول الى الروتين يتم تمرير البيانات من تلك الحقول الى الملف التنفيذى الملحق مع القاعدة والذى بدورة يقوم بانشاء كل من 1- رمز الاستجابة السريع بعد تشفير البيانات طبقا للمطلبات from string to hex to base64 2- انشاء ملف نص به تشفير البيانات بعد ذلك تقوم باقى الاكواد بجلب البيانات المشفرة من ملف النص واسنادها الى المتغير الذى تم تخصيصه لذلك --------------------------------------------- تفاصيل الاكواد داخل الموديول كالتالى الروتين MkDir لعمل المجلدات عند الحاجة دوال الـ API الخاصة بـ ShellWait والمتوافقة مع كلتا النواتان 32 , 64 وتمت التجربة بنجاح على اوفيس 32 تارة واوفيس 64 تارة اخرى بفضل الله بنجاح حيث يتم ارسال البيانات من الحقول الى الملف التنفيذى الملحق من خلال الروتين Shell_n_Wait ليتم انشاء رمز الاستجابة السريع من خلال الروتين الخاص به وهو CreateInvoice وانشاء الملف النصى بجوار الملف التنفيذى فى نفس المسار لالحاق البيانات المشفرة طبقا للمطلبات from string to hex to base64 وبعد ذلك يتم جلب البيانات المشفرة من خلال الروتين ReadFileToText ولابد من استخلاص التشفير من خلال الروتين StripSpChars للاحتفاظ بالنص دون اى زيادات وبعد ذلك يتم الحاق البيانات المشفرة الى المتغير الذى قمت بتخصيصه لذلك وهو يحمل الاسم strHashCode والذى يتم الحاق البيانات من خلاله لكل سجل الى الحقل المخصص به للاحتفاظ بتلك الشفرة حسب طلبات السادة رواد المنتدى الكرام الملف التنفيذى تم عمله من خلال الفيجوال دوت نت ليقوم بتحويل النص طبقا للمطلبات from string to hex to base64 وتم دمج ملفات الـ Dll الخاصة بانشاء رمز الاستجابة بداخل الملف التنفيذى لسهولة التعامل معه من خلال الاكسس ليكون ملف تنفيذى واحد فقط يتم التعامل معه من خلال الـ Command Line دون الحاجة لتثبيت او تسجيل او الاستعانة بأى مكتبات خارجية او حتى ملحقة بالاكسس وذلك لسهولة نقل الموديول الى اى قاعدة دون التقيد باى مكتبات --------------------------------------------- تنبيه هام جدا جدا جدا بجوار قاعدة البيانات فى نفس مسارها مجلد باسم KSA-QR-Tool لايمكن تغيير اسم المجلد والا يحدث خلل وان استدعت الحاجة تغيير الاسم يجب ذلك داخل المدويول يتم كذلك انشاء ملف نصى اليا داخل المجلد KSA-QR-Tool لذلك يجب تحرى الحذر عند محاولة تغيير اسم المجلد داخل الموديول لذلك يرجى عدم محاولة تغير اسم المجلد كذلك داخل المجلد السابق ذكرة الملف التنفيذى KSAQR.exe لا تحاول تغيير اسم الملف لان الاكواد كذلك تتعامل مع هذا الملف من خلال اسمه كذلك لا يمكن نقل المجلد او الملف من مسار قاعدة البيانات الا بالتعديل على الاكواد وفى الختام فضلا وكرما وليس امرا الرجاء الاهتمام بالرد بما يفيد نتيجة تجربتكم الشخصية وتقييم تلك التجربة فلا تبخلوا علينا بذلك... لكم منا خالص الشكر واتمنى لكم تجربة ممتعة ومن يريد طريقتى والتى احبها وافضلها وتعلمتها من استاذى الجليل ومعلمى الجليل الاستاذ @jjafferr بتحميل الملف التنفيذى داخل القاعدة للتأكد دائما من عدم حذفه لا يتردد فى طلب ذلك فقط حاولت تقديم القاعدة بأبسط شكل حتى يقف كل من يريد استخدامها او نقلها الى تطبيقه الخاص على الاكواد المهمة فقط من خلال موديول واحد فقط تيسيرا وتسهيلا عليه وحتى تعم الفائدة هذه الاكواد المستخدمة فى الملف التنفيذى الذى تم انشاؤه من خلال الـ فيجوال دوت نت بناء على رغبة استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل لمن يريد التعلم من اكواد التشفير وبناء على طلب استاذى القدير @ابوآمنة Imports System.Drawing Imports System.IO Imports System.Text Imports QRCoder Module Module1 Sub Main() Try Dim sellerName As String = "" Dim vatNumber As String = "" Dim timeStamp As String = "" Dim invoiceTotal As String = "" Dim vatTotal As String = "" Dim imagePath As String = "" Dim filePath As String = "" If My.Application.CommandLineArgs.Count >= 6 Then sellerName = My.Application.CommandLineArgs(0) vatNumber = My.Application.CommandLineArgs(1) timeStamp = My.Application.CommandLineArgs(2) invoiceTotal = My.Application.CommandLineArgs(3) vatTotal = My.Application.CommandLineArgs(4) imagePath = My.Application.CommandLineArgs(5) filePath = My.Application.CommandLineArgs(6) Else Environment.Exit(0) End If If Not String.IsNullOrEmpty(filePath) Then File.WriteAllText(filePath, String.Join(" ", sellerName, vatNumber, timeStamp, invoiceTotal, vatTotal), Encoding.UTF8) End If End Dim tlvInvoice = CreateInvoice(sellerName, vatNumber, timeStamp, invoiceTotal, vatTotal) Dim qrGenerator As New QRCodeGenerator() Dim qrData As QRCodeData = qrGenerator.CreateQrCode(tlvInvoice, QRCodeGenerator.ECCLevel.Q) Dim qrCode As QRCode = New QRCode(qrData) Dim qrCodeImage As Bitmap = qrCode.GetGraphic(20) qrCodeImage.Save(imagePath) If Not String.IsNullOrEmpty(filePath) Then File.WriteAllText(filePath, tlvInvoice, Encoding.UTF8) End If Catch ex As Exception End Try End Sub Function CreateInvoice(sellerName As String, vatNumber As String, timeStamp As String, invoiceTotal As String, vatTotal As String) As String Dim invoiceHex As String = "" For i = 1 To 5 Dim txt As String = "" Select Case i Case 1 txt = sellerName Case 2 txt = vatNumber Case 3 txt = timeStamp Case 4 txt = invoiceTotal Case 5 txt = vatTotal End Select Dim hexTxt As String = StringToHex(txt) Dim hexLen As String = Hex(Encoding.UTF8.GetBytes(txt).Length) If hexLen.Length = 1 Then hexLen = "0" & hexLen End If invoiceHex = invoiceHex & "0" & i & hexLen & hexTxt Next Return HexToBase64(invoiceHex) End Function Function StringToHex(txt As String) As String Dim b As Byte() = Encoding.UTF8.GetBytes(txt) Return BitConverter.ToString(b).Replace("-", "") End Function Function HexToBase64(txt As String) As String Dim bytes = New Byte((txt.Length \ 2) - 1) {} For i = 0 To bytes.Length - 1 Dim mi = txt.Substring(i * 2, 2) bytes(i) = Convert.ToByte(mi, 16) Next i Return Convert.ToBase64String(bytes) End Function End Module E-Invoicing.zip Ksa Qr 32x 64x 2007 to 2021 _Last Version.zip

ذكريات و تحديث اذاعات البث المباشر تحديث المرفق اعادة تفعيل الـ Shift تقليل حجم مستوى الصوت عتج الفتح ازالة روابط اذاعات بث الغناء اخص بكل الشكر والعرفان بالجميل اخى الحبيب الاستاذ @Amr Ashraf لتنبيهى لتدارك خطأى عبر نشر اذاعات بث الغتاء اللهم انى استغفرك واتوب واليك اللهم اغفر لى يارب وارحمتى واعفو عنى يارب العالمين Radio (V2).mdb

السلام عليكم ورحمة والله تعالى وبركاته طيب ببساطه انظر للسلسلة النصية الاتية "Moh8202281012343434" ونريد التعديل عليها لتظهر بهذا الشكل "Moh-820-228-101-234-343-4" او بهذا الشكل "Moh,820,228,101,234,343,4" او بهذا الشكل Moh820/228101/234343/4 يتم عمل ذلك من خلال الكود الاتى Function ReFormat(ByVal strText As String, Optional strSymbol As String = "-", Optional intCountDigits As Integer = 3) Dim i As Long ReFormat = "" For i = 0 To Len(strText) - 1 Step intCountDigits If i = 0 Then ReFormat = Mid(strText, i + 1, intCountDigits) Else ReFormat = ReFormat & strSymbol & Mid(strText, i + 1, intCountDigits) End If Next i End Function syntax code ReFormat(string ,Symbol, Count Digits) Result By default syntax used ReFormat(string) Symbol >-->> - Count Digits >-->> 3 اذا من خلال استدعاء الكود عن طريق البنية المفضلة الاتية: ReFormat(string) تحصل على اضافة العلامة - بعد كل 3 مواضع فى السلسلة النصية اما اذا اردت التعديل فى شكل الرمز وعدد المواضع يمكنك استخدام الكود الاتى : ReFormat(string ,Symbol, Count Digits) مثلا لو اردت استخدام الرمز $ بدلا من الرمز - وتريد وضع الرمز فى السلسلة النصية بعد كل خمس مواضع يكون الكود كالأتى: ReFormat(string ,"$", 5)

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