تعديل على أحد الأكواد

[figo82eg]

قام الأخ الكريم @أبو ابراهيم الغامدى بتعديل هذا الكود المرفق والخاص بنقل ملف من مكان الى أخر

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 وهكذا

[محمد أبوعبدالله]

اخي الكريم تجنباً لمثل هذا استخدم رقم عشوائي لاسم الملف بحيث لا يتكرر ولا يتم حذف القديم

وهذا كود لتوليد رقم عشوائي

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

تحياتي

[figo82eg]

 المشكلة اخى الكريم ان الملف المرقم المراد نقله مرتبط بجدول أخر له نفس الترقيم فلا يجوز تغير أسمه إلا بنفس الأسلوب الذى ذكرته مثل ١_١ و ١_٢ و ٢_١ و ٢_٢وهذا 

[محمد أبوعبدالله]

يوجد كود لاستاذنا جعفر يقوم بهذه الوظيفة وهو جزء من الموضوع التالي

ضع الكود التالي في وحدة نمطية جديدة

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

إن واجهتك مشكلة في التطبيق ارفق بنا وارفق مثال ليتم التعديل عليه 🙂

تحياتي

[figo82eg]

أشكركم جميعاَ اساتذتى الكرام على إهتمامكم طبقت المثال أستاذى محمد أبو عبدالله ولكن ظهر مشكلة لدى مرفق مثال لما قد حاولت تنفيذه

 

Desktop.rar

تم تعديل يناير 28, 2021 بواسطه figo82eg

[محمد أبوعبدالله]

الخطأ الذي ظهر كان بسبب السطر التالي

Me.CRN = sSourceFile

وذلك لان حجم حقل CRN = 16

واما sSourceFile فهو نص طويل

لذلك يجب ان يكون الحقل على الاقل = 255 او اجعله مذكرة

وحقيقة لم افهم لماذا تنقل قيمة sSourceFile الى حقل CRN ثم تحذفه من خلال الاستعلام Query2

تحياتي

 

 

[محمد أبوعبدالله]

10 دقائق مضت, محمد أبوعبدالله said:

وحقيقة لم افهم لماذا تنقل قيمة sSourceFile الى حقل CRN ثم تحذفه من خلال الاستعلام Query2

ربما تريد الحصول على الاسم الجديد

اذا كان مرادك ذلك فيكون كالتالي

Me.CRN = File_Pattern & Format(Next_Seq, "_0000.") & File_Type

تحياتي

[figo82eg]

أشكرك أخر استاذى الكريم هو المطلوب بالفعل والمناسب للقاعدة التى أعمل عليها

[jjafferr]

15 ساعات مضت, محمد أبوعبدالله said:

يوجد كود لاستاذنا جعفر يقوم بهذه الوظيفة وهو جزء من الموضوع التالي

ما شاء الله عليك اخوي أبو عبدالله ، يعني مو كفاية انك استعملت البرنامج ، ودخلت وفككت الكود كذلك واخذت الخلاصة منه 🙂

 

جعفر

[محمد أبوعبدالله]

7 دقائق مضت, jjafferr said:

ما شاء الله عليك اخوي أبو عبدالله ، يعني مو كفاية انك استعملت البرنامج ، ودخلت وفككت الكود كذلك واخذت الخلاصة منه 🙂

صدقأ اخي الحبيب انا من اشد المعجب بك وأحاول دائماً الاستفادة من مشاركاتك ... ما شاء الله لا قوة الا بالله

دمت لاخيك

تحياتي

[jjafferr]

حياك الله 🙂

[figo82eg]

استاذنا الكبير جعفر نحن نتعلم منك وحلولك وأكوادك تدرس ماشاء الله

[jjafferr]

حياك الله 🙂

 

الله سبحانه وتعالى وفقني ان اعمل برامج لبعض المؤسسات الكبيرة ، فالكثير من مقاطع شغلي هناك ، اسردها هنا في المنتدى ،

والكثير من اعمالي هنا ، استفيد منها في العمل هناك 🙂

وبين هذا وذاك ، يأتي من يستفيد من هذا وذاك ، والحمدلله 🙂

 

8 ساعات مضت, figo82eg said:

وحلولك وأكوادك تدرس ماشاء الله

تُدرس ، او تُدرّس ؟

 

جعفر