سامي الحداد

ماشاءالله عمل رائع وجميل بارك الله فيك اخي فادي

السلام عليكم اخي @Ahmos عمل رائع سلمت يداك

الف مبروك اخي العزيز @Ahmos انضمامك لفريق الخبراء تستأهل اكثر تحياتي لك

الف الف مبروك أخي الفاضل فادي تستاهل وبجدارة اللقب على ما تقدمه دائما لهذا الصرح الكبير تحياتي لك

السلام عليكم مشاركة مع الاستاذ @Moosak تعديل بسيط على الكود عسى ان يكون هو المطلوب بالتوفيق ta13.rar

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

وهذه مشاركتي بالنسبة لــــ كود استعلام التحديث 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