سامي الحداد

الظاهر اننا كنا نكتب في نفس الوفت استادي الفاضل فادي تحياتي لك.

وهذه مشاركتي بالنسبة لــــ كود استعلام التحديث UPDATE [ارقام مسلسله] SET مسلسل = Left([مسلسل], InStr([مسلسل], "/") - 1) & "/" & Year(Date()); ونصيحة نكررها داىما ابتعد عن المسميات باللغة العربية. بالتوفيق

هذا بسبب المتغيرات غير المعلنة المشكلة انه يتم استخدام المتغيرات دون الإعلان عنها باستخدام Dim أو Public أو Private. قم بتعريف كافة المتغيرات قبل استخدامها تحقق من وجود متغيرات غير معلنة، وأخطاء مطبعية، يمكنك استخدام Debug.Print لمعرفة اين الخطاء وايضا في محرر الاكواد استخدم Debug → Compile واليك تعديل بسيط للكود ولكن تأكد اولا من كل المتغيرات في برنامجك. Option Compare Database Option Explicit Private Sub Kind_AfterUpdate() Dim frm As Form If Not IsNull(Me.Kind) Then Set frm = Me.AGR.Form frm!Kind = Nz(Me.Kind, "") Set frm = Nothing End If End Sub بالتوفيق

السلام عليكم مشاركة مع الاساتدة بدون استعلام Private Sub Kind_AfterUpdate() Dim frm As Form If Not IsNull(Me.kind) Then Set frm = Me!AGR.Form frm!kind = Me.kind End If End Sub بالتوفيق Subform (1).accdb

تفضل اخي الكريم حسب ما فهمت نصيحه لا تستعمل مسميات الحقول باللغة العربية لانها تسبب الكثير من المشاكل في الاكواد وقد تم مناقشة الموضوع هنا كثيرا Private Sub FilterMe_Click() Dim strWhere As String strWhere = "[تاريخ التقرير] Between #" & Format(Me.date1, "mm/dd/yyyy") & "# And #" & Format(Me.date2, "mm/dd/yyyy") & "#" DoCmd.OpenForm "Screen_Date", acViewNormal, , strWhere End Sub واليك الملف بالتوفيق data.accdb

وعليكم السلام تفضل أخي حسب ما فهمت Private Sub TXT_AfterUpdate() Dim FormName As String Dim RecordID As String Dim FilterCondition As String FormName = Me.TXT.Value RecordID = Me!ID.Value If Not IsNull(FormName) And Not IsNull(RecordID) Then FilterCondition = "[ID] = " & RecordID DoCmd.OpenForm FormName, , , FilterCondition Else MsgBox " .الرجاء تحديد النموذج والسجل لفتحه ", vbExclamation End If End Sub واليك الملف بالتوفيق فتح نموذج محدد من خلال نموذج فرعي.accdb

