أحمد العيسى

تمام شكراً لك .. بارك الله فيك قبل سؤالى استخدمت صفحة vba-code-doctor فأنتج هذا الكود .. لكن به رسالة خطأ أين المشكلة ... هل المطلوب مكتبات معينة ، مع العلم أن الكود ليس به تحذير فى الــ Compile Private Sub cm_ToExcel_Click() On Error GoTo Err_cm_ToExcel_Click Dim stDocName As String Dim Q As Integer Dim fDialog As Office.FileDialog ' يتطلب مرجعًا إلى مكتبة كائنات Microsoft Office XX.0 Dim strFilePath As String stDocName = "tbl_Teacher" & [Year_name] Q = DCount("*", "tbl_Teacher") If Q > 0 Then ' تهيئة مربع حوار الملف Set fDialog = Application.FileDialog(msoFileDialogSaveAs) With fDialog .AllowMultiSelect = False .Title = "اختر مكان حفظ ملف أكسل" .InitialFileName = stDocName & ".xls" .Filters.Clear .Filters.Add "Excel Workbooks", "*.xls", 1 ' تصفية لملفات .xls .FilterIndex = 1 ' تحديد الفلتر الأول افتراضيًا If .Show = True Then ' المستخدم ضغط على حفظ strFilePath = .SelectedItems(1) ' التأكد من أن الملف له امتداد .xls If Right(strFilePath, 4) <> ".xls" Then ' التحقق مما إذا كان هناك امتداد موجود لاستبداله If InStr(strFilePath, ".") > InStrRev(strFilePath, "\") Then strFilePath = Left(strFilePath, InStrRev(strFilePath, ".") - 1) & ".xls" Else strFilePath = strFilePath & ".xls" End If End If DoCmd.TransferSpreadsheet acExport, 8, "tbl_Teacher", strFilePath, False MsgBox ("تم استخراج ملف أكسل لبيانات الموظفيـن وحفظه على الـ " & Chr(13) & Chr(13) & strFilePath), vbOKOnly + vbMsgBoxRight, "تنبيه" Else ' المستخدم ضغط على إلغاء MsgBox "تم إلغاء عملية الحفظ.", vbOKOnly + vbMsgBoxRight, "إلغاء" End If End With Else MsgBox ("لا يوجد سجلات لتصديرها "), vbOKOnly + vbMsgBoxRight, "تنبيه" End If Exit_cm_ToExcel_Click: Set fDialog = Nothing ' تنظيف كائن مربع حوار الملف Exit Sub Err_cm_ToExcel_Click: MsgBox Err.Description Resume Exit_cm_ToExcel_Click End Sub

السلام عليكم فيما يلى إجراء يقوم بحفظ قاعدة بيانات فى صورة ملف أكسل 2003 على القطاع E والمطلوب إظهار مربع حوار أكسس ليتيح لى حرية اختيار المكان على الهارد قبل الحفظ على أن يكون المكان الافتراضى E فى حالة سماح تقسيم الهارد بذلك مع جزيل شكرى مقدماً Private Sub cm_ToExcel_Click() On Error GoTo Err_cm_ToExcel_Click Dim stDocName As String Dim Q As Integer stDocName = "tbl_Teacher" & [Year_name] Q = DCount("*", "tbl_Teacher") If Q > 0 Then DoCmd.TransferSpreadsheet acExport, 8, "tbl_Teacher", "E:\" & stDocName & ".xls", False MsgBox (" E:\ تم استخراج ملف أكسل لبيانات الموظفيـن وحفظه على الـ " & Chr(13) & Chr(13) & stDocName & ".xls"), vbOKOnly + vbMsgBoxRight, "تنبيه" Else MsgBox ("لا يوجد سجلات لتصديرها "), vbOKOnly + vbMsgBoxRight, "تنبيه" End If Exit_cm_ToExcel_Click: Exit Sub Err_cm_ToExcel_Click: MsgBox Err.Description Resume Exit_cm_ToExcel_Click End Sub

