سامي الحداد

تفضل استاذ @jo_2010 هذا بالنسبة لطلبك الثاني
Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long) On Error Resume Next If Not Me.Dirty Then If (Count < 0) And (Me.CurrentRecord > 1) Then DoCmd.GoToRecord , , acPrevious ElseIf (Count > 0) And (Me.CurrentRecord <= Me.Recordset.RecordCount) Then DoCmd.GoToRecord , , acNext End If Dim parentForm As Form Dim labReqForm As Form Dim pnameValue As String Dim recordFound As Boolean Set parentForm = Me.Parent If parentForm.Controls("Lab_Patient").Form.CurrentView = 0 Then MsgBox "Lab_Patient subform is not open." Exit Sub End If Set labReqForm = parentForm.Controls("Lab_Sub_REQ").Form pnameValue = parentForm.Controls("Lab_Patient").Form.Controls("PNAME").Value labReqForm.Recordset.FindFirst "Pname = '" & pnameValue & "'" If Not labReqForm.Recordset.NoMatch Then labReqForm.Controls("Requests").BackColor = RGB(255, 0, 0) recordFound = True Else ' MsgBox "Record not found in Lab_Sub_REQ." recordFound = False End If End If End Sub بالتوفيق
LAB_GOOD 2.rar

هل هذا هو المطلوب ؟
حسب ما فهمت هل هذا  هو المطلوب؟
Private Sub Form_Load() Dim pdfPath As String pdfPath = "C:\Users\LENOVO\Documents\1222.pdf" ' استبدل المسار Me.WebBrowser0.Object.Navigate pdfPath End Sub  

مشاركة مع الاخ @Foksh
Option Compare Database Option Explicit Private Sub Command0_Click() ExecuteIfChromeOpen End Sub Function IsChromeRunning() As Boolean Dim strCommand As String Dim strOutput As String Dim objWShell As Object Set objWShell = CreateObject("WScript.Shell") strCommand = "tasklist /FI ""IMAGENAME eq chrome.exe""" strOutput = objWShell.Exec(strCommand).StdOut.ReadAll If InStr(strOutput, "chrome.exe") > 0 Then IsChromeRunning = True Else IsChromeRunning = False End If Set objWShell = Nothing End Function Sub ExecuteIfChromeOpen() If IsChromeRunning() Then MsgBox " المتصفح كروم قيد التشغيل. سيتم تنفيذ الأمر", vbInformation, "تأكيد" DoCmd.OpenForm "البيانات" Else MsgBox "يجب فتح المتصفح .", vbExclamation, "المتصفح مغلق" End If End Sub واليك المرفق 
بالتوفيق
Database313.accdb

نعم ممكن اليك الكود 
Option Compare Database Option Explicit Private Sub Command2_Click() ExtractImage End Sub Public Sub ExtractImage() Dim Db As DAO.Database Dim Rs_p As DAO.Recordset2 Dim Rs_c As DAO.Recordset2 Dim sPath As String Dim sFile As String sPath = CurrentProject.Path & "\Images\" Set Db = CurrentDb Set Rs_p = Db.OpenRecordset("select * from MsysResources where [type]='img';", dbOpenDynaset) With Rs_p If Not (.BOF And .EOF) Then .MoveFirst MKDir sPath Do Until .EOF Set Rs_c = .Fields("Data").Value sFile = sPath & .Fields("Name") & "." & .Fields("Extension") If Len(Dir$(sFile)) <> 0 Then Kill sFile End If Rs_c.Fields("FileData").SaveToFile sFile Set Rs_c = Nothing .MoveNext Loop MsgBox " : تمت عملية إستخراج الصور الى " & sPath, vbInformation, "تأكيد" End If .Close End With Set Rs_p = Nothing Set Db = Nothing End Sub Public Sub MKDir(ByVal sPath As String) Dim var As Variant, v As Variant Dim sPth As String var = Split(sPath, "\") On Error Resume Next For Each v In var sPth = sPth & v VBA.MKDir sPth sPth = sPth & "\" Next v End Sub سيتم إنشاء مجلد بجانب قاعدة البيانات باسم Images يمكنك تغير اسم المجلد كما تريد وسيتم استخراج كافة الصور و الايقونات من قاعدة البيانات وحفظها في المجلد.
وهذا ملفك مع الكود وتم إضافة ايقونات 2 للتجربة
بالتوفيق
saveimage2.accdb

