ابو البشر

تفضل Public Function GetMissingArabicLetters(ByVal InputText As String) As String Dim strAlphabet As String Dim strOutput As String Dim i As Integer Dim char As String Dim inputLetters As Collection Dim missingCount As Integer ' الحروف العربية الأبجدية (الألف إلى الياء) strAlphabet = "ابتثجحخدذرزسشصضطظعغفقكلمنهوي" ' إنشاء مجموعة لتخزين الحروف الموجودة Set inputLetters = New Collection ' إضافة كل حرف عربي موجود في النص إلى المجموعة (منع التكرار) For i = 1 To Len(InputText) char = Mid(InputText, i, 1) If InStr(1, strAlphabet, char, vbBinaryCompare) > 0 Then On Error Resume Next inputLetters.Add char, char On Error GoTo 0 End If Next i ' بناء النتيجة بالشكل المطلوب (حرف، حرف، حرف) strOutput = "" missingCount = 0 For i = 1 To Len(strAlphabet) char = Mid(strAlphabet, i, 1) On Error Resume Next inputLetters.Item (char) ' محاولة الوصول إلى الحرف If Err.Number <> 0 Then ' إذا حدث خطأ فهذا يعني أن الحرف غير موجود If missingCount > 0 Then strOutput = strOutput & "، " ' فاصلة عربية + مسافة End If strOutput = strOutput & char missingCount = missingCount + 1 End If On Error GoTo 0 Next i ' النتيجة النهائية If missingCount = 0 Then GetMissingArabicLetters = "لا توجد حروف مفقودة" Else GetMissingArabicLetters = strOutput End If ' تنظيف الذاكرة Set inputLetters = Nothing End Function استدعيه بهذا الشكل Private Sub cmdExtract_Click() Me.txtOutput.Value = GetMissingArabicLetters(Me.txtInput.Value) End Sub

وعليكم السلام ورحمة الله وبركاته اهلا بك جرب هذا Private Sub cmdExtract_Click() Dim strInput As String Dim strAlphabet As String Dim strOutput As String Dim i As Integer Dim char As String Dim inputLetters As Collection Dim missingCount As Integer strAlphabet = "ابتثجحخدذرزسشصضطظعغفقكلمنهوي" strInput = Me.txtInput.Value Set inputLetters = New Collection For i = 1 To Len(strInput) char = Mid(strInput, i, 1) If InStr(1, strAlphabet, char, vbBinaryCompare) > 0 Then On Error Resume Next inputLetters.Add char, char On Error GoTo 0 End If Next i strOutput = "" missingCount = 0 For i = 1 To Len(strAlphabet) char = Mid(strAlphabet, i, 1) On Error Resume Next inputLetters.Item (char) If Err.Number <> 0 Then If missingCount > 0 Then strOutput = strOutput & "'، '" End If strOutput = strOutput & "'" & char & "'" missingCount = missingCount + 1 End If On Error GoTo 0 Next i If missingCount = 0 Then Me.txtOutput.Value = "لا توجد حروف مفقودة" Else Me.txtOutput.Value = strOutput End If Set inputLetters = Nothing End Sub

لم اعدل ملفك ... ولكن عند فتحة ظهرت مرتبة وبدون مشاكل

الترتيب كما تريد .... ليس هناك مشكلة والا وضح مطلوبك

طيب تستطيع عملها ام اعدله لك بارك الله فيك

تفضل .......................... ‏‏‏‏saad_A.accdb

3-4 هذه الفترة ... اليست الفترة تعني من الساعة الثالثة الى الرابعة ... ام ماذا تعني الفترة ... نورنا

طريقتين ايهما تريد ...... الطريقة الاولى ::::: طباعة يوم بيوم الطريقة الثانية :::::: طباعة ورقة واحدة لايام الاختبار ليسهل على موزيع الملاحظة العدل بين المعلين

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

اداة مفيدة ... بارك الله فيك ... هديه مقبولة

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

وعليكم السلام 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

جرب هذا Dim result As VbMsgBoxResult result = MsgBox("ماذا تريد ان تفعل اضغط Yes لفتح النموذج NO لفتح التقرير Cancel للتراجع" & vbCrLf & vbCrLf & "الحمدلله", _ vbYesNoCancel + vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "الله المستعان") If result = vbYes Then DoCmd.OpenForm "22" ElseIf result = vbNo Then DoCmd.OpenReport "33", acViewPreview ElseIf result = vbCancel Then Exit Sub ' 👈 هنا يخرج بدون أي إجراء End If

البرنامج ممتاز ... ولكن عند تشغيلة يظهر بهذه الصورة زاحفا نحو اليسار الى الاسفل يبدو بسبب هذا الكود عند الفتح Private Sub Form_Current() Me.Form.InsideHeight = 9000 Me.Form.InsideWidth = 17000 CenterFormOnScreen "frm-UserLogon" End Sub

أسأل الله العظيم رب العرش العظيم أن يشفيك ووالدتك ويشافيكما عاجلاً غير آجل شفاءً لا يغادر سقماً