تمام .. كل الشكر لكما وهذا ما تم تنقيحه ليكون نهائياً ' طباعة المحدد Private Sub cmdPrint_Click() On Error GoTo Err_cmdPrint_Click Dim Index3 As Variant Dim repName As String ' فحص إذا كان هناك بند تم تحديده If L3.ItemsSelected.Count = 0 Then MsgBox "لا يوجد مطبوعات قد تم اختيارها", vbInformation + vbMsgBoxRight, "تنبيه " Exit Sub End If ' المرور على كل عنصر محدد وفتح التقرير المقابل له For Each Index3 In L3.ItemsSelected repName = L3.ItemData(Index3) repName = "تقرير_" & repName DoCmd.OpenReport repName, acViewNormal, , ftrName Next Index3 Exit_cmdPrint_Click: Exit Sub Err_cmdPrint_Click: MsgBox Err.Description Resume Exit_cmdPrint_Click End Sub أما عن هذا السطر Private ftrName As String فقد تم التصريح به فى بداية VBA سؤالى هنا : ما هو ftrName هل هو أمر محجوز للطباعة

السلام عليكم الكود التالى يعمل بدون مشاكل ولكن هناك سطور مكررة متداخلة به طلبى من السادة الزملاء ضبط البناء لاختصاره وتحسينه Private Sub cmdPrint_Click() On Error GoTo Err_cmdPrint_Click Dim Index3 As Variant Dim repName As String For Each Index3 In L3.ItemsSelected repName = L3.ItemData(Index3) repName = "تقرير_" & repName Next Index3 If repName = "" Then MsgBox "لا يوجد مطبوغات قد تم اختيارها", vbInformation + vbMsgBoxRight, "تنبيه " Exit Sub Else For Each Index3 In L3.ItemsSelected repName = L3.ItemData(Index3) repName = "تقرير_" & repName DoCmd.OpenReport repName, acViewNormal, , ftrName Next Index3 Exit_cmdPrint_Click: Exit Sub Err_cmdPrint_Click: MsgBox Err.Description Resume Exit_cmdPrint_Click End If End Sub

تم الوصول إلى الحل بالتجربة إذ يبدو أن الخصائص لها أولية عن الكود لذلك تم تغيير خاصية التوسيط للنموذجين بـ "لا" واستدعاء توسيط النموذج عند الفتح باستخدام الكود أعلاه Private Sub Form_Open(Cancel As Integer) CenterFormOnScreen "frm_M1" End Sub

شكراً لك لا يوجد مشكلة ، بل هى ناحية جمالية فقط النموذج الأول يفتح النموذج الثانى فى موضع أعلى منه قليلاً فى الشاشة قبل إغلاق نفسه والنموذج الثانى عند إغلاقه يعيد فتح النموذج الأول فى نفس الموضع الأول أى أسفل قليلاً من النموذج الثانى سأجرب هذا الكود لكل من النموذجين Public Sub CenterFormOnScreen(formName As String) Dim screenWidth As Long Dim screenHeight As Long screenWidth = GetSystemMetrics(SM_CXSCREEN) screenHeight = GetSystemMetrics(SM_CYSCREEN) Dim targetForm As Form Dim formWidthTwips As Long Dim formHeightTwips As Long Dim formWidthPixels As Long Dim formHeightPixels As Long Dim fleftPos As Long Dim ftopPos As Long Set targetForm = Forms(formName) ' الحصول على عرض النموذج وارتفاعه بالتويبس formWidthTwips = targetForm.windowWidth formHeightTwips = targetForm.windowHeight ' تحويل الأبعاد من تويبس إلى بكسل formWidthPixels = formWidthTwips / 15 formHeightPixels = formHeightTwips / 15 ' Calculate left and top positions for centering fleftPos = (screenWidth - formWidthPixels) / 2 ftopPos = (screenHeight - formHeightPixels) / 2 ' اعاده التحويل لوحدة القياس تويبس fleftPos = fleftPos * 15 ftopPos = ftopPos * 15 ' نقل النموذج إلى الموضع المركزي DoCmd.MoveSize fleftPos, ftopPos End Sub

السلام عليكم عندى نموذجين كل منهما عبارة عن "تفصيل ( Detail) فقط " .. لهما نفس الطول ونفس العرض رقمياً أحدهما ينادى الآخر ليحل محله ، فأجد أن الآخر يتموضع فى مكان أعلى قليلاً من النموذج المنادى عليه السؤال : ما هى بنود الخصائص التى توحد ظهور كل منهما فى نفس المكان بشاشة الكمبيوتر بالضبط علماً بأننى مفعل خاصية التوسيط لنموذج كل منهما بـ "نعم" تحياتى وتقديرى لكم

