ابو جودي

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

النماذج الفرعية:
لكل نسخة من النموذج AccTree سيكون هناك نسخة مستقلة من النماذج الفرعية
التلاعب بالقيم:
يؤثر فقط على النسخة التي تعمل عليها
clnClient.Add:
يستخدم لتخزين النماذج المفتوحة بحيث يمكن الوصول إليها لاحقا باستخدام معرف النافذة
المتغيرات:
يمكن استخدام نفس المتغير لإدارة جميع النماذج أو يمكن تعريف متغيرات منفصلة حسب الحاجة

 

جرب المرقق ده 
https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=229962&key=6be4aebe1bd6693b595feff8e00d6e1f

Private Sub jop_BeforeUpdate(Cancel As Integer) Dim db As DAO.Database Dim rs As DAO.Recordset Dim UserCount As Integer Dim PasswordInput As String Set db = CurrentDb() If Me.jop.Value <> "محاسب" And Me.jop.Value <> "مستخدم" Then MsgBox "برجاء إدخال كلمة محاسب أو مستخدم فقط.", vbExclamation, "قيمة غير صحيحة" Cancel = True Exit Sub End If If Me.jop.Value = "مستخدم" Then Set rs = db.OpenRecordset("SELECT COUNT(*) AS CountOfUsers FROM tblUsers WHERE jop = 'مستخدم'") UserCount = rs!CountOfUsers If UserCount >= 3 Then PasswordInput = InputBox("لقد تم إدخال 3 سجلات لمستخدمين. يرجى إدخال كلمة السر لإضافة مستخدم جديد:") If PasswordInput = "" Or PasswordInput <> "123" Then MsgBox "كلمة السر غير صحيحة. لا يمكن إضافة مستخدم جديد.", vbExclamation Cancel = True End If End If rs.Close Set rs = Nothing End If Set db = Nothing End Sub  

اعتقد يقصد الـتسمية " Caption "

والحل فى وحدة نمطية عامة
Public Function CopyCaptionToTextBox(TextBoxName As String) Dim ctrl As Control Set ctrl = Screen.ActiveControl If TypeOf ctrl Is CommandButton Then Forms(ctrl.Parent.Name).Controls(TextBoxName).Value = ctrl.Caption End If End Function للاستدعاء على اكثر من زر 
اولا تحديد كل الازرار التى نريد منها تنفيذ هذا الاجراء

والاستدعاء يتم بكتابة الكود بالشكل التالى فى الحدث عند الضغط
طبعا مع تغيير YouTextBoxNameInForm باسم مربع النص الموجود فى النموذج 
 
=CopyCaptionToTextBox("YouTextBoxNameInForm")  

 
 
 
المرفق بعد التعديل 
 
RR.accdb

اتفضل يا سيدى  
 
1234.accdb

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

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

سوف اقدم اليك النصح وانا اقل طويلب علم بالمنتدى 
ضع نصب عينيك دائما وابدا وبوجه خاص مع الاكسس البساطة قدر الامكان لانه صدقنى وعندما تكون البيانات اولا قليلة او قد يتتطلب مشروعك عمل وتنفيذ الكثير من الاجراءات وبالاخص ان كانت معقدة وام تم التعامل مع جهاز ضعيف او عبر استخدام القاعدة ضمن شبكة محلية قد تصيبك صدمة من استخدام ما قد يكون لو تأثير بالسلب على اداء وسرعة فاعدة البيانات
لذلك انصحك بالبساطة اعلم انه فد ترى وتشاهد حركات وامور تكون مبهجة وقد تعجب بها جدا ولكن كما اخبرتك 
 
واليك مثال على الرئيسية  على سبيل المثال
 
expand and collapse button V3.zip

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

ممكن تجرب الكود ده  
 
Dim ImagePath As String s1 = Str(Me![رقم الجلوس]) s1 = Right(s1, Len(s1) - 1) ImagePath = "D:\صور\" & s1 & ".jpg" On Error Resume Next Me![Image_Std].Picture = ImagePath If Err.Number <> 0 Then MsgBox "لا توجد صورة مطابقة لرقم الجلوس", vbExclamation, "خطأ" Err.Clear End If On Error GoTo 0 End Sub  

باش مهندسة @hanan_ms 
والدكتورة @safaa salem5 
اتفضلو المرفق ده 
Full Control Of Print Report التحكم في الطابعة وخصائصها طباعة التقارير.mdb

