sm44ms

اشكرك الف شكر اخي؟ يعلة والديك الجنة

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

ممكن

اريد تعديل على الكود بحيث اذا اخترت من القائمة KH تفتح النماذج المخصص فيها واذا اخترت من القايمة TW تفتح النماذج الخصصه له طبعا بعد الضغط هلى اسم النموذج في القائمة Private Sub KH_Click() ' إعادة تعيين جميع المربعات لتكون فارغة ClearAllLists ' تعبئة القوائم للنماذج المختلفة عند الضغط على KH Me.lstForms1.AddItem "شاشة اصدار البطاقات;FO1" Me.lstForms2.AddItem "شاشة تجديد البطاقات;FO2" Me.lstForms3.AddItem "شاشة تعديل بيانات البطاقات;FO3" Me.lstForms4.AddItem "شاشة تعديل بيانات اساسية فرعية;FO4" Me.lstForms5.AddItem "شاشة اصدار بطاقات المتقاعدين;FO5" Me.lstForms6.AddItem "شاشة البطاقات المنتهية;FO6" Me.lstForms7.AddItem "شاشة الملف الشخصي العام;FO7" End Sub Private Sub TW_Click() ' إعادة تعيين جميع المربعات لتكون فارغة ClearAllLists ' تعبئة القوائم للنماذج الخاصة بـ TW عند الضغط على TW Me.lstForms1.AddItem "شاشة الملف التاريخي العام;TW1" Me.lstForms2.AddItem "حركة الملفات التاريخية;TW2" Me.lstForms3.AddItem "الملف التاريخي;TW3" Me.lstForms4.AddItem "حالة المعاملات التاريخية;TW4" Me.lstForms5.AddItem "الشاشة قيد الاجراء;TW5" Me.lstForms6.AddItem "شاشة قيد الاجراء 2;TW6" Me.lstForms7.AddItem "شاشة الملف ;TW7" End Sub Private Sub ClearAllLists() ' إعادة تعيين جميع مربعات القوائم إلى الحالة الافتراضية Me.lstForms1.RowSource = "" Me.lstForms1.Value = Null Me.lstForms2.RowSource = "" Me.lstForms2.Value = Null Me.lstForms3.RowSource = "" Me.lstForms3.Value = Null Me.lstForms4.RowSource = "" Me.lstForms4.Value = Null Me.lstForms5.RowSource = "" Me.lstForms5.Value = Null Me.lstForms6.RowSource = "" Me.lstForms6.Value = Null Me.lstForms7.RowSource = "" Me.lstForms7.Value = Null End Sub Private Sub lstForms1_AfterUpdate() HandleFormOpen Me.lstForms1 End Sub Private Sub lstForms2_AfterUpdate() HandleFormOpen Me.lstForms2 End Sub Private Sub lstForms3_AfterUpdate() HandleFormOpen Me.lstForms3 End Sub Private Sub lstForms4_AfterUpdate() HandleFormOpen Me.lstForms4 End Sub Private Sub lstForms5_AfterUpdate() HandleFormOpen Me.lstForms5 End Sub Private Sub lstForms6_AfterUpdate() HandleFormOpen Me.lstForms6 End Sub Private Sub lstForms7_AfterUpdate() HandleFormOpen Me.lstForms7 End Sub Private Sub HandleFormOpen(lst As Control) ' تحقق من العنصر المحدد في مربع القائمة Dim selectedIndex As Integer selectedIndex = lst.ListIndex If selectedIndex = -1 Then MsgBox "يرجى اختيار عنصر من القائمة.", vbExclamation Exit Sub End If Select Case selectedIndex Case 0 ' فتح أكثر من نموذج عند Case 0 If Not IsFormOpen("MECARD") Then DoCmd.OpenForm "MECARD" If Not IsFormOpen("FEND HOSTRY") Then DoCmd.OpenForm "FEND HOSTRY" Case 1 If Not IsFormOpen("FORM2") Then DoCmd.OpenForm "FORM2" If Not IsFormOpen("FORM29") Then DoCmd.OpenForm "FORM29" Case 2 If Not IsFormOpen("FORM3") Then DoCmd.OpenForm "FORM3" Case 3 If Not IsFormOpen("FORM4") Then DoCmd.OpenForm "FORM4" Case 4 If Not IsFormOpen("FORM5") Then DoCmd.OpenForm "FORM5" Case Else MsgBox "النموذج غير موجود." End Select End Sub Private Function IsFormOpen(formName As String) As Boolean ' التحقق إذا كان النموذج مفتوح بالفعل On Error Resume Next IsFormOpen = (CurrentProject.AllForms(formName).IsLoaded) On Error GoTo 0 End Function Private Sub Form_Load() ' إعادة تعيين مربعي القوائم عند فتح النموذج Me.lstForms1.RowSource = "" ' تفريغ مربع القائمة الأول Me.lstForms2.RowSource = "" Me.lstForms3.RowSource = "" Me.lstForms4.RowSource = "" Me.lstForms5.RowSource = "" Me.lstForms6.RowSource = "" Me.lstForms7.RowSource = "" End Sub