شكراً للسادة الزملاء على تفاعلهم سأجرب نصيحة التشغيل على جهاز آخر عندما يتاح لى أما بالنسبة لتغيير الحدث TimerInterval = 500 وليس 1000 أى التغيير يحدث كل نصف ثانية فالمشكلة ما زالت كما هى بالنسبة للعزيز منتصر الانسي خارج الموضوع : هل من الممكن معرفة كيفية تسجيل ردك بصيغة gif ومن ثم رفعها على المنتدى ؟؟

تمام ، والله أعلم شكراً لك ربما تكون مواصفات جهازى أو نسخة الأكسس 2003 لكن لو لاحظت أننى ذكرت " أحياناً وليس دائم " جرب التشغيل ثم غلق الملف ، ثم تشغيله مرة ثانية

السلام عليكم هو موضوع غير مؤثر ولكنه يدخل فى الناحية الجمالية أحياناً وليس دائماً أجد Lable إظهار الوقت بالثوانى مرتعشاً مع كل ثانية تتغير من المؤكد هناك حل لتثبيت هذا الإرتعاش ، ولكنى لم أسأل عنه من قبل أى زميل هل هناك حل برمجى لهذا المرتعش ؟؟ db1.mdb

أداة مفيدة وجميلة لكن ماذا لو كانت السجلات لا تحتوى على حقول رقمية (نصية فقط حتى العددية منها ) Smart Fillter.accdb

السر يكمن فى سطر الكود أدناه شكراً جزيلاً للسادة الزملاء على تلك المناقشة y = Mid(MyNumber, 2, 2)

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

شكراً أخى Foksh على سرعة الرد تم المطلوب ،وشكراً لك لكن للمعرفة فقط ، لو تم استخدام هذه الدالة من الوحدة النمطية المرفقة Date_Sex_Province([National_Nr], 1) كيف سيكون التصميم ؟

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

لا توجد مشكلة فقد تم الحل من قبل فعلاً فقط أنا أضع محاولاتى للحل _ والتى توصلت إليها _ لأى عضو كان متابعاً هنا وحالياً قمت منذ قليل باختصار إضافى للأكواد المكررة ، ولا داعى للحديث عن ذلك 🤨

أضفت بعض التعديلات على كود الحذف فى النموذج المعروض فى أول مشاركة فأصبح التنفيذ ممتاز فى الحذف لأول سجل وما يليه أو بالداخل أو السجل الأخير بدون أى رسائل خطأ أعلم أن بعض الأكواد تكررت ، والمطلوب تكرماً تنظيمها وعدم تكرارها مع الحفاظ على الأداء صفر مشاكل شكراً لكل من شاركنى أفكاره سواء بالرد أو بكتابة الأكواد أو بالنصيحة .. Private Sub Cmdel_Click() On Error GoTo Err_Cmdel_Click If MsgBox(":ستقوم الآن بحذف السجل المسجل بملف رقم" & vbCrLf _ & vbCrLf _ & [Nr] & " " & vbCrLf _ & [Name_T] & vbCrLf _ & " " & vbCrLf _ & "هل أنت متأكد ؟" & vbCrLf _ & "أضغط ( نعم ) للإستمرار ، أو ( لا ) لإلغاء الأمر", vbQuestion + vbYesNo _ + vbMsgBoxRight, "تحذيـــر") = vbYes Then ' ما تم إضافته لتفريغ جميع الحقول غير المرتبطة فى سجل جديد بعد حذف السجل الأخير Me.Retire.Value = "" Me.d.Value = "" Me.m.Value = "" Me.y.Value = "" Me.dd.Value = "" Me.mm.Value = "" Me.yy.Value = "" Me.Retirement.Value = "" '----------------------- Me.Recordset.Delete Me.Recordset.MoveNext ' ما تم إضافته لإعادة حساب جميع الحقول غير المرتبطة فى السجل التالى بعد حذف السجل الذى قبله GetStrat '----------------------- End If Exit_Cmdel_Click: Exit Sub Err_Cmdel_Click: MsgBox Err.Description Resume Exit_Cmdel_Click End Sub db2.mdb