اتفضل جرب استيراد البيانات من خلال نموذج Form1
من خلال الضغط على الزر واستعراض المجلدات لاختيار ملف الاكسل المراد استيراد البيانات منه
سوف يتم انشاء جدول مؤقت به البيانات انقلها بعد ذلك للجدول وقم بباقى العمليات التى تريد اجراءها كما بحلو لك
test ExcelDataImport.rar

جرب الجملة التالية
 
"DELETE FROM tblBounce WHERE (((tblBounce.id) = " & x & "));"  

للاسف مع الاخفاء لابد من ان تكون  
Pou Up = yes
Modal = YES
لكل النماذج والتقارير
ولا انصحك باعتماد كود اخفاء اطار الاكسس هذا

وممكن 

 
SELECT VAL([ID]) AS valID, * FROM tblEmployees WHERE VAL([ID]) BETWEEN 50 AND 80;  
وممكن استخدام دالة CDBL لتحويل إلى رقم مزدوج (Double):
SELECT CDBL([ID]) AS cdblID, * FROM tblEmployees WHERE CDBL([ID]) BETWEEN 50 AND 80; وممكن استخدام دالة CDATE للتحويل إلى تاريخ (إذا كان يمكن تفسير القيم كتواريخ)
SELECT CDATE([FieldName]) AS cdateFieldName, * FROM TableName WHERE CDATE([FieldName]) Between #50# And #80#;  

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

اعتقد الاستعلام بدون اقواس بالشكل الاتى سوف يكون افضل
لان استخدام الأقواس ([]) في أسماء الحقول قد يؤدي إلى مشكلات في بعض الحالات وهذا عن تجربة شخصية
ولا يتطوع او يتبرع أحد ويسألنى عن السبب لأننى فعلا لا أعرف 
SELECT Data1.ID, Data1.namee, Data1.edara, Data1.woork, Data1.egraa FROM Data1 WHERE (Data1.namee Like "*" & [Forms]![Data1]![Combo17] & "*") AND (Data1.egraa Like "*" & [Forms]![Data1]![Combo19] & "*");  

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

طيب جرب المرفق ده


 
Goporodact_3.rar

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

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

يعنى كود ذكى وابن حلال وبيقدر يفهمنا من أول تكه على الزرار اه والله زيمبئولكم كده.. شغل فاخر من الاخر   اومااااااااااال 

1- أكواد الوحدة النمطية
 