اشكرك اخي

سوف اجرب وارد لك اشكرك على كل حال بعد التجربة سوف اخبرك

هذا المرفق msgpass الرقم السري على شكل نجوم.accdb

لدي نموذج افتح برقم سري عن طريق الكود عند الفتح - كان زمان تظهر كلمة المرور على شكل نجوم عدلت شوي على الكود صار الرقم السري يظهر بدون نجوم يعني عادي اليكم الكود والوحدة النمطية On Error GoTo Err_clic5 TimerId = SetTimer(0, 0, 1, AddressOf TimerProc) ' رسالة توضيحية لطلب إدخال كلمة المرور Dim str_Title As String Dim str_Prompt As String Dim userInput As String Dim mypass As Variant str_Title = "ادخال كلمة المرور" str_Prompt = "ادخل الرقم السري الذي تم منحة لك لدخول هذه الشاشة" ' الطلب من المستخدم إدخال كلمة المرور userInput = InputBox(str_Prompt, str_Title) ' البحث عن كلمة المرور في الجدول mypass = DLookup("[Password]", "tblUsers", "[Password] = '" & userInput & "'") ' التحقق مما إذا كانت كلمة المرور المدخلة تطابق أي كلمة مرور في الجدول If Not IsNull(mypass) Then ' كلمة المرور صحيحة، يستمر بفتح النموذج Exit Sub Else ' كلمة المرور غير صحيحة، يتم فتح نموذج الرفض وإلغاء العملية DoCmd.OpenForm "ACSSEC2" DoCmd.CancelEvent Exit Sub End If Exit_clic5: Exit Sub Err_clic5: DoCmd.Close MsgBox "تم الغاء الدخول بسبب عدم وجود صلاحيات كافية" Resume Exit_clic5 الوحدة النمطية Option Compare Database Declare Function SetTimer Lib "user32" (ByVal hwnd _ As Long, ByVal nIDEvent As Long, ByVal uElapse _ As Long, ByVal lpTimerFunc As Long) As Long Declare Function KillTimer Lib "user32" _ (ByVal hwnd As Long, ByVal nIDEvent As Long) _ As Long Declare Function FindWindowEx Lib "user32" _ Alias "FindWindowExA" (ByVal hWndParent As _ Long, ByVal hWndChildAfter As Long, ByVal _ lpClassName As String, ByVal lpWindowName _ As String) As Long Declare Function Sendmessagebynum _ Lib "user32" Alias "SendMessageA" (ByVal _ hwnd As Long, ByVal wMsg As Long, ByVal _ wParam As Long, ByVal lParam As Long) _ As Long Const EM_SETPASSWORDCHAR = &HCC Public str_Title$, TimerId& Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) KillTimer 0, TimerId Dim lng_Hwnd& lng_Hwnd = FindWindowEx(0, 0, "#32770", _ Trim(str_Title)) lng_Hwnd = FindWindowEx(lng_Hwnd, 0, _ "Edit", vbNullString) If lng_Hwnd Then Sendmessagebynum lng_Hwnd, EM_SETPASSWORDCHAR, 42, 0 End If End Sub اريد الباسورد على شكل نجوم ممكن

