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

السلام عليكم ورحمة الله وبركاته هذه دعوة كريمة لتجربة الأداة الجديدة والفريدة من نوعها : دكتور ال VBA وضائف الأداة : 1- تحويل الكود إلى صيغة متوافقة مع النواتين 32 و 64 بت. 2- تصحيح الأخطاء البرمجية في الكود. 3- تنسيق وترتيب الكود شكليا. 4- كتابة التعليقات وشرح للكود باللغتين العربية والإنجليزية. 5- إضافة صائد الأخطاء للكود وذلك لتعقب الأخطاء البرمجية. 6- إضافة ترقيم لأسطر الكود. يمكنك اختيار واحد من هذه الوظائف أو تختار من بينها ما تريده. الأداة مخصصة لأكواد ال VBA وتعتمد على قدرات الذكاء الاصطناعي لإعطاء نتائج دقيقة ومبهرة .. 😁✌🏻 اختصر على نفسك الوقت والجهد واعمل بذكاء 😉👌🏻 رابط الأداة : https://vba-code-doctor-471932697586.us-west1.run.app/ يمكنك فتحها في الهاتف أو الحاسوب على راحتك 😎🌷 جربوها وعطوني رأيكم 😇✌🏻

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

وعليكم السلام ورحمة الله وبركاته الى جانب الحلول التي ارفقها استاذنا الفاضل hegazee اليك حل اخر بالكود في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) Dim rngF As Range, rngG As Range Dim rngB As Range, rngC As Range Dim pos As Variant Set rngF = Me.Range("F2") ' Set rngG = Me.Range("G2") Set rngB = Me.Range("B2:B1000") Set rngC = Me.Range("C2:C1000") If Not Intersect(Target, rngF) Is Nothing Then Application.EnableEvents = False pos = Application.Match(rngF.Value, rngB, 0) If Not IsError(pos) Then rngG.Value = Application.Index(rngC, pos) Else rngG.Value = "" End If Application.EnableEvents = True End If rngG.Select End Sub data.xlsb

بعد إذن مهندسنا الغالي .. إذا كان ملفك بصيغة Accde فلن تصل للأكواد أبداً .

لا عليك أخي عبداللطيف ، المهم ان المشكلة تم حلها .

تفضل التعديل التالي .. جربه وأخبرني بالنتيجة . 123452025.zip

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

رداً على هذه النقطة ، وحيث أنه سبق تنفيذها سابقاً .. جرب المرفق نفسه بعد التعديل بحيث سيتم فقط عرض الخطوط العربية ( أو التي تتعامل مع الكاركتر العربي ) في الكومبوبوكس . مع إضافة الفرز التصاعدي للأسماء :- Db3.zip

وانا عند وعدى هذه مشاركتى 1- بعد فك الضغط انقل الصور الى المجلد : TempResources 2- قم بفتح قاعدة البيانات 3- فى المستقبل فقط اضف اى صور الى المجلد : TempResources فى جزء لم انته منه بعد حفظ الاعدادت كقوالب او حفظ الاعدادت لكل شهادة ان اردنا ان تكون كقاعدة بيانات للاحتفاظ بالبيانت وليس مجرد موديولر لعمل الشهادات ويتبقى الجزء الاخير انا افكر فى الطباعة من النموذج الفرعى بشكل مباشر بدون اى تقارير الى لقاء قريب بعد ان اعرف ارائكم فى التطبيق والافكار البسيطة المتواضعة

فكرتي المتواضعة .. dbs2.zip

بل اعجبني المشهد .. سلمت اناملك يا سلام .. زاد حماسي .. احب المفاجآت في مثل هذه المواضيع

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

فضلت ابحث فى المنتدى عن موضوع صفحة رئيسية لاستاذ ابو جودي الى ان وجدت الموضوع طيب المرفق الاول على طريقة ابو جودي والمرفق الثانى من هذا الموضوع والذى يخص الاستاذ Foksh قمت بتعديل بسيط واضافة بسيطة جدا قائمة جانبية على طريقة ابو جودى.zip قائمة جانبية على طريقة الاستاذ Foksh.zip

الملف بعد تحويله لـــ 2003 دون الدخول بأي شئ فقط التحويل . UnMatched.mdb