مشاركة مع الاخ العزيز @Foksh اليك التعديل والاضافة على الكود Private Sub Del_Click() On Error Resume Next If IsNull(Me.MyList) Then MsgBox "يجب اختيار الملف اولا " & vbNewLine & vbNewLine & " اختـار اسـم الملـف من القائمة", vbCritical + vbMsgBoxRight, "تنبيه" Else Dim sSQL As String Dim aFile As String Dim folderPath As String Dim FDS_path As String Dim fso As Object Dim FileCount As Integer aFile = DLookup("[Attachment_Path]", "[tbl_AttachmentList]", "[Attachment_NO]=[forms]![Attacheds]![MyList]") folderPath = Left(aFile, InStrRev(aFile, "\") - 1) FDS_path = Left(folderPath, InStrRev(folderPath, "\") - 1) If MsgBox("هل تريد حذف المرفق ؟", vbYesNo + vbMsgBoxRight + vbCritical) = vbYes Then Kill aFile Set DB = CurrentDb sSQL = "DELETE FROM tbl_AttachmentList WHERE [Attachment_NO]= " & Me.MyList DB.Execute sSQL MsgBox "تم حذف المرفق ... بنجاح", vbInformation + vbMsgBoxRight, "تأكيد" Me.MyList.Requery Me.Show_Files.Requery Set fso = CreateObject("Scripting.FileSystemObject") If fso.FolderExists(FDS_path) Then DeleteEmptySubfolders fso, FDS_path If fso.GetFolder(FDS_path).Files.Count = 0 And fso.GetFolder(FDS_path).SubFolders.Count = 0 Then fso.DeleteFolder FDS_path, True End If End If Set fso = Nothing End If End If End Sub Private Sub DeleteEmptySubfolders(fso As Object, folderPath As String) Dim folder As Object Dim subFolder As Object Set folder = fso.GetFolder(folderPath) For Each subFolder In folder.SubFolders DeleteEmptySubfolders fso, subFolder.Path If fso.GetFolder(subFolder.Path).Files.Count = 0 And fso.GetFolder(subFolder.Path).SubFolders.Count = 0 Then fso.DeleteFolder subFolder.Path, True End If Next subFolder End Sub والملف بعد التعديل بالتوفيق Lab_2024 - 2.rar

بعد التجربة وجدت ان عملية الحفظ تأخذ وقتا حتى تظهر الرسالة اليك التعديل النهائي وارجو المعذرة لانني كنت في العمل وعملت الكود على عجالة ولم اجربه كفايه. MyArchfa.accdb

تفضل اخي الكريم التعديل شكرا للاخ @Foksh على الملاحظة . MyArchfa.accdb

السلام عليكم مشاركة مع الاستاذ @Foksh جزاه الله خيرا اليك التعديل حسب ما طلبت Private Sub cmdSave_Click() If IsNull(Me.book_Bath) Or Me.book_Bath = "" Then MsgBox "الملف غير محدد" Exit Sub End If SourceFile = Me.book_Bath Dim targetFolder As String If Me.book_Type = "وارد" Then targetFolder = CurrentProject.Path & "\" & "\Files\Wared\" ElseIf Me.book_Type = "صادر" Then targetFolder = CurrentProject.Path & "\" & "\Files\Sader\" Else MsgBox "نوع الكتاب غير معروف" Exit Sub End If If Dir(targetFolder, vbDirectory) = "" Then MkDir targetFolder End If Dim fileExt As String fileExt = Split(SourceFile, ".")(UBound(Split(SourceFile, "."))) DestinationFile = targetFolder & "\" & Me.book_Num & "." & fileExt FileCopy SourceFile, DestinationFile Me.book_Bath = DestinationFile Me.imageType = fileExt MsgBox "تم حفظ الكتاب" Me.Requery End Sub Private Sub ComView_Click() On Error Resume Next If IsNull(book_Num) Then Beep MsgBox "رقم الكتاب مطلوب" Exit Sub End If If IsNull(Me.imageType) Then MsgBox "نوع الصورة مطلوب" Exit Sub End If Dim filePath As String Dim fileName As String Dim foundFilePath As String fileName = Me.book_Num & "." & Me.imageType foundFilePath = FindFile(CurrentProject.Path & "\Files\", fileName) If foundFilePath = "" Then MsgBox "لا يوجد كتاب" Exit Sub End If ShellExecute Me.hwnd, "open", foundFilePath, "", "", 1 End Sub Function FindFile(ByVal folderPath As String, ByVal fileName As String) As String Dim fso As Object Dim folder As Object Dim subFolder As Object Dim file As Object Set fso = CreateObject("Scripting.FileSystemObject") Set folder = fso.GetFolder(folderPath) For Each file In folder.Files If file.Name = fileName Then FindFile = file.Path Exit Function End If Next file For Each subFolder In folder.SubFolders FindFile = FindFile(subFolder.Path, fileName) If FindFile <> "" Then Exit Function Next subFolder Set fso = Nothing Set folder = Nothing Set subFolder = Nothing Set file = Nothing FindFile = "" End Function واليك الملف بعد التعديل بالتوفيق MyArchfa.rar

تفضل استاذ @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 أمر63_Click() DoCmd.SetWarnings False DoCmd.RunSQL "INSERT INTO TBLgiab (MainId, stclass, sttype, StName, remarks, G_date) " & _ "SELECT student.Stno, student.Stclass, student.sttype, student.StName, student.empty, " & _ "[forms]![frmgiab]![Text40] AS Expr1 FROM student WHERE student.ck = True;" DoCmd.RunSQL "UPDATE student SET student.ck = 0, student.Empty = Null;" DoCmd.SetWarnings True Forms![FrmGiab]![نموذج فرعي TBLgiab1].Form.Requery End Sub بالتوفيق

الان انتبهت انك غيرت طلبك . هذا طلبك الاول : وقد رايت كود الاستاذ @AlwaZeeR وهو يعمل بكفاءه. وهدا طلبك الثاني : هل هو المطلوب ام ان هناك تغير ثالث؟ أخي الكريم انت عضو فضي وتعرف قوانين المنتدى . على العموم قمت بتغير الكود للتالي فقط الغي الكود السابق وضع هذا الكود Private Sub Form_Current() Dim Psh As String Dim fileName As String Dim folderPath As String Dim folderName As Variant On Error GoTo Err fileName = [ID] Dim folders() As String folders = Split("picto,picto1,Picto2", ",") For Each folderName In folders folderPath = CurrentProject.Path & "\" & folderName & "\" If Dir(folderPath & fileName & ".jpg") <> "" Then Psh = folderPath & fileName & ".jpg" Exit For ' Exit loop once file is found ElseIf Dir(folderPath & fileName & ".png") <> "" Then Psh = folderPath & fileName & ".png" Exit For End If Next folderName pic.Picture = Psh Exit Sub Err: pic.Picture = "" Exit Sub End Sub تحياتي

وعليكم السلام مشاركة مع الاساتذة بازك الله فيهم هل هذا هو المطلوب ؟ Private Sub Form_Current() Dim Psh As String Dim filePath As String Dim fileName As String On Error GoTo Err fileName = [ID] filePath = CurrentProject.Path & "\picto\" & fileName If Dir(filePath & ".jpg") <> "" Then Psh = filePath & ".jpg" ElseIf Dir(filePath & ".png") <> "" Then Psh = filePath & ".png" Else Psh = "" End If pic.Picture = Psh Exit Sub Err: pic.Picture = "" Exit Sub End Sub والملف بعد التعديل التعامل مع الصور 2.rar

أحسنت وأحسن الله اليك اخي الاستاذ @Foksh بالفعل لقد فاتتني الاشارة الى المكتبات ونسخة 64 لان الاخ @UserUser2 كان بالفعل قد استخدم الطابعة الافتراضية لان ملفه كانت المكتبات موجودة بالفعل ولهذا لم افكر بالامر😄 اشكرك جزيل الشكر اخي الفاضل على هذه الاضافات ربي يسعدك.