كل الانشطه

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

الخبير الفاضل شكرا لابداعك المتجددة لي طلب بسيط ممكن لو تكرمت تستبدل قاعدة If بقاعدة Select Case حتى نتمكن من عمل امر لكل زر فى الرسالة مثلا لو حددنا ٣ ازرار نعم ولا وإلغاء الامر نعم فتح نموذج محدد لا لفتح تقرير محدد الغاء الأمر لغلق الرسالة لانى قمت بتجربة هذا الموضوع نعم يفتح النموذج تمام لا يفتح التقرير تمام الغاء الأمر حاولت بكل الطرق Undo Exit Sub لكنة يكرر الأمر السابق وهو فتح التقرير لذلك ارجوك تحويل قاعدة If إل cselect case لك خالص الشكر

بعد تجربة المرفق ، والتمعن فيه ، مشكلتك أخي الكريم في الجزء :- ElseIf vbNo Then السبب طبعاً أنه لا يفحص نتيجة رد الرسالة الكلي ، بل يعتبر vbNo قيمة ثابتة . وبالتالي يدخل إليه دائماً إذا لم تكن النتيجة vbYes . لذا فالأفضل من وجهة نظري ، والأصح هو استخدام Select Case في حالتك هذه . خلاف ذلك قد نضطر لاستخدام الرسالة مرتين في الجملة الشرطية ، وهذا سيكرر الرسالة مرتين داخل نفس الحدث . لذا جرب الفكرة التالية :- Private Sub أمر0_Click() Select Case MsgBox("ماذا تريد ان تفعل Yes فتح نموذج NO فتح تقرير Cancel تراجع" & vbCrLf & vbCrLf & "الحمدلله", _ vbYesNoCancel + vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, _ "الله المستعان") Case vbYes DoCmd.OpenForm "22" Case vbNo DoCmd.OpenReport "33", acViewPreview Case vbCancel Exit Sub End Select End Sub

شكراً أخى Moosak على مشاركتك بنقل ما تفضلت به للمشروع لم يتغير شئ الكود الوحيد الذى يعمل بلا مشاكل هو كود أخى ابو البشر وإن كان فى حاجة لبعض الإضافات لكنه هو الصحيح بلا أى مشكلة عندى

قمت بمسح السطر واعطى الاتى انظر الصورة

الخبير المبدع شكرا على ابداعك بس حضرتك انا كنت عاوز تعطيل فقط على الكود وهو بنفس الشكل بدون متغيرات كنت كيبت الكلام دة قبل كدة مفيش اى تعديل علي الكود المرسل بدون إضافة Dim result as بدون متغيرات لان الرسالة دى بيتم توليدها من برنامج وجدتي علي الموقع ولا أستطيع التعديل علية انا بكتب عنوان الرسالة ومستواها وعدد الازرار وهو بينتج الكود اريد التعديل علي الكود كما هو هل هذا ممكن البرنامج موجود فى هذا الرابط

تفض د @jo_2010 المرفق بعد التعديل . ووافني بالرد . JO.rar

فقط اوقف السطر أو امسحه لأني نسيته . ' Me.NO_Esal = Me.NEW

تفضل استاذ بلال المرفق . ووافني بالرد . Bilal_Yamen-Last-2.rar