و عليكم السلام ورحمة الله و بركاته https://www.officena.net/ib/topic/64613-أبغي-قائمة-منسدلة-مرتبطة-بقائمة-منسدلة-أخري-فى-نفس-ورقة-العمل/

مشاركة مع تنفيذ فكرة أستاذنا @kkhalifa1960 ، وبدلاً من الإعتماد على نموذج فرعي للقائمة الفرعية ، هذا تعديل على الفكرة التي تم طرحها سابقاً ، بحيث تم تطبيقها وكأنها Navigation Form .. الملف المرفق :- Menu Navigations.zip

وعليكم السلام اهلا بك استاذي القدير @ابوخليل في حالة المرفق داخل قاعدة البيانات ..... دائما التعامل يكون بحيلة سواءا لفتح المرفق او عرض المرفق مباشرة .... والحيله هي تصدير المرفق ثم التعامل معه .... في مثالك مثلا والطلب بفتح المرفق مباشرة .... الكود يقوم اولا بتصديره ثم فتحه .... جرب هذا الكود لاني لم افتح القاعدة التي لديك Private Sub cmdOpenAttachment_Click() Dim rs As DAO.Recordset2 Dim rsA As DAO.Recordset2 Dim fld As DAO.Field2 Dim tmpPath As String Dim fileName As String 'افتح السجل الحالي Set rs = Me.Recordset 'اسم الحقل الذي يحتوي على المرفق Set fld = rs.Fields("MyAttachmentField") '← غيّر الاسم حسب جدولك If fld.Value Is Nothing Then MsgBox "لا يوجد مرفق لفتحه.", vbExclamation Exit Sub End If 'افتح المرفق داخل الحقل Set rsA = fld.Value If rsA.RecordCount = 0 Then MsgBox "لا يوجد مرفق.", vbExclamation Exit Sub End If rsA.MoveFirst 'الاسم الأصلي للمرفق fileName = rsA.Fields("FileName").Value 'حدد مسار مجلد مؤقت tmpPath = Environ("TEMP") & "\" & fileName 'احفظ المرفق كملف مؤقت rsA.Fields("FileData").SaveToFile tmpPath 'افتح الملف بالبرنامج الافتراضي FollowHyperlink tmpPath End Sub

هذه الصور تبين النتيجة تصميم ثم عرض .. العرض يتم لجميع الطلاب

تفضل Sub ToggleColumns() Dim action As String Dim colsInput As String Dim colArray() As String Dim colItem As Variant Dim answer As VbMsgBoxResult Dim invalidInput As Boolean ' مربع حوار لتحديد الإجراء (إخفاء أو إظهار) answer = MsgBox("هل تريد إخفاء الأعمدة؟" & vbCrLf & vbCrLf & "اضغط 'Yes' للإخفاء، 'No' للإظهار.", vbYesNoCancel + vbQuestion, "تحديد الإجراء") If answer = vbCancel Then Exit Sub ' الخروج إذا ضغط المستخدم على "Cancel" ElseIf answer = vbYes Then action = "إخفاء" Else action = "إظهار" End If ' مربع إدخال لطلب الأعمدة من المستخدم colsInput = InputBox("الرجاء إدخال الأعمدة التي تريد " & action & "ها." & vbCrLf & vbCrLf & "أمثلة:" & vbCrLf & "عمود واحد: B" & vbCrLf & "أعمدة متجاورة: B:D" & vbCrLf & "أعمدة متفرقة: B,D,F", "تحديد الأعمدة") ' الخروج إذا كان الإدخال فارغًا If colsInput = "" Then Exit Sub ' إزالة أي مسافات زائدة وتقسيم الإدخال عند الفاصلة colArray = Split(Replace(colsInput, " ", ""), ",") invalidInput = False On Error Resume Next ' تجاهل الأخطاء مؤقتًا للتحقق من صحة الإدخال ' المرور على كل عنصر أدخله المستخدم For Each colItem In colArray If colItem <> "" Then ' التحقق من أن كل جزء من الإدخال يمثل نطاقًا صالحًا If Columns(colItem).Count = 0 Then invalidInput = True Exit For End If End If Next colItem On Error GoTo 0 ' إعادة تفعيل معالجة الأخطاء ' إذا كان هناك إدخال غير صالح، أظهر رسالة خطأ If invalidInput Then MsgBox "الإدخال '" & colItem & "' غير صالح. الرجاء التأكد من إدخال أسماء أعمدة صحيحة.", vbCritical, "خطأ في الإدخال" Exit Sub End If ' تنفيذ الإجراء على كل عمود أو نطاق For Each colItem In colArray If colItem <> "" Then If action = "إخفاء" Then Columns(colItem).Hidden = True Else Columns(colItem).Hidden = False End If End If Next colItem MsgBox "تم " & action & " الأعمدة بنجاح!", vbInformation, "اكتمل الإجراء" End Sub

