sm44ms

مبارك عليكم الشهر الكريم اذا اردت عرض التاريخ الهجري في النموذج او التقرير ماهي الداله لذلك

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

اشكركم جميعا؟ Foksh الاخ جربت على التقرير عندي ولم يعمل سوف اجرب وارد لكم اليوم kkhalifa1960 الاخ يعني انسخ المربع فيوق الصوره

حاولت اكثر من مره اسويها في الباوربوينت ولم تظبط معي اذا سمحت تسوي لي نموذج من عندك جزاك الله خير هذا الي اريد

لا الصوره الاخير الذي تحت اريدها خفيفه جدا على شكل خلفيه

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

اشكرك

اشتغل ؟ ولكن فيه خطاء في التوقيت العالمي مثال - انا في ابوظبي والفرق بينها ومكة ساعه نفس الشي في عدن وبعض المدن والفرق كبير Private Sub Form_Timer() ' زيادة العداد x = x + 1 ' تحديث الوقت الحالي في Text1 Me.Text1 = Time ' تغيير المنطقة الزمنية كل 5 ثواني If x = 5 Then x = 0 currentTimeZone = currentTimeZone + 1 ' إعادة تعيين المنطقة الزمنية إذا تجاوزت الحد الأقصى If currentTimeZone > 10 Then currentTimeZone = 0 ' الحصول على الوقت حسب المنطقة الزمنية الحالية Select Case currentTimeZone Case 0 ' أبوظبي (UTC+4) Me.Text2 = Format(dateadd("h", 4, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss AM/PM") & " أبوظبي" Case 1 ' مكة المكرمة (UTC+3) Me.Text2 = Format(dateadd("h", 3, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss AM/PM") & " مكة المكرمة" Case 2 ' توقيت غرينتش (UTC+0) Me.Text2 = Format(TimeSerial(Hour(Time), Minute(Time), Second(Time)), "hh:nn:ss AM/PM") & " غرينتش" Case 3 ' موسكو (UTC+3) Me.Text2 = Format(dateadd("h", 3, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss AM/PM") & " موسكو" Case 4 ' نيويورك (UTC-5) Me.Text2 = Format(dateadd("h", -5, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss AM/PM") & " نيويورك" Case 5 ' طوكيو (UTC+9) Me.Text2 = Format(dateadd("h", 9, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss AM/PM") & " طوكيو" Case 6 ' عدن (UTC+3) Me.Text2 = Format(dateadd("h", 3, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss AM/PM") & " عدن" Case 7 ' القاهرة (UTC+2) Me.Text2 = Format(dateadd("h", 2, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss AM/PM") & " القاهرة" Case 8 ' بكين (UTC+8) Me.Text2 = Format(dateadd("h", 8, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss AM/PM") & " بكين" Case 9 ' باريس (UTC+1) Me.Text2 = Format(dateadd("h", 1, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss AM/PM") & " باريس" Case 10 ' لندن (UTC+0) Me.Text2 = Format(TimeSerial(Hour(Time), Minute(Time), Second(Time)), "hh:nn:ss AM/PM") & " لندن" End Select End If End Sub

ياصديقي - حصلت معي مشكلة هنا - لاني استخدم كود ثاني مع هذا وارفق لك الكود لتعدلهOption Compare Database Option Compare Database Option Explicit Private x As Integer Private currentTimeZone As Integer Private Sub Form_Timer() ' زيادة العداد x = x + 1 ' تحديث الوقت الحالي في Text1 Me.Text1 = Time ' تغيير المنطقة الزمنية كل 5 ثواني If x = 5 Then x = 0 currentTimeZone = currentTimeZone + 1 If currentTimeZone > 3 Then currentTimeZone = 0 ' الحصول على الوقت حسب المنطقة الزمنية الحالية Select Case currentTimeZone Case 0 ' أبوظبي (UTC+4) Me.Text2 = Format(dateadd("h", 4, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss") & " أبوظبي" Case 1 ' مكة المكرمة (UTC+3) Me.Text2 = Format(dateadd("h", 3, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss") & " مكة المكرمة" Case 2 ' توقيت غرينتش (UTC+0) Me.Text2 = Format(TimeSerial(Hour(Time), Minute(Time), Second(Time)), "hh:nn:ss") & " غرينتش" Case 3 ' موسكو (UTC+3) Me.Text2 = Format(dateadd("h", 3, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss") & " موسكو" End Select End If On Error Resume Next If [TT] = "بدل فاقد" Then If [TT].ForeColor = vbYellow Then [TT].ForeColor = vbBlack [TT].BackColor = vbBlack Else [TT].ForeColor = vbYellow [TT].BackColor = vbBlack End If Else [TT].ForeColor = vbBlack [TT].BackColor = vbWhite End If If [ss] = "متقاعد" Then If [ss].ForeColor = vbWhite Then [ss].ForeColor = vbBlue [ss].BackColor = vbRed Else [ss].ForeColor = vbWhite [ss].BackColor = vbBlue End If Else [ss].ForeColor = vbBlack [ss].BackColor = vbYellow End If If [BD] = "استقالة" Then If [BD].ForeColor = vbWhite Then [BD].ForeColor = vbRed [ss].BackColor = vbRed Else [BD].ForeColor = vbWhite [BD].BackColor = vbRed End If Else [BD].ForeColor = vbBlack [BD].BackColor = vbYellow End If End Sub Option Compare Database Option Explicit Private x As Integer Private currentTimeZone As Integer Private Sub Form_Timer() ' زيادة العداد x = x + 1 ' تحديث الوقت الحالي في Text1 Me.Text1 = Time ' تغيير المنطقة الزمنية كل 5 ثواني If x = 5 Then x = 0 currentTimeZone = currentTimeZone + 1 If currentTimeZone > 3 Then currentTimeZone = 0 ' الحصول على الوقت حسب المنطقة الزمنية الحالية Select Case currentTimeZone Case 0 ' أبوظبي (UTC+4) Me.Text2 = Format(dateadd("h", 4, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss") & " أبوظبي" Case 1 ' مكة المكرمة (UTC+3) Me.Text2 = Format(dateadd("h", 3, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss") & " مكة المكرمة" Case 2 ' توقيت غرينتش (UTC+0) Me.Text2 = Format(TimeSerial(Hour(Time), Minute(Time), Second(Time)), "hh:nn:ss") & " غرينتش" Case 3 ' موسكو (UTC+3) Me.Text2 = Format(dateadd("h", 3, TimeSerial(Hour(Time), Minute(Time), Second(Time))), "hh:nn:ss") & " موسكو" End Select End If On Error Resume Next If [TT] = "بدل فاقد" Then If [TT].ForeColor = vbYellow Then [TT].ForeColor = vbBlack [TT].BackColor = vbBlack Else [TT].ForeColor = vbYellow [TT].BackColor = vbBlack End If Else [TT].ForeColor = vbBlack [TT].BackColor = vbWhite End If If [ss] = "متقاعد" Then If [ss].ForeColor = vbWhite Then [ss].ForeColor = vbBlue [ss].BackColor = vbRed Else [ss].ForeColor = vbWhite [ss].BackColor = vbBlue End If Else [ss].ForeColor = vbBlack [ss].BackColor = vbYellow End If If [BD] = "استقالة" Then If [BD].ForeColor = vbWhite Then [BD].ForeColor = vbRed [ss].BackColor = vbRed Else [BD].ForeColor = vbWhite [BD].BackColor = vbRed End If Else [BD].ForeColor = vbBlack [BD].BackColor = vbYellow End If End Sub سبب مشكلة هنا ولم يعمل Option Compare Database

حلو ه الفكره ولكن كيف فتح عدد 2 محرر اكود لنفس الحدث لاني اريد كود الوقت لبعض الدول مثل ابوظبي مكة قرينتش موسكو في حقل واحد وتتغير كل 5 ثواني بين كل دوله في التوقيت

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

هلاهلا - وهل يفتي ومالك في المدينة؟ ع العموم شكرا على تواضعك هذا - اما بخصوص الانترنت نعم يجب ان تكون متصل بالانترنت؟ اما ملف الجنسيات موجود عندي كامل به كل الجنسيات اذا تبيه برسله لك نعود للكود Private Sub Drive_Nat_AfterUpdate() On Error Resume Next ' استدعاء الدالة Translate لترجمة الجنسية العربي إلى الإنجليزي Dim translatedText As String translatedText = Translate(Me.Drive_Nat.Value, "ar", "en") ' هذه هو مربع التحرير الخاص بك Drive_Nat ' تحديث حقل الجنسيات الإنجليزية NASH If Not IsNull(translatedText) And translatedText <> "" Then ' NASH وهذا مربع التحرير الخاص بالجنسية العربية اذا كان لديك Me.NASH.Value = translatedText Else MsgBox "تعذر الترجمة. يرجى المحاولة مرة أخرى.", vbExclamation, "خطأ في الترجمة" End If ' وهذا حقل الجنسية العربيه بحيث ييم الترجمة فيه ' تحديث الحقل NAOINALTYEN بناءً على الترجمة If Not IsNull(Me.NASH.Value) And Me.NASH.Value <> "" Then Me.NAOINALTYEN.Value = Me.NASH.Value End If ' استدعاء الكود الخاص بتحديث الصور Call NASH_AfterUpdate End Sub قبل ذلك تضع هذا الكود في وحدة نمطية واحفظها Option Compare Database Option Explicit Public Function Translate(strInput As String, strFromSourceLanguage As String, strToTargetLanguage As String) As String Dim strURL As String Dim objHTTP As Object Dim objHTML As Object Dim objDivs As Object, objDiv As Object Dim strTranslated As String strURL = "https://translate.google.com/m?sl=" & strFromSourceLanguage & "&tl=" & strToTargetLanguage & "&q=" & EncodeQP2(strInput) & "&hl=ar" Set objHTML = Nothing Set objHTTP = CreateObject("Msxml2.XMLHTTP.6.0") objHTTP.Open "GET", strURL, False objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)" objHTTP.SEND "" Set objHTML = CreateObject("htmlfile") With objHTML .Open .Write objHTTP.responseText .Close End With Set objDivs = objHTML.getElementsByTagName("div") For Each objDiv In objDivs If objDiv.className = "result-container" Then strTranslated = objDiv.innerText Translate = strTranslated End If Next objDiv End Function Function EncodeQP2(s As String) As String Dim i As Long Dim p1 As Long Dim p2 As Long Dim R As String Dim n As Long For i = 1 To Len(s) n = AscW(MID(s, i, 1)) If n < 128 Then R = R & "%" & Hex(n) ElseIf n < 2048 Then p1 = n \ 64 R = R & "%" & Hex(p1 + 192) p2 = n Mod 64 R = R & "%" & Hex(p2 + 128) Else End If Next i EncodeQP2 = R End Function

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

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

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

ممكن

اريد تعديل على الكود بحيث اذا اخترت من القائمة 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