كل الشكر والتقدير لكل من kkhalifa1960 Foksh رسالة الخطأ التى تحدثت عنها فى بداية الموضوع لا تؤثر فى عمل النموذج وتعتبر شيئاً زائداً فى بعض الأحيان لكن استفدت منكما فى معرفة سببها لذلك لن أقوم بالتعديل حالياً ، فالوضع الحالى بدون تعديل هو الأفضل مرة أخرى .. شكراً جزيلاً لكما

شكراً أخى لاهتمامك وردك سوف أضع مرفق للملف الذى أعمل عليه أدناه أحياناً الفورم يعمل بدون مشاكل بالمرة ، وفى بعض الأحيان تكون المشكلة فى حذف السجل الأخير لكن أرجو أن تضيف سجل جديد باستخدام أحد الأرقام القومية الآتية 26507111201809 أنثى 28603110400251 ذكر 27301052700568 أنثى 27908100400212 ذكر 28101200400409 أنثى والخروج من خانة الرقم القومى بعد لصقه بالضغط على زر Tab ثم قم بحذف هذا السجل .. المفترض بعد الحذف وجود صفحة بيضاء خالية من كل الحقول الغير منضمة لكن هذا لا يحدث دائماً db1.mdb

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

السلام عليكم ورحمة الله وبركاته باستخدام الكود التالى يمكن حذف أى سجل داخل قاعدة بيانات ما عدا عند حذف السجل الأخير فى نفس القاعدة تظهر هذه الرسالة كيف يمكن معالجة خطأ هذه الرسالة ؟؟ إذ أن المفترض بعد هذا الحذف ظهور صفحة فارغة من كل الحقول لإدخال سجل جديد الكود Private Sub Cmdel_Click() On Error GoTo Err_Cmdel_Click If MsgBox(":ستقوم الآن بحذف السجل المسجل بملف رقم" & vbCrLf _ & vbCrLf _ & [Nr] & " " & vbCrLf _ & [Name_T] & vbCrLf _ & " " & vbCrLf _ & "هل أنت متأكد ؟" & vbCrLf _ & "أضغط ( نعم ) للإستمرار ، أو ( لا ) لإلغاء الأمر", vbQuestion + vbYesNo _ + vbMsgBoxRight, "تحذيـــر") = vbYes Then Me.Recordset.Delete Me.Recordset.MoveNext End If Exit_Cmdel_Click: Exit Sub Err_Cmdel_Click: MsgBox Err.Description Resume Exit_Cmdel_Click End Sub

تم التجربة بالتعديلات كما فى الكود السابق على السجلات الداخلية والأخيرة وإنشاء سجل جديد لا بأس لكن كما ذكرت أشعر بأن الأكواد تم تكرارها فى كل مكان .. إن كان هناك أفضل لن أمانع 😀

نعم كل هذا صحيح ، ما عدا حذف السجل الأخير فى القاعدة هنا تظهر المشكلة حاولت مبدئياً إدخال التعديل على هذا الكود وجاري التجربة على السجلات الأخير أو إنشاء سجل جديد Private Sub Cmdel_Click() On Error GoTo Err_Cmdel_Click If MsgBox(":ستقوم الآن بحذف السجل المسجل بملف رقم" & vbCrLf _ & vbCrLf _ & [Nr] & " " & vbCrLf _ & [Name_S] & vbCrLf _ & " " & vbCrLf _ & "هل أنت متأكد ؟" & vbCrLf _ & "أضغط ( نعم ) للإستمرار ، أو ( لا ) لإلغاء الأمر", vbQuestion + vbYesNo _ + vbMsgBoxRight, "تحذيـــر") = vbYes Then Me.Recordset.Delete Me.Recordset.MoveNext 'هذه الإضافة تحقق المرجو منها ولكن أشعر بتكرار الأكواد Me.D.Value = "" Me.m.Value = "" Me.y.Value = "" Me.gender.Value = "" Me.Mohaftha.Value = "" GetStrat ' End If Exit_Cmdel_Click: Exit Sub Err_Cmdel_Click: MsgBox Err.Description Resume Exit_Cmdel_Click End Sub

هذا ما فعلته قبل الإطلاع على تعديل حضرتك بالمرفق وحصلت على هذه الرسائل

حينها سوف تحدث مشكلة عند حذف السجل الأخير . ممكن التعديل بالمرفق ؟