Option Compare Database Option Explicit ' Constant that specifies the time interval for color flashing (in seconds) Const dblTimeInterval As Double = 0.5 ' Constant that determines the number of times the colors will flash Const intFlashCount As Integer = 5 ' Variable to track whether Label flashing should occur Public AllowFlashing ' Public variables to store default values Public btnControlDefaultColor As Long Public lblControlDefaultColor As Long Public strLblControlCaption As String Public formIsClosing As Boolean ' Public variable to store the selected button Public selectedButton As CommandButton ' Function to return the highlighted color Function ApplyHighlighted() As Long ApplyHighlighted = RGB(255, 255, 0) End Function ' Subroutine to set the button color Sub ButtonColor(ByVal frm As Form, Optional btn As CommandButton = Nothing, Optional DisableLabelChange As Boolean) ' Set the default button color if not highlighted If Not btn Is Nothing Then If btn.BackColor <> ApplyHighlighted Then btnControlDefaultColor = btn.BackColor ' Clear the previous button's highlight If Not selectedButton Is Nothing Then selectedButton.BackColor = btnControlDefaultColor End If ' Set the new button as selected and highlight it btn.BackColor = ApplyHighlighted ' Save the caption of the current button If Not DisableLabelChange Then strLblControlCaption = btn.Caption End If Set selectedButton = btn End If End Sub ' Subroutine to flash the label control Sub FlashLabelControl(frm As Form, lblControl As Object, DisableLabelChange As Boolean) On Error GoTo ErrorHandler Dim flashingColor As Long Dim flashingInterval As Single Dim flashCount As Integer Dim flashTimer As Single Dim i As Integer On Error GoTo 0 ' Turn off error trapping. On Error Resume Next ' Defer error trapping. ' Set the default label color if not highlighted If lblControl.BackColor <> ApplyHighlighted Then lblControlDefaultColor = lblControl.BackColor flashingColor = ApplyHighlighted flashingInterval = dblTimeInterval flashCount = intFlashCount ' Reset the label color to the default when the form is loaded If TypeOf lblControl Is Access.Label And Not formIsClosing Then lblControl.BackColor = lblControlDefaultColor If Not DisableLabelChange Then lblControl.Caption = strLblControlCaption End If End If flashTimer = Timer + flashingInterval ' Flash the label color For i = 1 To flashCount Do While Timer < flashTimer And Not formIsClosing DoEvents Loop ' Update the label color during the flash If TypeOf lblControl Is Access.Label And Not formIsClosing Then If AllowFlashing Then ' Check the AllowLabelCaptionChange value to determine whether to change the caption If Not DisableLabelChange Then lblControl.Caption = IIf(lblControl.Caption = strLblControlCaption, strLblControlCaption, vbNullString) End If lblControl.BackColor = IIf(lblControl.BackColor = lblControlDefaultColor, flashingColor, lblControlDefaultColor) End If End If ' Update the flash timer flashTimer = Timer + flashingInterval Next i ' Reset the label color to the default after flashing If TypeOf lblControl Is Access.Label And Not formIsClosing Then lblControl.BackColor = lblControlDefaultColor If Not DisableLabelChange Then lblControl.Caption = strLblControlCaption End If End If ' 2467 Err.Clear ' Clear Err Exit Sub ' Exit to avoid handler. ErrorHandler: ' Error-handling routine. Select Case Err.Number ' Evaluate error number. Case Is = 2467 flashCount = 0 flashTimer = 0 Exit Sub ' Exit to avoid handler. Case Else ' Handle other situations here... MsgBox Err.Number & ": " & Err.Description Resume ' Resume execution at the same line End Select End Sub ' Subroutine to change the button color and control Label flashing Sub ChangeCommandButtonColor(frm As Form, Optional lblControl As Object, Optional DisableLabelChange As Boolean) On Error GoTo ErrorHandler Dim clickedButton As CommandButton Set clickedButton = frm.ActiveControl On Error GoTo 0 ' Turn off error trapping. On Error Resume Next ' Defer error trapping. ' Clear the previous button's highlight If Not selectedButton Is Nothing Then selectedButton.BackColor = btnControlDefaultColor lblControl.Caption = "" strLblControlCaption = "" End If ' Set the new button as selected and highlight it Set selectedButton = clickedButton ' Update the label caption If Not DisableLabelChange Then strLblControlCaption = clickedButton.Caption End If ' Apply the button color and control Label flashing ButtonColor frm, clickedButton, True ' Check if lblControl is provided and is a valid object If Not lblControl Is Nothing Then AllowFlashing = Not DisableLabelChange ' Determine whether to trigger flashing lblControl.Caption = strLblControlCaption FlashLabelControl frm, lblControl, False End If Err.Clear ' Clear Err Exit Sub ' Exit to avoid handler. ErrorHandler: ' Error-handling routine. Select Case Err.Number ' Evaluate error number. Case Is = 5 Exit Sub ' Exit to avoid handler. Case Else ' Handle other situations here... MsgBox Err.Number & ": " & Err.Description Resume ' Resume execution at the same line End Select End Sub  2- الاكواد للاستخدام من خلال النموذج ولا اسهل من كده..  يا عينى ع الدلع
 
Private Sub Form_Load() formIsClosing = False End Sub Private Sub Form_Close() formIsClosing = True End Sub Private Sub Command1_Click() ' Call the ChangeCommandButtonColor subroutine with the current form and label control (lblDisplayTitle). ChangeCommandButtonColor Me, Me.lblDisplayTitle End Sub Private Sub Command2_Click() ' Call the ChangeCommandButtonColor subroutine with the current form and label control (lblDisplayTitle). ChangeCommandButtonColor Me, Me.lblDisplayTitle End Sub Private Sub Command3_Click() ' Call the ChangeCommandButtonColor subroutine with the current form and label control (lblDisplayTitle). ChangeCommandButtonColor Me, Me.lblDisplayTitle End Sub Private Sub Command4_Click() ' Call the ChangeCommandButtonColor subroutine with the current form and label control (lblDisplayTitle). ChangeCommandButtonColor Me, Me.lblDisplayTitle End Sub Private Sub Command5_Click() ' Call the ChangeCommandButtonColor subroutine with the current form only without label control (lblDisplayTitle). ' To disable Allow Label Caption Change = True ChangeCommandButtonColor Me, Me.lblDisplayTitle, True End Sub
معلش انا شرحت كل شئ ع الأكواد بالانجليزى طبعا مش فلسفة علشان عارف انت هتقول ايه سامعك...
علشان العربى بيعمل مشاكل فى الاعدادت الاقليمية للغة لو مكانت مضبوطه