أرى الحل أنك تستغني عن المكتبات تماما بتعريف المتغيرات كـ Object .. رجعت لنفس الأداة وكتبت له : والنتيجة : Private Sub cm_ToExcel_Click() ' تعلن عن المتغيرات المطلوبة Dim stDocName As String Dim Q As Integer Dim objFileDialog As Object ' كائن مربع حوار الملفات (يتم تعريفه كـ Object لعدم استخدام المكتبات) Dim varFilePath As Variant ' المسار الكامل للملف الذي سيتم حفظه (يتم تعريفه كـ Variant لاستقبال قيمة من مربع الحوار) Dim fso As Object ' كائن نظام الملفات للتحقق من وجود محرك الأقراص (يتم تعريفه كـ Object لعدم استخدام المكتبات) Dim drv As Object ' كائن محرك الأقراص (يتم تعريفه كـ Object لعدم استخدام المكتبات) Dim blnDriveEExists As Boolean ' علامة منطقية للتحقق مما إذا كان محرك الأقراص E موجودًا وجاهزًا Dim strDefaultPath As String ' المسار الافتراضي الذي سيتم عرضه في مربع الحوار ' تعيين معالج الأخطاء للانتقال إلى تسمية Err_cm_ToExcel_Click في حالة حدوث خطأ On Error GoTo Err_cm_ToExcel_Click ' بناء اسم المستند بناءً على اسم الجدول وقيمة حقل [Year_name] stDocName = "tbl_Teacher" & [Year_name] ' حساب عدد السجلات في جدول tbl_Teacher Q = DCount("*", "tbl_Teacher") ' التحقق مما إذا كانت هناك سجلات (أكثر من صفر) لتصديرها If Q > 0 Then ' -------------------------------------------------------------------- ' الجزء الخاص بالتحقق من وجود محرك الأقراص E وتعيين المسار الافتراضي ' -------------------------------------------------------------------- ' إنشاء كائن FileSystemObject بدون استخدام مكتبات (Late Binding) ' هذا يسمح بالتحقق من محركات الأقراص دون الحاجة إلى إضافة مرجع لمكتبة Microsoft Scripting Runtime Set fso = CreateObject("Scripting.FileSystemObject") blnDriveEExists = False ' تهيئة العلامة إلى False ' التكرار عبر جميع محركات الأقراص المتاحة للتحقق من وجود محرك الأقراص E For Each drv In fso.Drives If drv.DriveLetter = "E" Then ' إذا كان حرف محرك الأقراص هو "E" If drv.IsReady Then ' والتأكد من أن محرك الأقراص جاهز للاستخدام (ليس فارغًا أو غير متصل) blnDriveEExists = True ' تعيين العلامة إلى True Exit For ' الخروج من الحلقة بمجرد العثور على محرك الأقراص E الجاهز End If End If Next drv ' تعيين المسار الافتراضي لمربع الحوار بناءً على نتيجة التحقق If blnDriveEExists Then strDefaultPath = "E:\" ' إذا كان E موجودًا وجاهزًا، استخدمه كمسار افتراضي Else ' إذا لم يكن E موجودًا أو جاهزًا، استخدم مسار المشروع الحالي كمسار افتراضي strDefaultPath = CurrentProject.Path End If ' تحرير كائنات نظام الملفات لتحرير الذاكرة Set fso = Nothing Set drv = Nothing ' -------------------------------------------------------------------- ' الجزء الخاص بعرض مربع حوار حفظ الملف للسماح للمستخدم باختيار الموقع ' -------------------------------------------------------------------- ' إنشاء كائن مربع حوار الملفات (Application.FileDialog) بدون استخدام مكتبات (Late Binding) ' 2 يمثل msoFileDialogSaveAs (قيمة ثابتة لمربع حوار حفظ باسم) Set objFileDialog = Application.FileDialog(2) ' تهيئة خصائص مربع الحوار With objFileDialog .Title = "اختر مكان حفظ ملف الإكسل" ' تعيين العنوان الذي يظهر في أعلى مربع الحوار .InitialFileName = stDocName & ".xls" ' تعيين الاسم الافتراضي للملف الذي سيتم حفظه .InitialFolder = strDefaultPath ' تعيين المجلد الافتراضي الذي سيتم فتحه عند ظهور مربع الحوار .ButtonName = "حفظ" ' تعيين النص الذي يظهر على زر الحفظ في مربع الحوار .Filters.Clear ' مسح أي فلاتر ملفات موجودة مسبقًا .Filters.Add "ملفات إكسل (*.xls)", "*.xls" ' إضافة فلتر لملفات الإكسل القديمة (Excel 97-2003) .Filters.Add "جميع الملفات (*.*)", "*.*" ' إضافة فلتر لجميع أنواع الملفات .FilterIndex = 1 ' تعيين الفلتر الأول (ملفات إكسل) كفلتر افتراضي ' عرض مربع الحوار والتحقق مما إذا كان المستخدم قد ضغط على زر "حفظ" If .Show = -1 Then ' -1 يعني أن المستخدم ضغط على زر "حفظ" (OK) ' الحصول على المسار الكامل للملف المحدد من قبل المستخدم varFilePath = .SelectedItems(1) ' تصدير البيانات من جدول tbl_Teacher إلى ملف الإكسل بالمسار الذي اختاره المستخدم ' 0 يمثل acExport (قيمة ثابتة لعملية التصدير) ' 8 يمثل acSpreadsheetTypeExcel97 (قيمة ثابتة لنوع ملف الإكسل Excel 97-2003) DoCmd.TransferSpreadsheet 0, 8, "tbl_Teacher", varFilePath, False ' عرض رسالة نجاح للمستخدم تتضمن المسار الذي تم الحفظ فيه MsgBox ("تم استخراج ملف أكسل لبيانات الموظفيـن وحفظه في: " & Chr(13) & Chr(13) & varFilePath), vbOKOnly + vbMsgBoxRight, "تنبيه" Else ' إذا ألغى المستخدم عملية الحفظ (ضغط على Cancel) MsgBox "تم إلغاء عملية حفظ ملف الإكسل.", vbInformation + vbMsgBoxRight, "تنبيه" End If End With ' تحرير كائن مربع حوار الملفات لتحرير الذاكرة Set objFileDialog = Nothing Else ' عرض رسالة إذا لم تكن هناك سجلات في الجدول لتصديرها MsgBox ("لا يوجد سجلات لتصديرها "), vbOKOnly + vbMsgBoxRight, "تنبيه" End If Exit_cm_ToExcel_Click: ' نقطة الخروج العادية من الإجراء Exit Sub Err_cm_ToExcel_Click: ' معالج الأخطاء: عرض وصف الخطأ الذي حدث MsgBox Err.Description, vbCritical, "خطأ" ' استئناف التنفيذ عند نقطة الخروج العادية من الإجراء Resume Exit_cm_ToExcel_Click End Sub