الكود في مشاركتي الاخيرة وافي وكافي ... فقط تضاف هذه الجملة عند اغلاق البرنامج لمن اراد حذف الملف FilePath = CurrentProject.Path & "\" & "soccer.png" Result = Dir(FilePath) If Result <> "" Then Kill FilePath End if وهذا يعني انك لم تفهم عني ما اريد راجع نقاشي مع اخونا فادي

تفضل أخي الكريم / ملفك بعد التعديل وتوسيع النطاق في العمل . وأرجو منك الإهتمام بمواضيعك وأغلاق ما يستحق الإغلاق إشعاراً للقارئ بأن الموضوع قد تم حله والإجابة عليه . فتفاعلك يعكس فكرك . UnMatched123.zip

مهو علشان أعرف أفكر وانا بفطر، شجعنا بالهدف المنشود لنحدد الوسيلة التي سنسير بها 😉 . على العموم ، بالنسبة للمطلوب الأول هذه وجهة نظري بالتعديل :- Function RelinkIsIco() As String Dim rs As DAO.Recordset Dim rst As DAO.Recordset2 Dim strFilePath As String Set rs = CurrentDb.OpenRecordset("SELECT progIcon FROM tblEnDc") If Not rs.EOF Then Set rst = rs.Fields("progIcon").Value If Not rst.EOF Then strFilePath = CurrentProject.Path & "\" & rst.Fields("FileName").Value If Dir(strFilePath) <> "" Then Kill strFilePath rst.Fields("FileData").SaveToFile strFilePath RelinkIsIco = strFilePath End If rst.Close: Set rst = Nothing End If rs.Close: Set rs = Nothing End Function مطلوب المسار الوهمي بعتمد تنفيذ فكرته على ماهية حاجتك له وغايتك وهدفك منه .

صباح الفل اخي فادي الغاية هي الوصول الى الهدف لا تتهرب .. سوف امهلك الى ما بعد الافطار

السلام عليكم ورحمة الله تم تصحيح كود الشيت "كشف" وهو يعمل جيدا (بطيء بعض الشيء)، أما بالنسبة لكود الشيت "تجميع" وكود الطباعة فتمت الاستعانة بالذكاء الاصطناعي بتصرف من طرفي لموافقة الكود مع ملفك... أرجو أن يفي الغرض المطلوب... كل هذه التعديلات تجدها في الملف المرفق... سرى ملاحظة.xlsm

استاذنا الخبير المتألق @Foksh اشكرك كل الشكر ,, وسع الله رزقك وزادك علما وكفاك شرور الناس

اعتذر عن التأخير .. تفضل هذا الملف المرفق ، حيث يحتوي الدالة البسيطة :- Public Sub SetTableHiddenState(ByVal strTableName As String, ByVal hide As Boolean) On Error GoTo ErrHandler Dim db As DAO.Database Dim tdf As DAO.TableDef Set db = CurrentDb db.TableDefs.Refresh Dim t As DAO.TableDef Dim found As Boolean: found = False For Each t In db.TableDefs If t.Name = strTableName Then found = True Exit For End If Next t If Not found Then MsgBox "حدثت مشكلة أثناء تأمين المكونات", vbExclamation + vbMsgBoxRight, "" Exit Sub End If Set tdf = db.TableDefs(strTableName) If hide = True Then tdf.Attributes = tdf.Attributes Or dbSystemObject Or dbHiddenObject Else tdf.Attributes = tdf.Attributes And Not (dbSystemObject Or dbHiddenObject) End If Application.RefreshDatabaseWindow Exit Sub ErrHandler: MsgBox "حدث خطأ أثناء تأمين مكونات البرنامج" & Err.Description, vbCritical + vbMsgBoxRight, "خطأ" End Sub * الدالة جزء من مشروع سابق . الملف المرفق :- Hide TBL.accdb