بس خلاص 

• وأخيرا المرفق
 
FlashLabel.accdb

Documents_2.rar

ومن قال انه يكفينى انا ؟!
ومن قال اننى فى حل

اعتذر عن التأخير كنت صائم
 
  

بل روعة حياتنا هم اساتذتنا العظماء الذين اناروا افكارنا
شكرا لكم استاذى الجليل و معلمى القدير و والدى الحبيب استاذ @ابوخليل سعادة  الحياة أن تكون بجانبك وتساندك روح طيبة وكريمة تمنحك وتهديك الفرح والسرور وتدخل على نفوس من حولها الفرح و السعادة
ولا أزكيكم على الله وكل اساتذتنا المبجلين كل كلمات ومعان الشكر والعرفان بالجميل لا تكفيكم وتوفيكم قدر حقكم 
بارك الله لكم فى عمركم وفى علمكم و عملكم واهلكم وأسال الله تعالى لكم سعادة الدارين وان يزيدكم من فضله كما تدخلون السرور على قلوب طلاب العلم
دائما تكثرون من العطاء وبكل سخاء دون كلل ولا ملل
احسن الله اليكم كما تحسنون الى طلاب العلم دائما 
-----
اتفضل استاذى الجليل ومعلمى القدير ووالدى الحبيب 
اولا الدالة الاتية لاحضار اسماء الحقول
 
Function GetFieldNameFromRowSource(ComboRowSource As String, columnIndex As Integer) As String Dim columns As Variant Dim columnName As String ' Split the RowSource to get the column names columns = Split(Mid(ComboRowSource, InStr(ComboRowSource, "SELECT") + Len("SELECT")), ",") ' Extract the column name from the specified index columnName = Trim(Split(Split(columns(columnIndex - 1), "AS")(0), ".")(1)) ' Return the column name GetFieldNameFromRowSource = columnName End Function  وهذه الدالة التى يتم التحديث من خلالها
Sub GetComboBoxNameAndUpdateTableRecords(frm As Form) Dim ctrl As Control Dim ComboRowSource As String Dim FldData As String Dim FldID As String Dim strSQL As String ' Loop through all controls on the form For Each ctrl In frm.Controls ' Check if the control is a TextBox or a ComboBox If TypeOf ctrl Is comboBox Then ' Perform your custom action for each control ' For example, print the name and set a default value If Not ctrl Is Nothing Then ' Debug.Print "Control Name: " & ctrl.Name ComboRowSource = ctrl.rowSource FldID = GetFieldNameFromRowSource(ComboRowSource, 1) FldData = GetFieldNameFromRowSource(ComboRowSource, 2) Dim varConditionFieldValue As Variant Dim varUpdateFieldValue As Variant ' Open the database Dim db As DAO.Database Set db = CurrentDb ' Verify RowSource If Len(ComboRowSource) = 0 Then ' Debug.Print "RowSource is empty for control " & ctrl.Name Exit For End If ' Open a recordset for the values in targetComboBox Dim rsCombo As DAO.Recordset Set rsCombo = db.OpenRecordset(ComboRowSource, dbOpenSnapshot) ' Verify Recordset If rsCombo.EOF Then ' Debug.Print "Recordset is empty for control " & ctrl.Name rsCombo.Close Set rsCombo = Nothing Set db = Nothing Exit For End If Do Until rsCombo.EOF Dim TableName As String Dim FieldToUpdate As String Dim ConditionFieldNameTable As Variant Dim ConditionComboBoxFieldNameTable As Variant ' Get the value from the current record in targetComboBox varConditionFieldValue = rsCombo.Fields(FldID).Value varUpdateFieldValue = rsCombo.Fields(FldData).Value ' Table and Field Names TableName = "Table1" FieldToUpdate = "textNm" ConditionFieldNameTable = "frmNm" ConditionComboBoxFieldNameTable = "FieldNm" ' Construct the SQL update statement strSQL = "UPDATE " & TableName & " " & _ "SET " & FieldToUpdate & "='" & Nz(varUpdateFieldValue, "") & "' " & _ "WHERE " & TableName & "." & ConditionComboBoxFieldNameTable & "= '" & ctrl.Name & "' AND " & _ TableName & "." & ConditionFieldNameTable & "= '" & Nz(frm.Name, "") & "' AND " & _ TableName & "." & FieldToUpdate & "= '" & varConditionFieldValue & "';" ' Debug.Print strSQL ' Execute the query db.Execute strSQL, dbFailOnError rsCombo.MoveNext Loop ' Close the recordset and the database rsCombo.Close Set rsCombo = Nothing Set db = Nothing End If End If Next ctrl End Sub ونستدعى الدالة فقط من خلال 
GetComboBoxNameAndUpdateTableRecords Me هى سوف تقوم بكل شئ بالنيابة عنك  
لا تقلق منها يا معلملى هى دالة ذكية ليست مثلى


