figo82eg قام بنشر يناير 27, 2021 مشاركة قام بنشر يناير 27, 2021 قام الأخ الكريم @أبو ابراهيم الغامدى بتعديل هذا الكود المرفق والخاص بنقل ملف من مكان الى أخر Sub CopyFile() Dim rs As DAO.Recordset Dim fso, sSourceFile, sDestinationFile Set fso = CreateObject("Scripting.FileSystemObject") Set rs = CurrentDb.OpenRecordset("SELECT crn FROM BASIC_DATE") If rs.RecordCount = 0 Then Exit Sub End If rs.MoveFirst Do Until rs.EOF sSourceFile = Application.CurrentProject.Path & "\CONTACT\" & rs!crn & ".pdf" sDestinationFile = Application.CurrentProject.Path & "\CONTACT\old\" '-- تحقق من أن الملف موجود قبل إجراء عملية النسخ If fso.FileExists(sSourceFile) Then fso.CopyFile sSourceFile, sDestinationFile, True fso.DeleteFile sSourceFile End If rs.MoveNext Loop End Sub ولكن فى حالة وجود ملف بنفس الإسم فى الفولدر المنقول اليه يتم حذف الملف الموجود هل فى امكانية لنقل الملف مع وضع إسم أخر له مثال : الملف المراد نقله أسمه 1 اريد عند وجود ملف بنفس الإسم فى فولدر أولد يتم تسميته 1_1 وعند وجود ملف إسمه 1_1 يتم تمسه الملف المنقول الجديد 1_2 وهكذا رابط هذا التعليق شارك More sharing options...
محمد أبوعبدالله قام بنشر يناير 27, 2021 مشاركة قام بنشر يناير 27, 2021 اخي الكريم تجنباً لمثل هذا استخدم رقم عشوائي لاسم الملف بحيث لا يتكرر ولا يتم حذف القديم وهذا كود لتوليد رقم عشوائي Function fnAutoField() As String Dim strRndNo As String strRndNo = Format((999999999 * Rnd) + 1, "0000000000") fnAutoField = strRndNo End Function ويصبح الكود بالشكل التالي Sub CopyFile() Dim rs As DAO.Recordset Dim fso, sSourceFile, sDestinationFile Set fso = CreateObject("Scripting.FileSystemObject") Set rs = CurrentDb.OpenRecordset("SELECT crn FROM BASIC_DATE") Dim XXX As String XXX = fnAutoField() If rs.RecordCount = 0 Then Exit Sub End If rs.MoveFirst Do Until rs.EOF sSourceFile = Application.CurrentProject.Path & "\CONTACT\" & rs!crn & XXX & ".pdf" sDestinationFile = Application.CurrentProject.Path & "\CONTACT\old\" '-- تحقق من أن الملف موجود قبل إجراء عملية النسخ If fso.FileExists(sSourceFile) Then fso.CopyFile sSourceFile, sDestinationFile, True fso.DeleteFile sSourceFile End If rs.MoveNext Loop End Sub تحياتي رابط هذا التعليق شارك More sharing options...
figo82eg قام بنشر يناير 28, 2021 الكاتب مشاركة قام بنشر يناير 28, 2021 المشكلة اخى الكريم ان الملف المرقم المراد نقله مرتبط بجدول أخر له نفس الترقيم فلا يجوز تغير أسمه إلا بنفس الأسلوب الذى ذكرته مثل ١_١ و ١_٢ و ٢_١ و ٢_٢وهذا رابط هذا التعليق شارك More sharing options...
محمد أبوعبدالله قام بنشر يناير 28, 2021 مشاركة قام بنشر يناير 28, 2021 يوجد كود لاستاذنا جعفر يقوم بهذه الوظيفة وهو جزء من الموضوع التالي ضع الكود التالي في وحدة نمطية جديدة Public Function Biggest_Value_in_Folder(ByVal Fldr As String, Pttrn As String, Digts As Integer, fle_Type As String) As Double 'usage: 'Call Biggest_Value_in_Folder("D:\Temp", "EM_New_Section_Letter_Number_", 6, "jpg") Dim strFile As String Dim Digits_Only As String If Len(fle_Type & "") = 0 Then fle_Type = "*" If Right(Fldr, 1) <> "\" Then Fldr = Fldr & "\" strFile = Dir(Fldr & Pttrn & "*." & fle_Type) 'Debug.Print strFile Do Until strFile = "" 'NumberOfFiles = NumberOfFiles + 1 Digits_Only = Replace(strFile, "." & fle_Type, "") Digits_Only = Right(Digits_Only, Digts) If Val(Digits_Only) > Biggest_Value_in_Folder Then Biggest_Value_in_Folder = Val(Digits_Only) End If strFile = Dir() Loop End Function ثم قم بتعديل الكود كالتالي Dim rs As DAO.Recordset Dim fso, sSourceFile, sDestinationFile Set fso = CreateObject("Scripting.FileSystemObject") Set rs = CurrentDb.OpenRecordset("SELECT crn FROM BASIC_DATE") If rs.RecordCount = 0 Then Exit Sub End If rs.MoveFirst Do Until rs.EOF sSourceFile = Application.CurrentProject.Path & "\CONTACT\" & rs!crn & ".pdf" sDestinationFile = Application.CurrentProject.Path & "\CONTACT\old\" '-- تحقق من أن الملف موجود قبل إجراء عملية النسخ If fso.FileExists(sSourceFile) Then Dim MSAccPath As String Dim File_Type As String Dim File_Pattern As String Dim Next_Seq As Double 'make the next backup, by giving it the next sequence number File_Type = Mid(sSourceFile, InStrRev(sSourceFile, ".") + 1) File_Pattern = Mid(sSourceFile, InStrRev(sSourceFile, "\") + 1) File_Pattern = Mid(File_Pattern, 1, Len(File_Pattern) - Len(File_Type) - 1) Next_Seq = Biggest_Value_in_Folder(sDestinationFile, File_Pattern, 4, File_Type) + 1 Destination_File = sDestinationFile & File_Pattern & Format(Next_Seq, "_0000.") & File_Type FileCopy sSourceFile, Destination_File Me.P = sSourceFile fso.DeleteFile sSourceFile End If rs.MoveNext Loop إن واجهتك مشكلة في التطبيق ارفق بنا وارفق مثال ليتم التعديل عليه 🙂 تحياتي رابط هذا التعليق شارك More sharing options...
figo82eg قام بنشر يناير 28, 2021 الكاتب مشاركة قام بنشر يناير 28, 2021 (معدل) أشكركم جميعاَ اساتذتى الكرام على إهتمامكم طبقت المثال أستاذى محمد أبو عبدالله ولكن ظهر مشكلة لدى مرفق مثال لما قد حاولت تنفيذه Desktop.rar تم تعديل يناير 28, 2021 بواسطه figo82eg رابط هذا التعليق شارك More sharing options...
محمد أبوعبدالله قام بنشر يناير 28, 2021 مشاركة قام بنشر يناير 28, 2021 الخطأ الذي ظهر كان بسبب السطر التالي Me.CRN = sSourceFile وذلك لان حجم حقل CRN = 16 واما sSourceFile فهو نص طويل لذلك يجب ان يكون الحقل على الاقل = 255 او اجعله مذكرة وحقيقة لم افهم لماذا تنقل قيمة sSourceFile الى حقل CRN ثم تحذفه من خلال الاستعلام Query2 تحياتي رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد أبوعبدالله قام بنشر يناير 28, 2021 أفضل إجابة مشاركة قام بنشر يناير 28, 2021 10 دقائق مضت, محمد أبوعبدالله said: وحقيقة لم افهم لماذا تنقل قيمة sSourceFile الى حقل CRN ثم تحذفه من خلال الاستعلام Query2 ربما تريد الحصول على الاسم الجديد اذا كان مرادك ذلك فيكون كالتالي Me.CRN = File_Pattern & Format(Next_Seq, "_0000.") & File_Type تحياتي 1 رابط هذا التعليق شارك More sharing options...
figo82eg قام بنشر يناير 28, 2021 الكاتب مشاركة قام بنشر يناير 28, 2021 أشكرك أخر استاذى الكريم هو المطلوب بالفعل والمناسب للقاعدة التى أعمل عليها رابط هذا التعليق شارك More sharing options...
jjafferr قام بنشر يناير 28, 2021 مشاركة قام بنشر يناير 28, 2021 15 ساعات مضت, محمد أبوعبدالله said: يوجد كود لاستاذنا جعفر يقوم بهذه الوظيفة وهو جزء من الموضوع التالي ما شاء الله عليك اخوي أبو عبدالله ، يعني مو كفاية انك استعملت البرنامج ، ودخلت وفككت الكود كذلك واخذت الخلاصة منه 🙂 جعفر 2 رابط هذا التعليق شارك More sharing options...
محمد أبوعبدالله قام بنشر يناير 28, 2021 مشاركة قام بنشر يناير 28, 2021 7 دقائق مضت, jjafferr said: ما شاء الله عليك اخوي أبو عبدالله ، يعني مو كفاية انك استعملت البرنامج ، ودخلت وفككت الكود كذلك واخذت الخلاصة منه 🙂 صدقأ اخي الحبيب انا من اشد المعجب بك وأحاول دائماً الاستفادة من مشاركاتك ... ما شاء الله لا قوة الا بالله دمت لاخيك تحياتي 2 رابط هذا التعليق شارك More sharing options...
jjafferr قام بنشر يناير 28, 2021 مشاركة قام بنشر يناير 28, 2021 حياك الله 🙂 رابط هذا التعليق شارك More sharing options...
figo82eg قام بنشر يناير 28, 2021 الكاتب مشاركة قام بنشر يناير 28, 2021 استاذنا الكبير جعفر نحن نتعلم منك وحلولك وأكوادك تدرس ماشاء الله رابط هذا التعليق شارك More sharing options...
jjafferr قام بنشر يناير 29, 2021 مشاركة قام بنشر يناير 29, 2021 حياك الله 🙂 الله سبحانه وتعالى وفقني ان اعمل برامج لبعض المؤسسات الكبيرة ، فالكثير من مقاطع شغلي هناك ، اسردها هنا في المنتدى ، والكثير من اعمالي هنا ، استفيد منها في العمل هناك 🙂 وبين هذا وذاك ، يأتي من يستفيد من هذا وذاك ، والحمدلله 🙂 8 ساعات مضت, figo82eg said: وحلولك وأكوادك تدرس ماشاء الله تُدرس ، او تُدرّس ؟ جعفر 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان