ناقل

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

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

تفضل انظر الاستعلام الجديد البحث وتعديل درجات10.rar

قمت لاحظ الاستعلام قام بتصفية الصف الاول واضفت طالب وسام ذكر وقام الاستعلام بترتيبة .... هل هذا الترتيب هو المطلوب لديك ؟؟؟

بعد اذنك سيد @Foksh ممكن عمل ذلك عن طريق النموذج أو التقرير دون الحاجة لطريقتك هذه

مشاركة Sub ClearClipboardAndFreeMemory() ' تحرير محتوى الحافظة On Error Resume Next Dim DataObject As Object Set DataObject = CreateObject("MSForms.DataObject") DataObject.SetText "" DataObject.PutInClipboard Set DataObject = Nothing On Error GoTo 0 ' تحرير الذاكرة DoEvents Application.Echo True, "Memory cleared" End Sub

جرب هذا .... Private Sub Form_Open(Cancel As Integer) Me.OrderBy = "fega ASC" ' للفرز تصاعديًا Me.OrderByOn = True End Sub Private Sub Form_Current() Me.OrderBy = "fega ASC" ' للفرز تصاعديًا Me.OrderByOn = True End Sub

جرب واعلمنا ... لاني لم اجربه #If VBA7 Then Private Declare PtrSafe Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const HWND_BROADCAST As LongPtr = &HFFFF& #Else Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const HWND_BROADCAST As Long = &HFFFF& #End If Private Const WM_FONTCHANGE As Long = &H1D Sub InstallFonts() Dim dbPath As String Dim fontsFolder As String Dim fontFile As String Dim fontName As String Dim fso As Object Dim folder As Object Dim file As Object Dim fontInstalled As Boolean ' الحصول على مسار قاعدة البيانات ومجلد الخطوط dbPath = CurrentProject.Path fontsFolder = dbPath & "\الخطوط" ' التحقق إذا كان مجلد الخطوط موجودًا Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists(fontsFolder) Then MsgBox "مجلد الخطوط غير موجود: " & fontsFolder, vbExclamation Exit Sub End If ' تصفح الخطوط في المجلد Set folder = fso.GetFolder(fontsFolder) For Each file In folder.Files If LCase(Right(file.Name, 4)) = ".ttf" Or LCase(Right(file.Name, 4)) = ".otf" Then fontFile = file.Path fontName = GetFontName(fontFile) ' التحقق إذا كان الخط مثبتًا fontInstalled = IsFontInstalled(fontName) If Not fontInstalled Then If AddFontResource(fontFile) > 0 Then ' تحديث النظام لإضافة الخط SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0 MsgBox "تم تثبيت الخط: " & fontName, vbInformation Else MsgBox "فشل في تثبيت الخط: " & fontName, vbExclamation End If End If End If Next file MsgBox "اكتمل التحقق من الخطوط.", vbInformation End Sub Function IsFontInstalled(fontName As String) As Boolean Dim regPath As String Dim objRegistry As Object On Error Resume Next regPath = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts" Set objRegistry = CreateObject("WScript.Shell") IsFontInstalled = Not IsEmpty(objRegistry.RegRead(regPath & "\" & fontName & " (TrueType)")) On Error GoTo 0 End Function Function GetFontName(fontFile As String) As String ' استرجاع اسم الملف بدون الامتداد GetFontName = CreateObject("Scripting.FileSystemObject").GetBaseName(fontFile) End Function

تفضل ... Me.Caption =DLookUp("[school]";"Tbl_basic") في حدث عند تحميل النموذج

تفضل .............. Dim UserInput As String Dim IsValid As Boolean ' احصل على النص المدخل UserInput = Me.y.Value ' تحقق من وجود حروف وأرقام فقط IsValid = Not UserInput Like "*[!A-Za-z0-9]*" And _ UserInput Like "*[A-Za-z]*" And _ UserInput Like "*[0-9]*" If IsValid Then ' أغلق النموذج إذا كان الإدخال صحيحًا DoCmd.Close Else ' إظهار رسالة خطأ MsgBox "الرقم المدخل غير صحيح. يجب أن يحتوي الإدخال على حروف وأرقام فقط.", vbCritical, "خطأ" ' تفريغ مربع النص Me.y.Value = "" End If

امين واياك ... منكم تعلمنا بارك الله فيك وفي علمك حياك اخي الكريم ... في الخدمه

جرب المرفق open.accdb Private Sub Form_Load() Call CopyText("Pa@ 12345678") End Sub Public Function CopyText(ByVal Text As Variant) As Boolean CopyText = CreateObject("htmlfile").ParentWindow.ClipboardData.SetData("Text", Text) End Function

كود VBA باستخدام Windows API وبدون تفعيل مكتبة Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal uFormat As Long, ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPtr Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long Const CF_TEXT As Long = 1 Const GMEM_MOVEABLE As Long = &H2 Sub CopyToClipboard(Text As String) Dim hGlobal As LongPtr Dim lpGlobal As LongPtr ' فتح الحافظة If OpenClipboard(0&) Then ' تفريغ الحافظة EmptyClipboard ' تخصيص ذاكرة للنص hGlobal = GlobalAlloc(GMEM_MOVEABLE, Len(Text) + 1) If hGlobal Then ' قفل الذاكرة وتعبئتها بالنص lpGlobal = GlobalLock(hGlobal) If lpGlobal Then CopyMemory ByVal lpGlobal, ByVal StrPtr(Text), Len(Text) GlobalUnlock hGlobal ' نسخ النص إلى الحافظة SetClipboardData CF_TEXT, hGlobal End If End If ' إغلاق الحافظة CloseClipboard End If End Sub Private Sub Form_Load() ' نسخ النص "P@12345678" عند تحميل النموذج CopyToClipboard "P@12345678" MsgBox "تم نسخ النص إلى الحافظة!", vbInformation, "نسخ النص" End Sub ملاحظات: الكود يدعم الأنظمة 64 بت (استخدم PtrSafe و LongPtr). إذا كنت تعمل على نظام 32 بت، يمكنك استبدال LongPtr بـ Long وحذف الكلمة PtrSafe. لا يحتاج إلى مكتبات خارجية.

MSForms.DataObject يحتاج إلى تفعيل مكتبة Microsoft Forms 2.0 Object Library

تفضل .... Private Sub Form_Load() ' نسخ النص إلى الحافظة Dim clipboard As Object Set clipboard = CreateObject("MSForms.DataObject") ' النص الذي تريد نسخه clipboard.SetText "P@12345678" clipboard.PutInClipboard MsgBox "تم نسخ النص إلى الحافظة!", vbInformation, "نسخ النص" End Sub