وعليكم السلام 
تفضل اخي الكريم
Private Sub Cmdshow_Click() Me.txt = "" Me.Form.RecordSource = "" Me.Form.RecordSource = "SELECT * FROM Qtb " Me.Form.RecordSource = "Qtb" End Sub واليك الملف  بعد التعديل
test (2).accdb

السلام عليكم 
تفضل اخي الكريم حسب ما فهمت من طلبك.
Private Sub cmd_add_pic_Click() On Error GoTo ErrHandler If IsNull(Emp_Code) Or Emp_Code = "" Then DoCmd.OpenForm "frmMassage" Forms!frmMassage!lblMassage.Caption = "فضلاً يجب أن تقوم بإدخال كود الموظف حتى تتمكن من إضافة صورة الموظف" Me.Emp_Code.SetFocus Else Dim employees_Photo_Path As String employees_Photo_Path = GetOpenFile_CLT("c:\windows\desktop\", ".حدد مكان الصورة") If employees_Photo_Path <> "" Then Me![Import_pictures_path] = employees_Photo_Path Me![Import_pictures_path] = LCase(Me![Import_pictures_path]) Me![Image].Picture = Me![Import_pictures_path] Dim Project_path As String Project_path = Application.CodeProject.Path Dim EmployeeFolder As String EmployeeFolder = Project_path & "\Images_Company\Employees_Photo\" & Me.Emp_Name If Dir(EmployeeFolder, vbDirectory) = "" Then MkDir EmployeeFolder End If Dim Dir_employees_Photo As String Dir_employees_Photo = EmployeeFolder & "\" & Me.Emp_Code & ".jpg" FileCopy employees_Photo_Path, Dir_employees_Photo Me.TxtImagePath = Dir_employees_Photo Me.Image_d.Visible = False End If End If ErrHandler: If Err.Number = 94 Then Resume Next End If End Sub واليك الملف 
بالتوفيق
test scan4-للمسح من سكانر نوع اوتوماتيك فيدر وبدن تحديد عدد الصور.mdb

جرب التعديل 
Private Sub FindDates_Click() Dim startDateFrom As Date Dim startDateTo As Date Dim endDateFrom As Date Dim endDateTo As Date Dim filterCondition As String If Not IsNull(Me.txtStartFrom) And Not IsNull(Me.txtStartTo) Then startDateFrom = DateValue(Me.txtStartFrom.Value) startDateTo = DateValue(Me.txtStartTo.Value) filterCondition = "(Date1 >= #" & Format(startDateFrom, "yyyy-mm-dd") & "# AND Date1 <= #" & Format(startDateTo, "yyyy-mm-dd") & "#) OR " & _ "(Date2 >= #" & Format(startDateFrom, "yyyy-mm-dd") & "# AND Date2 <= #" & Format(startDateTo, "yyyy-mm-dd") & "#)" End If If Not IsNull(Me.txtEndFrom) And Not IsNull(Me.txtEndTo) Then endDateFrom = DateValue(Me.txtEndFrom.Value) endDateTo = DateValue(Me.txtEndTo.Value) If filterCondition = "" Then filterCondition = "(Date1 >= #" & Format(endDateFrom, "yyyy-mm-dd") & "# AND Date1 <= #" & Format(endDateTo, "yyyy-mm-dd") & "#) OR " & _ "(Date2 >= #" & Format(endDateFrom, "yyyy-mm-dd") & "# AND Date2 <= #" & Format(endDateTo, "yyyy-mm-dd") & "#)" Else filterCondition = filterCondition & " OR " & _ "(Date1 >= #" & Format(endDateFrom, "yyyy-mm-dd") & "# AND Date1 <= #" & Format(endDateTo, "yyyy-mm-dd") & "#) OR " & _ "(Date2 >= #" & Format(endDateFrom, "yyyy-mm-dd") & "# AND Date2 <= #" & Format(endDateTo, "yyyy-mm-dd") & "#)" End If End If If filterCondition <> "" Then Me.Filter = filterCondition Me.FilterOn = True Else Me.FilterOn = False End If End Sub  
بحث.accdb

السلام عليكم اخي الكريم
نعم معك حق .. الدالة لم تكن تعمل بشكل صحيح اليك التعديل
وبالنسبة الى إرجاع الدالة شهرين و-1 يوم بدلاً من 59 يومًا هو أنها تستخدم الدالة DateDiff مع الفاصل الزمني "m"، الذي يحسب عدد أشهر التقويم بين تاريخين وهذا يعني أنه يتجاهل العدد الفعلي للأيام في كل شهر وينظر فقط إلى الفرق بين أجزاء الشهر من التواريخ. على سبيل المثال، الفرق بين 01/07/2024 و01/08/2024 هو شهر واحد، على الرغم من وجود 31 يومًا بينهما.
Function CalculateRemainingPeriod(StartDate As Date, EndDate As Date) As String Dim Years As Long Dim Months As Long Dim Days As Long Dim Result As String Dim TodayDate As Date TodayDate = Date Years = DateDiff("yyyy", TodayDate, [نهاية عقد العمل]) TodayDate = DateAdd("yyyy", Years, TodayDate) Months = DateDiff("m", TodayDate, [نهاية عقد العمل]) TodayDate = DateAdd("m", Months, TodayDate) Days = DateDiff("d", TodayDate, [نهاية عقد العمل]) Result = Years & " years, " & Months & " months, " & Days & " days" CalculateRemainingPeriod = Result End Function الملف بعد التعديل 
التاريخ.accdb

تفضل اخي الكريم هذا الكود لتحويل التقرير إلى صيغة pdf 
Private Sub أمر65_Click() Dim varItem As Variant Dim myWhere As String Dim Criteria As String Dim ReportName As String ReportName = "rap_liste_stagiere_grade_groupe1" Criteria = varItem myWhere = "" ' Loop through the selected items in the ListBox For Each varItem In Me.lst_XX.ItemsSelected ' Add each selected item to the string myWhere = myWhere & "'" & Me.lst_XX.ItemData(varItem) & "', " Next varItem ' Remove the trailing comma and space from the string myWhere = Left(myWhere, Len(myWhere) - 2) DoCmd.OpenReport "rap_liste_stagiere_grade_groupe1", acViewPreview, , "[grade] in (" & myWhere & ")" DoCmd.OutputTo acOutputReport, ReportName, acFormatPDF DoCmd.Close acReport, ReportName, acSaveNo End Sub نفس الكود تستطيع ان تستخدمه في طباعة التقرير مع تغير بسيط في هذا السطر  DoCmd.OutputTo acOutputReport, ReportName, acFormatPDF
بالتوفيق

تفضل اخي الكريم جرب الان هذا التعديل
 

الكنترول المدرسى.mdb

أخي الكريم 
من الخطاء جعل حقل رقم الموظف ترقيم تلقائي لانك ستواجه مشاكل كثيرة في ال TempVars من خلال ال Dlookup.   
اليك هذا التعديل في اكواد المودولات Emp_Var و Module2 
' Emp_Var Module Option Compare Database Option Explicit Public Sub EmpNameVar() Dim EmpNameTemp As Variant If Not IsNull([TempVars]![EmpIdTemp]) And [TempVars]![EmpIdTemp] <> "" Then Dim empId As Long empId = CLng([TempVars]![EmpIdTemp]) EmpNameTemp = DLookup("[emp_name]", "[tblName]", "[emp_code]=" & empId) TempVars.Add "EmpNameTemp", EmpNameTemp End If End Sub Public Function Totalcountt() As Integer Dim x As Integer x = DCount("[emp_code]", "tblName", "[job_Status]=1") Totalcountt = x End Function ' Module2 Option Compare Database Option Explicit Function TotalVac() Dim db As DAO.Database Dim rs As DAO.Recordset Dim rs1 As DAO.Recordset Dim rs2 As DAO.Recordset Dim CountRecord As Integer Dim i, s As Integer Set db = CurrentDb If Not IsNull([TempVars]![EmpIdTemp]) Then Dim empId As String empId = "'" & CStr([TempVars]![EmpIdTemp]) & "'" Set rs = db.OpenRecordset("SELECT * FROM tblVacation WHERE (((tblVacation.EmpCode) = " & empId & " AND (tblVacation.VacationLife) = 'سارية')) ORDER BY vacationstartdate Asc;") Set rs1 = db.OpenRecordset("SELECT * FROM tblVacation WHERE (((tblVacation.EmpCode) = " & empId & " AND (tblVacation.VacationLife) = 'سارية')) ORDER BY vacationstartdate Asc;") On Error Resume Next db.TableDefs.Delete "vac" On Error GoTo 0 Dim strSQL As String strSQL = "SELECT * INTO vac FROM tblVacation " & _ "WHERE (((tblVacation.EmpCode) = " & empId & " AND (tblVacation.VacationLife) = 'سارية')) " & _ "ORDER BY vacationstartdate ASC;" db.Execute strSQL rs.Close Set rs = Nothing rs1.Close Set rs1 = Nothing Else ' (يمكنك إظهار رسالة أو تنفيذ أي إجراء آخر حسب الحاجة) End If Set db = Nothing End Function تأخرت  عليك بالرد لان الوقت عندي متقدم  بستة ساعات عن وقت الدول العربية.
بالتوفيق
الكل.rar

السلام عليكم
حسب ما فهمت جرب 
AVGS24: Round(Avg(IIf([S24] <> 6, [S24], Null)), 0)  

وعليكم السلام 
تفضل اخي الكريم 
عملت الكود حسب الحقول الموجودة في الجدول إذا كان هناك حقل فارغ سيتم حذف السجل نهائيا. جرب ووافنا بالنتيجة
بالتوفيق
Private Sub Form_AfterUpdate() Dim rs As DAO.Recordset Dim strSQL As String Dim Field1, Field2, Field3 As Variant strSQL = "SELECT * FROM aaa" Set rs = CurrentDb.OpenRecordset(strSQL) rs.MoveFirst Do Until rs.EOF Field1 = rs.Fields("Nam").Value Field2 = rs.Fields("Home").Value Field3 = rs.Fields("dats").Value If IsNull(Field1) Or Field1 = "" Or IsNull(Field2) Or Field2 = "" Or IsNull(Field3) Or Field3 = "" Then MsgBox "توجد حقول غير مكتملة ... سوف يتم حذف السجل كليا", vbExclamation, "تنبيه" rs.Delete If Not rs.EOF Then rs.MoveNext End If Else rs.MoveNext End If Loop rs.Close Set rs = Nothing DoCmd.Requery MsgBox " . تمت عملية حذف الحقول الفارغة ", vbInformation, "تمت العملية بنجاح" End Sub وهذا الملف بعد التعديل
program.accdb

السلام عليكم
اليك التعديل هل هو المطلوب ؟
 
S&M_22.rar

وعليكم السلام
تفضل اخي الكريم
Private Sub cmdSearch_Click() Dim strSearch As String Static XC Dim rs As Object Set rs = Me.RecordsetClone Me.أمر26.Visible = False Me.أمر27.Visible = False Me.أمر29.Visible = False Me.أمر30.Visible = False Me.أمر32.Visible = False Me.أمر35.Visible = False If IsNull(Me![txtSearch]) Or (Me![txtSearch]) = "" Then MsgBox "رجاء ادخل اسم للبحث عنه", vbOKOnly, "خطأ في البحث" Me![txtSearch].SetFocus Exit Sub End If strSearch = Me![txtSearch] With rs .FindNext "[emp_nam] like '*" & strSearch & "*'" If Not .emp_nam Like "*" & strSearch & "*" Then MsgBox "لا يوجد سجل بهذا الإسم : " & strSearch, vbCritical, "غير موجود" Me.txtSearch = "" Me![txtSearch].SetFocus ElseIf .NoMatch Then MsgBox "آخر سجل في البحث عن : " & strSearch, vbExclamation, "آخر سجل" Me.cmdSearch.Caption = "بحث" Me.txtSearch = "" Me![txtSearch].SetFocus Me.cmdSearch.ForeColor = RGB(0, 0, 255) Me.أمر26.Visible = True Me.أمر27.Visible = True Me.أمر29.Visible = True Me.أمر30.Visible = True Me.أمر32.Visible = True Me.أمر35.Visible = True DoCmd.GoToRecord , , acFirst rs.MoveFirst XC = 0 Else XC = XC + 1 Me.Bookmark = .Bookmark If XC = 1 Then MsgBox "تم ايجاد اسم : " & strSearch, vbInformation, "مبروك" Me.cmdSearch.Caption = "اكمال البحث" Me.cmdSearch.ForeColor = RGB(255, 0, 0) End If End With rs.Close Set rs = Nothing End Sub وهذا الملف بعد التعديل للعلم انا استخدم الاوفيس 2021 اذا لم يفتح معك الملف فقط انسخ الكود اعلاه وضعه تحت زر البحث ويجب عليك تغير مسميات الزر ونص البحث كما هو في الكود.
تحياتي 
Database2023.accdb

جرب التالي
Me.المبلغ_الاجمالي.DefaultValue = Nz(Form_الطالب.LenaT) - Nz(DSum("[دفع]", "نموذج الترحيل اليدوي", "[المعرف]=" & Form_الطالب.المعرف) - Nz(DSum("[mortaghday]", "نموذج الترحيل اليدوي", "[المعرف]=" & Form_الطالب.المعرف), 0)) واليك الملف ان شاءالله يكون هو المطلوب
11.accdb
المعذرة استاذ قاسم لم انتبه لردك كنت اكتب  الرد وانشغلت بالرد على الهاتف 

جرب هذا التعديل و وافنا بالنتيجة
Private Sub mail_DblClick(Cancel As Integer) Dim Msg As String If IsNull(Mail) Or Len(Mail) = 0 Then MsgBox "حقل البريد الإلكتروني فارغ. الرجاء إدخال عنوان البريد الإلكتروني " Exit Sub End If Msg = "<div style='direction:rtl; font-family:Consolas, Courier;'>" & _ " hey " & namecus & "<br>" & _ "</div>" Dim O As Outlook.Application Dim M As Outlook.MailItem Set O = New Outlook.Application Set M = O.CreateItem(olMailItem) With M .BodyFormat = olFormatHTML .HTMLBody = Msg '.Body = txt - if you see olformatplain .To = Mail '.CC="khate9191@gmail.com;khateb91@outlook.com" '.BCC="hateeb991@gmail.com" .Subject = " new mail " & Now() .Display '.send End With Set M = Nothing Set O = Nothing End Sub تحياتي

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

العملاء 2.accdb

تفضل اخي الكريم
بالتوفيق
Database2.accdb

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

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

السلام عليكم
تفضل هذه المحاولة وبدون اي استعلام بعد إذن الاستاذ @Ahmed.IQ
بالتوفيق
 
بحث شامل2.accdb

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

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

اخى واستاذى الحبيب @Moosak اسعدك الله وبارك فيك وفى علمكم ونتعلم كل يوم منك ومن اساتذتنا الافاضل معاً نكمل مسيرة نشر العلم و نتعلم كل ماهو جديد اعاننا الله جميعا على هذه الثقه فى خدمه اخواننا الكرام

اخى الحبيب حمدى الظابط بارك الله فيك وجزاكم الله خيرا وفقكم الله 
اخي الكريم @TQTHAMI  بارك الله فيك وجزاكم الله خيرا ، شكراً على تشجيعكم وإن شاءالله معا نكمل مسيرة العلم ونتعلم كل ما هو جديد
اخي الكريم  @qathi بارك الله فيك وجزاكم الله خيرا 
تقبلوا تحياتي وتمنياتي بالتوفيق واسال الله لى ولكم ان يكون عملنا خالصا لوجهه الكريم 

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