انظر الصور

استاذى الفاضل قمت بتغيير Undo الى Exit Sub واعطى نفس النتيجة السابقة وهو تنفيذ اخر امر فتح التقرير اليك القاعدة للتعديل JO.accdb

السلام عليكم أرجو التمهل قليلا و باذن الله تكون الأمور مستقلا على ما يرام

للأسف .. حيث أن العمل على أكسس 2003 فلا يوجد غير هذه المكتبة المرقمة برقم 11 وهى مضافة أصلاً للمشروع لكن يبدو أنها غير كافية لهذا الإصدار والمقصود بالعمل على أكسس 2003 هو توافق هذا العمل حتى على أحدث إصدار لذلك عند التشغيل على أوفيس 2024 تم استبدال المكتبه بالإصدار 16 تلقائياً التى أشار إليها أخى Foksh ومع ذلك عند التنفيذ ظهرت نفس رسالة الخطأ !!!!

تفضل المرفق بعد التعديل بطلبك . Jo_Lab3.rar

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

بدل كلمة Undo ، اجعلها Exit Sub فقط .

دعماً لما تفضل به أستاذنا ابو البشر ، المكتبة الموضحة في الصورة التالية :- طبعاً الرقم 16.0 سيختلف حسب إصدار الأوفيس لديك . فللإصدارات التي أقل من 2016 سيكون الرقم 14.0

هذه هي المكتبة المطلوبة

قمت بتجربة النموذج المرسل من حضرتك يعمل بكفاءة مع الايصالات التى تنتهى ب ٥٥ وعندما كتبت ١٠٠٠ أصبحت القيمة ٥٦٠٠٠ وهذا رائع وقمت بإدخال رقم الإيصال ه أرقام ٥٦٠٠١ ورقم آخر ٠٠٩ أعطى نتيجة رائعة ولكن حاولت تجربة إذا تخطينا ٥٦ بدل رقمين أصبحت ٣ أرقام مثال١٠١٠٠٥ أدخلت رقم إيصال بالكامل ١٠١٠١٩ وسجل جديد كتبت ١٢٢ لم يحتفظ ١٠١ وعاد الي ٥٦ أصبح الإيصال ٥٦١٢٢ بدل ١٠١١٢٢ وهو الرقم الصحيح كيفية حل هذا الوضع هذا الخطأ يظهر لى كثيرا كتبت إيصال ٢٣٠ المفروض ٥٦٢٣٠ قبل منة كان في إيصال ٥٦٢٥٠ يعطى خطا كما بالصورة

تمام شكراً لك .. بارك الله فيك قبل سؤالى استخدمت صفحة 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

السلام عليكم وكل عام واانتم بالف خير الاساتذه الكرام لدي برنامج اريد عمل شاشه دخول وصلاحيات مستخدمين تصفح فقط او تصفح مع تعديل او كامل تصفح وتعديل وحذف 2008-4 (1).rar

وعليكم السلام Private Sub cm_ToExcel_Click() On Error GoTo Err_cm_ToExcel_Click Dim stDocName As String Dim Q As Integer Dim sh As Object Dim folder As Object Dim FolderPath As String Dim FilePath As String stDocName = "tbl_Teacher_" & [Year_name] Q = DCount("*", "tbl_Teacher") If Q > 0 Then ' اختيار مجلد Set sh = CreateObject("Shell.Application") Set folder = sh.BrowseForFolder(0, "اختر مجلد حفظ الملف", 0) ' لو إلغاء If folder Is Nothing Then Exit Sub FolderPath = folder.Items().Item().Path FilePath = FolderPath & "\" & stDocName & ".xls" ' 🔥 التحقق من وجود الملف If Dir(FilePath) <> "" Then If MsgBox("الملف موجود بالفعل:" & vbCrLf & FilePath & vbCrLf & vbCrLf & _ "هل تريد استبداله؟", _ vbYesNo + vbQuestion + vbMsgBoxRight, "تأكيد") = vbNo Then Exit Sub End If End If ' التصدير DoCmd.TransferSpreadsheet acExport, 8, "tbl_Teacher", FilePath, False MsgBox "تم حفظ الملف بنجاح في:" & vbCrLf & FilePath, vbInformation + vbMsgBoxRight, "تم" Else MsgBox "لا يوجد سجلات لتصديرها", vbExclamation + vbMsgBoxRight, "تنبيه" End If Exit_cm_ToExcel_Click: Exit Sub Err_cm_ToExcel_Click: MsgBox Err.Description Resume Exit_cm_ToExcel_Click End Sub

السلام عليكم نعم المشكلة من حماية الشيتات اليك التعديل مع اظافة الترقيم التلقائي لرقم التسجيل Plateform (1) .xlsb

السلام عليكم فيما يلى إجراء يقوم بحفظ قاعدة بيانات فى صورة ملف أكسل 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