لم يعمل سوف اجهز المرفق لك وعدل عليه انت

اريد تعديل

الكود الذي ارسلته لم اعرف اين اضعه شوف هذا الكود الي معي على زر الامر ... للحفظ Private Sub SAEF_Click() DoCmd.RunCommand acCmdSaveRecord Dim db As DAO.Database Dim rst As DAO.Recordset Dim existingName As String Dim nameExists As Boolean Set db = CurrentDb nameExists = False ' التحقق مما إذا كان الاسم موجودًا بالفعل في الجدول Set rst = db.OpenRecordset("SELECT [NAME ARABIC] FROM TABELSIMCARD WHERE [NAME ARABIC] = '" & Me.D2 & "'", dbOpenSnapshot) If Not rst.EOF Then ' إذا تم العثور على السجل، فذلك يعني أن الاسم موجود nameExists = True End If rst.Close Set rst = Nothing Set db = Nothing ' إذا كان الاسم موجودًا بالفعل، عرض رسالة تحذيرية وعدم الحفظ If nameExists Then MsgBox "الاسم '" & Me.D2 & "' الموظف موجود مسبقاً في نظام الكشوفات الخاصة ببطاقات الهاتف.", vbExclamation Else End If End Sub هو عباره عن نقل الاسم من حقل غير منظم اسمه D2 الى حقل منظم اسمه NAME ARABIC اذا كان الاسم موجود في الجدول الاساسي المنظم تظهر الرساله انه مكرر - ولا اريد يحفظ البيانات واذا لم يكن مكرر يتم الحفظ

السلام عليكم اريد تعديل على هذا الكود - D2حقل الاسم الاساسي مصدر بيانات NAME ARABIC فية حقل غير منظم اسمه EMPNA اسحب بيانات عن طريق البحث طبعا هو من جدول اخر - يقوم بنسخ الاسم الى الحقل السابق D2 عند الضغط على حفظ انا اريد اذا كان الاسم مكرر في الحقل D2 لايحفظ اي بيانات فقط اريد الرساله الموجوده في الكود التالي واذا غير مكرر يحفظ لي دون عرض الرساله بان الاسم مكرر انا اريد تعديل على هذا الكود ؟؟؟؟؟ DoCmd.RunCommand acCmdSaveRecord Dim db As DAO.Database Dim rst As DAO.Recordset Dim existingName As String Dim nameExists As Boolean Set db = CurrentDb nameExists = False ' التحقق مما إذا كان الاسم موجودًا بالفعل في الجدول Set rst = db.OpenRecordset("SELECT [NAME ARABIC] FROM TABELSIMCARD WHERE [NAME ARABIC] = '" & Me.D2 & "'", dbOpenSnapshot) If Not rst.EOF Then ' إذا تم العثور على السجل، فذلك يعني أن الاسم موجود nameExists = True End If rst.Close Set rst = Nothing Set db = Nothing ' إذا كان الاسم موجودًا بالفعل، عرض رسالة تحذيرية وعدم الحفظ If nameExists Then MsgBox "الاسم '" & Me.D2 & "' الموظف موجود مسبقاً في نظام الكشوفات الخاصة ببطاقات الهاتف.", vbExclamation Else End If

شكرا

- السلام عليكم ورحمة الله وبركاتة؟ عندي جدول في حقل الادارة فيه قيمة مكررة باسم الادارات اي ان الادارة مكرر اكثر من مره ولاكثر من موظف اريد حساب عدد الادارة في النموذج دون تكرار لو فيه داله او كود مبسط اكون شاكر لكم

اشكرك الف شكر اخي