نجوم المشاركات

السلام عليكم ورحمة الله تعالى وبركاته المصدر و الموضوع الاساسى : فى هذه المشاركة لأستاذى القدير و معلمى الجليل و والدى الحبيب الاستاذ جعفر ( @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

:: قريبا إن شاء الله 😊👌 :: واجهة متطورة بألوان جذابة :: وقائمة رئيسية يمكن تحريرها بسهولة و لها أزرار فرعية :: بأبسط ما يكون

وعليكم السلام ورحمة الله وبركاته ,, هذا النمط من الجمل الشرطية يسمى توابع الجملة الشرطية المتداخلة . وفي حالتك تريد التحقق من شرطي مقارنة مختلفين وإرجاع قيمة معينة إذا تحقق أحدهما. IIf([ASNAF.UNIT]=[SAP.UNIT], "YYY", IIf([ASNAF.UNIT]=[SAP.[ADDITION UNIT]], "YYY", "NNN")) جرب وأخبرني بالنتيجة

ومشاركةً مع أخي @ahmed draz ، اجعل كود الحدث بعد التحديث للقائمة cmb_TQ كما يلي ، لجلب التسمية التوضيحية للحقول من الجدول المختار من القائمة .. Private Sub cmb_TQ_AfterUpdate() Dim db As Database, td As TableDef Dim fld As Field Dim sql As String Dim captions As String Set db = CurrentDb Set td = db.TableDefs(Me.cmb_TQ.Value) sql = "SELECT data_tech.* FROM data_tech WHERE data_tech.a1 LIKE '" & Me.cmb_TQ.Value & "' ORDER BY a1" With Me.ListFields .ColumnCount = 1 .RowSourceType = "Value List" .RowSource = "" End With For Each fld In td.Fields If fld.Properties("Caption") <> "" Then captions = fld.Properties("Caption") Else captions = fld.Name End If Me.ListFields.AddItem captions Next fld Set db = Nothing Set td = Nothing End Sub هذا فيما يخص الطلب الأول طبعاً . ، وأعتقد الثاني أيضاً ولكن بطريقة الاختيار المتعدد .

مشاركة يتخصيص اكثر وتحكم اكثر بما يتناسب للطلب والتصميم 1- ظهور القثائمة باي مكان تضغط فيى على زر يسار الماوس وخاصة الضبط عند كامل الشاشة للنافذه docmd.mixmain 2-تخصيصها وتشكيل القائمة باي تصميم دائرة او شبة دائرة تستطيع اختصار ما تشاء وتصميم كما تشاء بسهولة Ezy كانة لاعادة الاتصال او كانت اعدادة او اكثر من خطو مع اضافة شعار للشركة وشريط التقدم ..😇 ============================ فقط بحدثين تستطيع جعل راس النموذج قائمة لحالها زالتفصيل النموذج قائمة للحالة وتذليل النموذج قائمة للحالها ==================================(!) ولا تستطيع تشغيل عند (معاينة التقرير للاسف ) -😏 Lift_Click_Mouse(Menu_Form_Custom).rar

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

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

لاحظى ان كلامك جارح وبتحكى عنى انا مش البعض انا كلهم

تمعن فى هذا الجمال بدلا من ذلك العناء مع iif Switch( [ASNAF.UNIT] = [SAP.UNIT], "YYY", [ASNAF.UNIT] = [SAP.ADDITION UNIT], "YYY",True, "NNN" ) والله دالة سويتش جميلة وبنت حلال ليه تتجاهلونها يا اخوان عمالة تشتكى لى وتعيط منكم ده حتى كمان طيبة ومسكينة و لا تقلب الدنيا راسا على عقب لو تم استخدامها مع اللغة العربية بعكس بنت اللذينة iif دى اه والله زيمبئولكم كده بالمناسبة انا كاتبها صح مش غلط بس قاصد كتابتها كده علشان تشوفوا سهولة كتابتها عند الاستخدام وعلى سطر واحد تكون Switch([ASNAF.UNIT] = [SAP.UNIT], "YYY", [ASNAF.UNIT] = [SAP.ADDITION UNIT], "YYY", True, "NNN") وكما تلاحظون تكتب مرة واحدة بس لو هتعمل ميت شرط بطريقة اكثر تعقيدا ناهيك عن عدد مرات استخدام iif مع الشروط وعدد الاقواس وترتيبها

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

باش مهندسة @hanan_ms فكرة حلوة وانا كمحمد مبسوط منها شغلك وافكارك بصراحة حلوة جدا شابوه بجد

بعد اذن استاذي @ابو جودي❤️🌹 احب مشاركة بقوائم المختصر وسهل تستطيع التعديل عند تركيز الفورم اغلق القائمة 😇 كيف تخصيص قائمة عند معاينة التقرير ☕

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

كلك إبداع يابو هندسة @ابو جودي ما شاء الله 🙂👌 لمساتك على المشاريع زي الكرزة الي بتتحط فوق التورتة وزي ما بيقولوا : ( حطيت النقاط على الحروف ) 😄🌷 وتحفة تخش على المكتبة من أوسع الأبواب 🖐 ولازلنا ننتظر مشروع مستر @Foksh المرتقب

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

زي كده يا معلم

حتدفع كام ؟؟ !!

الله اكبر واخيرا حيبقى عندى مكتبه ايوة بقه بس تعالى نتفق اتفاق الواجه عليك والالوان الحذابة على ايه رايك خلى بالك العرض ده لمرة واحدة بس فكر بتأنى واوعى تتسرع

ابو جودي والله ما قصرت 🥰 بس محتاج منك تكملي اللمطلوب وهو اختيار الحقل او عدة حقول واظهارهم بالبيانات بتاعتها من الجدول كاملة في الليست بوكس التانية حسب الاختيار من الليست بوكس الاولي انا نفذت الكود بتاعك في المرفق الرجاء اكمال الموضوع وشكراا مقدما CustomColumns.accdb

هههههه انا قلت @Foksh هيزعق لى ويدينى بالمجهر فى دماغى ويعيط ويدبدب برجله زى ناس اسمها @safaa salem5 وفى الاخر يقولى انا مش داخل هنا تانى ومش عاوز منك حاجة وهروح عند الاجانب انا راضى زمتكم الاجانب عندهم @Moosak صاحب المكتبة العامرة واللا عندهم @Foksh ابو قلب ابيض العسل ده والا عندهم واحدة بتكلم العرب بالعربى والعرب عاوزين مترجم علشان يفهموها اسمها الباش مهندس @hanan_ms حتة واحدة وبتفضل تحط مرفقات تخبل وتجنن وفيها اخترعات غريبة من كوكب تانى اه والله زيمبئولكم كده روحوا شوفوا شغلها يجنن بس اتفرجوا على الشغل هلى طول بدون ما تقرأوا كلامها والله احلى صحبة هنا ناس عسل مالهومش زى احل اخل واخوات فى الدنيا واعظم اساتذة فى الوجود ال مش لاعبه هنا تانى واروح العب عند الاجانب قال روحى يا اختى

خلاص انا هحاول مع نفسى متشكره

Private Sub RE_cmd_Click() OpenFormAndSetFields "PT_frm" ------------------------------------------------------------------------------------------- Private Sub OpenFormAndSetFields(formName As String) DoCmd.OpenForm formName, , , "[ID]=" & Me.ID Forms(formName)!ID = Me.ID Forms(formName)!gender = Forms![visit_frm]![gender] Forms(formName)!age = Forms![visit_frm]![age] Forms(formName)!ageunit = Forms![visit_frm]![ageunit] Forms(formName)!pname = Forms![visit_frm]![pname] End Sub Dim reference_value As Variant reference_value = DLookup("Reference", "normals_tbl", _ "Gender = '" & Forms("pt_frm")("gender").value & "' AND " & _ "Ageunit = '" & Forms("pt_frm")("ageunit").value & "' AND " & _ "tcode = 144 AND " & _ "age >= [from] AND age <= [to]") If Not IsNull(reference_value) Then Forms!pt_frm!pt_r.value = reference_value End If Private Sub RE_cmd_Click() OpenFormAndSetFields "PT_frm" ------------------------------------------------------------------------------------------- Private Sub OpenFormAndSetFields(formName As String) DoCmd.OpenForm formName, , , "[ID]=" & Me.ID Forms(formName)!ID = Me.ID Forms(formName)!gender = Forms![visit_frm]![gender] Forms(formName)!age = Forms![visit_frm]![age] Forms(formName)!ageunit = Forms![visit_frm]![ageunit] Forms(formName)!pname = Forms![visit_frm]![pname] End Sub هل ممكن انه مش قادر يقرأ قيمة age ممكن اكتبها بالشكل دا reference_value = DLookup("Reference", "normals_tbl", _ "Gender = '" & Forms("pt_frm")("gender").value & "' AND " & _ "Ageunit = '" & Forms("pt_frm")("ageunit").value & "' AND " & _ "tcode = 144 AND " & _ "Forms!pt_frm!age >= [from] AND Forms!pt_frm!age <= [to]")

استاذي هذه للاجهزه التعبانة من 32bit (X) ================ 64bit بالتنجبر باعلى تصاميم على صعيد الشركات والمؤسسات ذات بنية قاعدة بيانات جغرافية ومعمارية SDD Up Bost ,,,,, Flash "red" شبكات وخطوط ارضية باعلى المواصفات وصيانة الدورية فتعطي مقومات اعلى بتصميم البرامج من جرب 128 bit ... PC 😏 ======== استاذي اكيد تتكلم على البعض الي عندهم 😇 لابتوب قديم جيل حطب و32 😗 32bit ما تعرف تصمم برنامج الا تخلي اكسس بتصميم 2003 وبعد تقلل الاستعلامات مع كافة ادوات التصليح 😂 زين اشتغل الاوفيس😂 ولا واحد حاشي مكتبات وبرامج وتشعيبات SPY - Virus Full Disk 😂 ========================== اتفق مع الاستاذي @ابو جودي تصميم السادة للتجربة وانتهاء المشروع واعتماد ثم تصاميم الهيكل copy ---- past full control and full skin ==(look time finish ) with test 😇 level up with skin

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

طيب الكودين تحت المجهر >>-----> الكود الاول للاستاذ العظيم @Foksh والكود الثانى اللى هو احسن طبعا <<----< مين يشهد للعروسة الكود الاول : استخدام AddItem لإضافة العناصر بشكل فردي بدلا من بناء سلسلة نصية يقوم الكود بإضافة أسماء الحقول إلى قائمة ListFields بشكل فردي باستخدام AddItem عدم التعامل مع الأخطاء الكود لا يحتوي على أي تعامل مع الأخطاء مما قد يسبب أخطاء غير متوقعة إعداد RowSource في بداية العملية يتم إعداد RowSource وإفراغه قبل البدء في إضافة العناصر عدم استخدام جملة sql جملة sql الموجودة في الكود لا تؤثر على الكود ويمكن إزالتها لأنها غير مستخدمة الكود الثانى : استخدام متغير rowSourceString لبناء قائمة ListFields الكود يجمع كل أسماء الحقول في سلسلة نصية مفصولة بفواصل إعداد RowSource مباشرة بسلسلة نصية في النهاية حيث يقوم الكود بإعداد RowSource لقائمة ListFields باستخدام السلسلة النصية التي تم بناؤها التعامل مع الأخطاء بشكل آمن يتم التعامل مع الأخطاء عند محاولة الوصول إلى خاصية "Caption" في الحقول بشكل آمن عبر استخدام On Error Resume Next ثم On Error GoTo 0 بعد محاولة الوصول مسح الذاكرة بشكل صحيح: يتم تعيين المتغيرات db و td إلى Nothing في النهاية، مما يساعد على تحرير الذاكرة. المرونة والأداء: الكود الثانى قد يكون أفضل من حيث الأداء ده كده كده لانه بتاعى بالعند فيك يا استاذ @Foksh حيث يتم بناء السلسلة النصية مرة واحدة ثم تعيينها إلى RowSource بدلاً من إضافة العناصر بشكل فردي كما في الكود الاول فى الكود الثانى يتم التعامل مع الأخطاء بشكل صحيح مما يجعله نسبيا ً أكثر استقراراً وضوح الكود : الكود الثانى أكثر وضوحاً وسهولة في الفهم ده كده كده برضو لتانى مرة حيث يتم جمع أسماء الحقول ثم تعيينها دفعة واحدة بدلاً من الإضافة الفردية الخلاصة بقة لان ده شغل فاخر من الاخر : الكود الثانى يعتبر أفضل بسببين بس بعد الرغى ده كله ومعاكسة اغلى الغوالى 1- تعامله الأفضل مع الأخطاء 2- فعاليته في الأداء من خلال إعداد RowSource دفعة واحدة ووضوحه في التنفيذ من غير ما تدخل تزعق يا عم @Foksh هدى اعصابك بس روح ع الجدول وامسح اى تسمية لاى حقل وجرب

شكل الكود هاد ما بيحب احمد هاهاههاا شوفتوا بقه فايدة ان الواحد يبقى اسمه محمد عن نفسي انا كمحمد مبسوط والله

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

السلام عليكم اخي الكريم Foksh اسئل الله لحضرتك السلامة اخي الكريم بارك الله بجهودك والشكر والتقدير لحضرتك ملاحظة : عندما افتح النموذج (Form1) من اجل الادخال او التغيير واقوم بالبحث في حقل الاسم من اجل تخصيص منصب له يحذف الاسم الذي كان موجودا عند الفتح مثال , عندما افتح النموذج واجد اسم (احمد) واحذف من اجل ادخال اسم جديد ومنصب جديد ل (محمد) يقوم بحذف اسم (احمد ) من استعلام المنصب . كل الشكر والتقدير لحضرتك مقدما

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

للأسف القاعدة لا تعمل عندي نهائيا مش عارف المشكلة في ايه فعلا عندك حق حصل كدة عندي تقريبا

أعتقد أنه قد فقد رمز الأيميل ولم يعد يستطيع التواصل عبر هذا الحساب ولذلك فتح حساب جديد والله أعلم ...... حسب فهمي لكلمة تصكر والتي أعتقد أنها تسكر أو أغلق...

كل الشكر للأخ الفاضل Foksh تم ضبط المعادلة الى IIf([ASNAF.UNIT]=[SAP.UNIT],"YYY",IIf([ASNAF.UNIT]=[SAP.ADDITION UNIT],"YYY","NNN")) وتعمل بشكل صحيح لدى فكل الشكر والتقدير لحضرتك

الآن يا @hanan_ms بدأت تتدفق الأفكار الجميلة منك 😎 شكرا على هذه الفنيات الجميلة 👍🙂🌷

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

السلام عليكم هل تقبلون تجربة احد جيرانكم من منتدى الاكسس جرب الكود الاتى ' This function rounds a given value to the nearest multiple of a specified value. ' It uses Excel's built-in RoundUp and RoundDown functions to perform the rounding. ' ' Parameters: ' mainVal: The value to be rounded (of type Double). ' roundVal: The multiple to which mainVal will be rounded (of type Double). ' ' Returns: ' The rounded value as a Double. ' If roundVal is zero or an error occurs, the function returns 0. ' ' Error Handling: ' The function raises an error if roundVal is zero to prevent division by zero. ' If any other error occurs, a message box displays the error number and description. Function MyRound(ByVal mainVal As Double, ByVal roundVal As Double) As Double Dim h As Double, v As Double Dim remainder As Double On Error GoTo ErrSub ' Check if roundVal is zero to avoid division by zero error If roundVal = 0 Then Err.Raise vbObjectError + 9999, "MyRound", "RoundVal cannot be zero." End If ' Calculate half of roundVal h = roundVal / 2 ' Calculate the remainder of mainVal divided by roundVal remainder = mainVal - Int(mainVal / roundVal) * roundVal ' Determine whether to round up or down based on the remainder and half of roundVal If mainVal >= 0 Then If remainder >= h Then v = Application.WorksheetFunction.RoundUp(mainVal / roundVal, 0) * roundVal Else v = Application.WorksheetFunction.RoundDown(mainVal / roundVal, 0) * roundVal End If End If ' Return the rounded value MyRound = v Exit Function ErrSub: ' Handle errors and provide a meaningful message MsgBox "Error Number: " & Err.Number & vbCrLf & "Description: " & Err.Description, vbCritical + vbMsgBoxRight MyRound = 0 End Function وفكرة أخرى تعتمد على العمليات الجسابية بعيدا عن الدوال Function MyRound(ByVal mainVal As Double, ByVal roundVal As Double) As Double Dim roundedValue As Double Dim quotient As Double On Error GoTo ErrHandler ' Check if roundVal is zero to avoid division by zero error If roundVal = 0 Then Err.Raise vbObjectError + 9999, "MyRound", "RoundVal cannot be zero." End If ' Calculate the quotient of mainVal divided by roundVal quotient = mainVal / roundVal ' Determine whether to round up or down based on the quotient If quotient - Int(quotient) >= 0.5 Then roundedValue = Application.WorksheetFunction.RoundUp(quotient, 0) * roundVal Else roundedValue = Application.WorksheetFunction.RoundDown(quotient, 0) * roundVal End If ' Return the rounded value MyRound = roundedValue Exit Function ErrHandler: ' Handle errors and provide a meaningful message MsgBox "Error Number: " & Err.Number & vbCrLf & "Description: " & Err.Description, vbCritical + vbMsgBoxRight MyRound = 0 End Function

ممكن صورة للخطأ ... حتى نفهم المشكلة ... هل بسبب ربط الجداول ام هي حماية ..

الحمد لله رب العالمين ... بارك الله فيك اخي الكريم منكم نتعلم استاذي الفاضل @Foksh اشكر لك الاطراء

يمكنك وضع تاريخ نهاية التقييم في العمود E والتقييم في العمود F واستعمال هذه المعادلة في العمود C إلى =IF(TODAY()<=E2,F2,1) بالتوفيق

يمكنك تعديل الكود المستعمل في الملف إلى هذا وتم إضافة متغير لتحديد الصف الأخير من العمود A Option Explicit Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Boolean Sub Export_Range_As_Picture() Dim Ws As Worksheet, StrToFolder2 As String, lr As Long Dim oRng As Range, sPath As String, oChart As ChartObject Set Ws = ActiveSheet Application.ScreenUpdating = False StrToFolder2 = "D:\pic\" MakeSureDirectoryPathExists StrToFolder2 sPath = StrToFolder2 & Ws.Range("a1").Value & "." & "jpg" lr = Cells(Rows.Count, 1).End(xlUp).Row Set oRng = Ws.Range("A2:E" & lr) oRng.CopyPicture xlScreen, xlPicture Set oChart = Ws.ChartObjects.Add(Left:=0, Top:=0, Width:=oRng.Width * 1, Height:=oRng.Height * 1) With oChart .Activate .Chart.Paste .Chart.Export Filename:=sPath .Delete End With Application.ScreenUpdating = True End Sub بالتوفيق

شكرأ جزيلا لك

اخى الكرريم FOKSH اشكرك على العناية و الاخلاص بالاهتمام بمشاهدة و مراجعة القيديو تأكدت ان الاستجابة هايلة فهل تعتقد ان مواصفات جهازى محتاجة لمراجعة و تحسين windows 7 64bit 8 GB OFFICE 2016 ارجو الافادة مع خالص الشكر و التقدير

Try this instead Function MyRound(ByVal mainVal As Double, ByVal roundVal As Double) As Double Dim h As Double, v As Double On Error GoTo ErrSub h = roundVal / 2 If mainVal >= 0 Then If (mainVal Mod roundVal) >= h Then v = Application.WorksheetFunction.RoundUp(mainVal / roundVal, 0) * roundVal Else v = Application.WorksheetFunction.RoundDown(mainVal / roundVal, 0) * roundVal End If End If MyRound = v Exit Function ErrSub: MsgBox Err.Number & vbCrLf & Err.Description, vbCritical + vbMsgBoxRight MyRound = 0 End Function

السلام عليكم ورحمة الله تعالى وبركاته ضع الصيغة التالية في الخلية (E6) مع سحبها للاسفل =IFERROR(INDEX($J$6:$J$11,MATCH(TRUE,MMULT(--(ROW($J$6:$J$11)>=TRANSPOSE(ROW($J$6:$J$11))),$I$6:$I$11)>=ROWS($1:1),0)),"") في حالة الرغبة بتسلسل عمود المدة بقدر بيانات عمود المبلغ في الخلية (F6) مع سحب المعادلة للاسفل =IF(E6<>"",ROWS($A$1:A1),"") Book1.xlsx

لا اعلم ان كان الذي فهمته صحيح أم لا ,, تفضل هذا التعديل البسيط 101.accdb

البرنامج مع جمال الشرح لكنه لا يعمل على النواة 64 ولا يمكن التعديل عليه ليعمل عليها