وعليكم السلام ورحمة الله وبركاته .. استخدم في حدث في الحالي الكود التالي :- If Me.NewRecord Then Me.AllowAdditions = True Me.AllowEdits = True Me.AllowDeletions = True Else Me.AllowEdits = False Me.AllowDeletions = False End If وفي حدث بعد الإضافة للنموذج الحدث التالي :- Private Sub Form_AfterInsert() Me.AllowEdits = False Me.AllowDeletions = False End Sub ملفك بعد التطبيق :- 123452025.zip

الفا مليون شكر الاساتذة الكرام

افتح موضوع جديد ، وارفق ملفك وإن شاء الله تجد حل لمشكلتك .

ما شاء الله تبارك الرحمن 🙂 جميل جدا تنوع الأفكار في نفس المجال 😊👌 وأنا أيضا لدي برنامج خاص بتصميم الشهادات وتنسيقها وتوليد الشهادات لمجموعة كبيرة من الطلاب أو المتدربين أو المستلمين بشكل عام ، وكذلك يقوم بإرسال الشهادات بالبريد الإلكتروني لكل المستهدفين ( كل متدرب أو طالب يستلم شهادته) ، وأيضا يقوم بحفظ جميع الشهادات على شكل Pdf دفعة واحدة .. 🙂 مع إمكانيات تنسيق النص ( الخطوط والألوان ) بشكل حر ، وإضافة التواقيع ، وتغيير إطارات البرنامج .. إلخ تصميم وتنسيق النصوص بكل أريحية إضافة المتدربين دفعة واحدة بعدد لا محدود معاينة بشكل مباشر اواجهة البرنامج مع خيارات البحث وعرض تقارير وإحصائيات لتحميل البرنامج : تنصيب برنامج صانع الشهادات الإصدار الثالث 3.0.zip

أفتح البرنامج عن طريق الضغط على زر الشفت Shift لكي تصل إلى الأكواد .. وبعدها قم بتحويل الأكواد وأعد تشغيل البرنامج 🙂

نعم .. تماما السر في هذه الدالة التي حلت المشكلة الدالة تتحدث وليست بحاجة الى شرح .. حيث تفحص الوقت الحالي هل هو في مساء اليوم ام لا Dim startTime As Date Dim endTime As Date Dim currentTime As Date Dim i As Integer startTime = TimeValue("12:01:00") endTime = TimeValue("23:59:59") currentTime = Time() If currentTime > startTime And currentTime < endTime Then i = 1 Else i = 2 End If CheckTimeBetween = i وكان السبب الرئيس في المشكلة هو دالة توقيت المساء سواء الحضور او الانصراف لأنه عند دخول اليوم التالي يعتبر الدخول المسائي ضمن مساء الغد لهذا تم تعديل دالتي التوقيت المسائي وفقا لهذه الدالة اعلاه انظروا كيف تتعامل الدالتان ادناه الشرط يقول : اذا الوقت الحالي داخل في شرط الدالة وصحيح .. اي =1 فالتاريخ تاريخ اليوم وإلا فإن التاريخ هو تاريخ الأمس Public Function funFirstTimeB_in() Dim z As Integer Dim i As Date, ii As Date, jj As Date z = Nz(DLookup("free2_in", "tblTimeCtrl"), 0) If CheckTimeBetween() = 1 Then i = DLookup("fatrah2_In", "tblTimeCtrl") & " " & Date ii = DateAdd("n", -z, i) Else jj = DateAdd("d", -1, Date) i = DLookup("fatrah2_In", "tblTimeCtrl") & " " & jj ii = DateAdd("n", -z, i) End If funFirstTimeB_in = ii End Function Public Function funLastTimeB_Out() Dim z As Integer Dim x As Integer, xx As Integer Dim i As Date, ii As Date, jj As Date z = Nz(DLookup("free2_out", "tblTimeCtrl"), 0) x = Nz(DLookup("hours_Work2", "tblTimeCtrl"), 0) xx = (x * 60) + z If CheckTimeBetween() = 1 Then i = DLookup("fatrah2_In", "tblTimeCtrl") & " " & Date ii = DateAdd("n", xx, i) Else jj = DateAdd("d", -1, Date) i = DLookup("fatrah2_In", "tblTimeCtrl") & " " & jj ii = DateAdd("n", xx, i) End If funLastTimeB_Out = ii End Function للتجربة والتأكد ان كل شيء تمام جعلت عند التوقيع في الفترتين كليهما .. تظهر رسالتان الاولى لبداية التوقيع والثانية لنهايته اذا الامور تمام يمكنك تعطيل وايقاف هذه الرسائل بداية التوقيع = وقت الدخول الرسمي - الوقت المتاح قبل نهاية التوقيع = وقت الدخول الرسمي + عدد ساعات العمل + الوقت المتاح بعد جعلت الاوقات المتاحة بالدقائق من اجل دقة الاختيار

هذه تفيد بأن أحد المكتبات ناقصة أو مفقودة أو احد الاكواد يعمل عل 32 بت وانت نقلتها على جهاز يعمل على 64 بت . وللاسف انا كما قلت لك انا حولت الملف فقط والباقي عند الاستاذ @Foksh . هو صاحب الموضوع .................... تحياتي لك .

وسعة المرفق تصحيح بسيط في تكبير حجم نموذج واضافة 3 انماط تفاعلية في الامكان التوسع التفريع بنفس المرفق انسخ النموذج لاي نمط تحت الزر مع تعريف الحجم اعلى النموذج السابق للتوسيع النموذج سيضم تفريع 3 و4 وتكرار لتشعب التفريعات في الزر مثال الى 9 و10 في زر واحد من قائمة الجانبية فكرة بسيطة واذا حاب نغير وتحدد الالوان مع تنزيل ايكون في خلفية الزر بدل من حفظ الصور في الجدول واستعمال الصور من ملفات خارجية ومن غير تحديث استعلام ولا وميض ولا ترميش 😇 اشرايك استاذ @Foksh عندك كود لتبسيط التفريعات في الزر مرفق اسفل الفيديو تحميل المرفق https://www.mediafire.com/file/jrahtllbz0xmgdj/Menu+Navigations_V1.rar/file

نعم هذا هو المفترض في جميع الانظمة المتعارف عليها .. التوقيع الأول = حضور سواء جاء اول الوقت او آخره الأصل ان البرنامج يجب ان يعرفهم واحدا واحدا ، ويعرف اوقاتهم المتاح لهم التوقيع فيها . انا صنعت ذلك باحكام .. ولكن طلب الاخ محمد فيما لو تجاوز الوقت اليوم الحالي الى ما بعد منتصف الليل ودخول يوم جديد هنا المعيار الاساسي يكون حجر عثرة ويجب ازالته والبحث عن بديل .. وهنا جاءت الثغرات ...................... بعد كل المحاولات اتضح لي انه من اجل الضبط المحكم ( ما يخرش المية ) يجب اضافة فترة جديدة تخص اليوم التالي هنا يصبح لدينا ثلاث فترات على الأقل .. ويمكن زيادة عدد الفترات عن 3 لمن اراد .. وكل ذلك خلال 24 ساعة تبدأ من الساعة 12:01 صباحا وتنتهي في 11:59 مساء .. حسب تقسيم كل فترة بداية/نهاية ان وافقني على هذا المقترح سوف اقوم باعداده سواء على طريقة تصميم حقلين في الجدول حضور/انصراف //// او طريقة الحقل الواحد والمعرف

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

ليس بالضرورة ان تكون هناك طابعة موصولة !! فالطابعة الإفتراضية في ويندوز لها أيضاً تعريف 😉 .

السلام عليكم تم تعديل المعادلات حسب ما تريد (حسب فهمي) في الملف المرفق... مخصصات.xlsx

بالفعل مثل ما تفضل الاستاذ : Foksh المشكلة دي مش من Access نفسه قد ما هي من تعريف الطابعة + إعدادات الصفحة المختلفين بين الجهازين وخصوصا مع الهوامش 0 وصورة كاملة صفحة ليه التصميم بيخرب بين الجهازين؟ كل تقرير في Access بيتضبط على خصائص الطابعة الافتراضية وقت التصميم لذلك أي اختلاف في تعريف الطابعة أو نوع الورق/الهوامش يخلي التقرير يعيد حساب المقاسات وتمركز الصورة والكنترولز أغلب تعريفات الطابعات أصلا لا تسمح بهوامش 0 حقيقية فتجبر هامش أدنى (مثلا 3–5 مم من كل جانب) وده اللي يخلي الصورة تتصغر أو تتزحزح ويظهر كأن فيه هوامش رغم إنها 0 في التقرير على ويندوز 7 غالبا تعريف الطابعة مختلف أو إعدادات الـ Page Setup غير اللي على ويندوز 10 ماذا تفعل على كل جهاز افتح التقرير في معاينة قبل الطباعةثم اختر إعداد الصفحة Page Setup تأكد أن: حجم الورقة A4 الهوامش Manual وليست إعدادات خاصة بالطابعة (لو 0 عمل مشاكل استخدم 0.25 سم مثلا واضبط حجم الصورة بحيث تملأ المساحة داخل الهامش) ثبت نفس تعريف الطابعة ونفس الإعداد كـ Default على الجهازين قدر الإمكان Access يعتمد على تعريف الطابعة في حساب عرض وارتفاع التقرير لو حابب يمكن ضبط التقرير بحيث: حجم التقرير نفسه يساوي A4 ناقص أقل هامش تدعمه الطابعة (مثلا عرض 19.7 سم بدل 21 سم) والصورة تمتد داخل هذا المقاس كده هتاخد شكل فول بليد تقريبا على كل الأجهزة بدون ما يتلخبط التخطيط