طبعا يا استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل 
ان اردت اضافة هذه المعاملات (  parameters  ) الى رأس الدالة لتكتبها عند الاستدعاء ان كانت متغيرة فلا بأس بذلك سبق التعامل معها فى الامثلة السابقة
' Table and Field Names TableName = "Table1" FieldToUpdate = "textNm" ConditionFieldNameTable = "frmNm" ConditionComboBoxFieldNameTable = "FieldNm"  
بــــــس خلاص أخيرا خلصت الواجب الحمد لله 
واخيرا المرفق 

 
DatabaseUp7.rar

اتفضل يا دكتور المرفق وبه 4 استعلامات
تدلل واختر ما يلبى رغباتك
 
 
الاكثر بيع.accdb

بعد اذن اخوانى الكرام واساتذتى العظماء 
اذا انا قدرت افهم اصح 
هذه تجربتى بالمرفق  ده لو كنت فهمت صح يعنى
ملحوظة انا حذفت جدول sub_tbl لان انا لا ارى له اى اثر ولا اى فائدة اصلا على الاقل طبقا للمرفق الاتى 
 
اختنا الغالية @safaa salem5
راجعت الاكواد قدر المستطاع وحسب ما ترائى لى قمت بسد كل الثغرات التى قد تضيف سجلات فارغة او ينتج عنها اخطاء باستخدام كود تصيد الاخطاء وذلك حسب الخطوات فقط التى كنت اقوم بتجربتها 
اذا فى المرفق الفائدة اولا من تحقيق طلبك برجاء مراجعة الاكواد قمت بالعديد من الاضافات والتغييرات  
كذلك باتت القاعدة لن تحفظ اى بيانات الا بالضغط على زر الامر حفظ 
 
lab8.zip

ولا تزعلى نفسك سهله ان شاء الله
اتفضلى يا افندم غيرى الكود السابق بالكود اللاحق
Private Sub pname_AfterUpdate() If Not NewRecord Then Exit Sub Dim strDLookupFlds As String Dim stLinkCriteria As String Dim MyVariable As String Dim Arry() As String MyVariable = Me.pname stLinkCriteria = "[pname] ='" & MyVariable & "'" '|String On Error GoTo ErrorHandler strDLookupFlds = DLookup("[pname] & '|' & [code] & '|' & [ptitle] & '|' & [bdate] & '|' & [gender] & '|' & [phone] & '|' & [mobile] & '|' & [adress] & '|' & [email] & '|' & [wt] & '|' & [ht]", "[reservation_tbl]", stLinkCriteria) Arry = Split(strDLookupFlds, "|") Me.code = Arry(1) Me.ptitle = Arry(2) Me.bdate = Arry(3) Me.gender = Arry(4) Me.phone = Arry(5) Me.mobile = Arry(6) Me.adress = Arry(7) Me.email = Arry(8) Me.wt = Arry(9) Me.ht = Arry(10) ExitHandler: Exit Sub ErrorHandler: Select Case Err.Number Case Is = 94: pname.Requery: Resume ExitHandler Case Else MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description Resume ExitHandler End Select End Sub  
وغيرى الكود الخاص بزر امر الاضافة الى الكود الاتى 
Private Sub Add_cmd_Click() On Error GoTo Err_NewRec DoCmd.Requery DoCmd.GoToRecord , , acNewRec Exit_Err_NewRec: Exit Sub Err_NewRec: MsgBox Err.Description Resume Exit_Err_NewRec End Sub  
وهذا مرفقكم بعد التعديل 
 
lab3(2).zip

اتفضل  
 
مم.accdb