عجيب .. عجيب يبدو انك عدلت على شيء ما اعدت التجربة .. والنتيجة كانت مذهلة التعديلات التي اجراها : تنظيم الكود .. بحيث جعل جميع الاعلانات عن المتغيرات في الأعلى بدل شرط الحقل النصي في الدوال بالمتغير وكذلك في جملة sql استبدل الدالة بالمتغير .. عفريت برمجي اضاف لي متغير اسم الموظف غفلت عن نقله من العمل السابق ... هذه الاضافة لا تخطر على بال المحترفين الا بعد عناء اغلاق السجلات عند نهاية كل شرط .. الحقيقة هذه الحركة تحفة هذه صورة من الخيارات التي استخدمتها : وهذا الكود الاصلي : Private Sub id_AfterUpdate() EmpUserid = id Dim mylevl As Boolean mylevl = Nz(DLookup("Emp_user", "tblEmpNames", "Emp_user='" & Me.id & "'"), 0) EmpFatrah = Nz(DLookup("fatrah", "tblEmpNames", "Emp_user='" & Me.id & "'"), 0) If mylevl = False Then Beep Me.LabelH.Caption = "خطأ!! .. الادخال غير صحيح" Me.TimerInterval = 3000 id = "" id.SetFocus Exit Sub End If Dim rs As Recordset Dim strSql As String strSql = "SELECT TOP 1 tblCheckINOut.id, tblCheckINOut.EmpUser, tblCheckINOut.chekInOut, tblCheckINOut.chkio, tblCheckINOut.ftra_id " & vbCrLf & _ "FROM tblCheckINOut " & vbCrLf & _ "WHERE (((tblCheckINOut.EmpUser)=funEmpUserid())) " & vbCrLf & _ "ORDER BY tblCheckINOut.id DESC;" Set rs = CurrentDb.OpenRecordset(strSql) If rs.RecordCount = 0 Then rs.AddNew rs!EmpUser = id rs!chekInOut = Now() rs!chkio = "I" rs!ftra_id = EmpFatrah Me.txtnm = empName LabelH.Caption = "حضور" Me.Requery Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus rs.Update Exit Sub End If Dim waitTime As Integer Dim AdTim As Date waitTime = Nz(DLookup("waitBtween", "tblTimeCtrl"), 0) AdTim = DateAdd("n", waitTime, rs!chekInOut) If Now() < AdTim Then Me.id.SetFocus Beep Me.LabelH.Caption = "توقيع مكرر !! انتظر قليلا ..." id = "" Me.TimerInterval = 3000 id.SetFocus Exit Sub Else If rs!chkio = "I" Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "O" rs!ftra_id = EmpFatrah Me.txtnm = empName LabelH.Caption = "انصراف" Me.Requery Me.id = "" Me.TimerInterval = 3000 Me.id.SetFocus rs.Update Exit Sub ElseIf rs!chkio = "O" Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "I" rs!ftra_id = EmpFatrah Me.txtnm = empName LabelH.Caption = "حضور" Me.Requery Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus rs.Update Exit Sub End If End If End Sub وهذه هي النتيجة الرائعة : Private Sub id_AfterUpdate() Dim EmpUserid As Variant Dim mylevl As Boolean Dim EmpFatrah As Variant Dim rs As DAO.Recordset Dim strSql As String Dim waitTime As Integer Dim AdTim As Date Dim empName As String ' Declare empName EmpUserid = Me.id ' Corrected logic for mylevl to check for user existence mylevl = Not IsNull(DLookup("Emp_user", "tblEmpNames", "Emp_user='" & EmpUserid & "'")) EmpFatrah = Nz(DLookup("fatrah", "tblEmpNames", "Emp_user='" & EmpUserid & "'"), 0) If mylevl = False Then Beep Me.LabelH.Caption = "خطأ!! .. الادخال غير صحيح" Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus Exit Sub End If ' Lookup empName once after confirming user existence empName = Nz(DLookup("Emp_Name", "tblEmpNames", "Emp_user='" & EmpUserid & "'"), "") strSql = "SELECT TOP 1 tblCheckINOut.id, tblCheckINOut.EmpUser, tblCheckINOut.chekInOut, tblCheckINOut.chkio, tblCheckINOut.ftra_id " & vbCrLf & _ "FROM tblCheckINOut " & vbCrLf & _ "WHERE (((tblCheckINOut.EmpUser)='" & EmpUserid & "')) " & vbCrLf & _ "ORDER BY tblCheckINOut.id DESC;" Set rs = CurrentDb.OpenRecordset(strSql) If rs.RecordCount = 0 Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "I" rs!ftra_id = EmpFatrah Me.txtnm = empName Me.LabelH.Caption = "حضور" Me.Requery Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus rs.Update rs.Close Set rs = Nothing Exit Sub End If waitTime = Nz(DLookup("waitBtween", "tblTimeCtrl"), 0) AdTim = DateAdd("n", waitTime, rs!chekInOut) If Now() < AdTim Then Me.id.SetFocus Beep Me.LabelH.Caption = "توقيع مكرر !! انتظر قليلا ..." Me.id = "" Me.TimerInterval = 3000 Me.id.SetFocus rs.Close Set rs = Nothing Exit Sub Else If rs!chkio = "I" Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "O" rs!ftra_id = EmpFatrah Me.txtnm = empName Me.LabelH.Caption = "انصراف" Me.Requery Me.id = "" Me.TimerInterval = 3000 Me.id.SetFocus rs.Update rs.Close Set rs = Nothing Exit Sub ElseIf rs!chkio = "O" Then rs.AddNew rs!EmpUser = EmpUserid rs!chekInOut = Now() rs!chkio = "I" rs!ftra_id = EmpFatrah Me.txtnm = empName Me.LabelH.Caption = "حضور" Me.Requery Me.TimerInterval = 3000 Me.id = "" Me.id.SetFocus rs.Update rs.Close Set rs = Nothing Exit Sub End If End If End Sub صحيح هو اضاف لي هذا المتغير : Dim EmpUserid As Variant ولكن هذا المتغير تم الاعلان عنه في الوحدة النمطية كمتغير عام وانا لا الومه لانه لا يعلم وليس له الا الظاهر ☺️

اعرض الملف دليل شجرة حسابات لنشاط صناعي دليل شجرة حسابات لنشاط صناعي - حسب داتا ونظام برنامج سماك 6 صاحب الملف salahmosaed تمت الاضافه 29 نوف, 2022 الاقسام قسم الإكسيل  

ممتاز

انا طريقتي تختلف عن الاخوان حيث قمت بإظهار الجدول نفسه كما بالصورة وللقيام بذلك قم بتنفيذ الخطوات كالتالي 1- إنسخ الملف تحت القرص D مباشرة (يمكن نسخه إلى أي مكان ولكن هكذا سيكون المسار قصير) 2- إفتح الملف وقم بإنشاء الاستعلام التالي (هذه الخطوة غير مهمة لكم لإني سبق واستخرجت قيمة العمود المطلوب ووضعتها في الكود ولكني ذكرتها للتعرف على الخطوات) SELECT MSysObjects.Flags, MSysObjects.Name, MSysObjects.Type FROM MSysObjects WHERE ( ((MSysObjects.Name) NOT LIKE "MSys*") AND ((MSysObjects.Type) = 1) ); من خلال هذا الاستعلام سنتعرف على أي جدول Type=1 ولايبدأ بالأحرف MSys لتظهر لنا النتيجة كما بالصورة مايهمنا هنا هي قيمة العمود الأول Flags بعد ذلك قم بإغلاق التطبيق بدون حفظ اي شيء 3- إفتح أي قاعدة بيانات أخرى (سواء قاعدة بيانات فارغة أو مستخدمة لايهم) وفي أي وحدة نمطية (جديدة أو فيها اكواد لايهم) والصق فيها الإجراء التالي Sub sbUnHideTables() Dim app As Access.Application Dim wks As Workspace Dim db As dao.Database Dim rst As dao.Recordset Dim tdf As TableDef Set app = New Access.Application Set wks = app.DBEngine(0) 'الإصدار 64 Set db = wks.OpenDatabase("D:\HideTBL V1-64.accde") 'مسار الملف 'الإصدار 32 'Set db = wks.OpenDatabase("D:\HideTBL V1-32.accde") 'مسار الملف For Each tdf In db.TableDefs If tdf.Attributes = -2147483645 Then tdf.Attributes = 0 'تغيير قيمة العمود Flags Next tdf Set db = Nothing End Sub 4- انقر الزر F5 لتشغيل الإجراء حيث سيقوم بتغيير قيمة العمود Flags إلى القيمة صفر 5- اغلق قاعدة البيانات التي قمنا بتنفيذ الكود فيها (حفظ الكود من عدمه راجع لك) 6- الان إذهب إلى القرص D وقم بفتح الملف (HideTBL V1-64.accde او HideTBL V1-32.accde وفقاً لإصدار أوفيس لديك) لتجد أن الجدول قد ظهر في جزء التنقل تحياتي

مرفق لك المثال بعد استخدام ماكرو البيانات جرب تعديل حقلSlabs الي في جدول Receiving_Bundle وشاهد كيف ستتغير قيمة الحقل Slabs_in_Bundle في جدول SAW حيث يقوم ماكرو البيانات بما يشبه الـ Trigger في انظمة قواعد البيانات الكبيرة مثل Sql Server و Oracle وغيرها ولكن المشكلة الوحيدة هي ان هذا النوع من الماكرو لن يعمل الا مع اكسس 2010 ومابعده (صراحة غير متأكد من انه يعمل مع اكسس 2007) والاكيد انه لن يعمل مع ماقبل 2007 تحياتي Database.accdb

تفضل استاذ @RAIANESAMI طلبك حسب ما فهمت بالمرفق . ووافني بالرد . DDFinding Differences.rar

بارك الله فيك وزادك الله من فضله كلها اعمال رائعة

وعليكم السلام-تفضل لك ما طلبت بهذه المعادلة =IFERROR(DGET($B$4:$G$12,B4,$C$17:$D$18),"") صفحة 1.xlsx

أحسنت استاذ مجدى عمل رائع بارك الله فيك

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

وعليكم السلام-يمكنك تجربة هذا كيف اجعل صفحة اكسل تتحول لصفحة نت تفاعلية في موقعي وهنا ايضا كيفية ربط جداول ومخططات إكسل ببرنامج بوربوينت كيف تربط جداول ومخططات إكسل ببرنامج بوربوينت