كود نسخ الملفات من فهرس " مجلد " الى آخر

من طرف **SiteAdmin** الثلاثاء يونيو 14, 2011 10:10 am

كود نسخ ملفات من فهرس( مجلد ) الى آخر

لاحظ :

1- تم وضع الكود فى Function ويجب تحديد الفهرس المراد النسخ منه والفهرس
المراد النسخ له وقمنا بافتراض ان المستخدم سيكتبهم فى textbox ولكن يمكنك تغيير ذلك باى اسلوب
تراه مناسبا.

2- سيتحقق الكود من ان
كلا الفهرسين ينتهيان بالعلامة \ واذا لم يكونا
كذلك سيتم اضافتهما الى اسم الفهارس.

3- فى حالة الفهرس
المنسوخ له غير موجود سيتم انشاؤة .

4- اذا كان الفهرس
المنسوخ له موجود فعلا وبه نفس الملفات ، ماذا سيحدث ؟

جرب الكود بنفسك لتعرف
ماذا سيحدث

الكود:: Public Function Copy_Files_Folder(ByRef strFrom_Path As String, ByRef strTo_Path As String) 'Copy all the files in a directory to another' Dim FSO As FileSystemObject Dim strFile As String 'Used to store the files that are found On Error GoTo err_hndl 'Simple check if the path is correct it hase to end with "" else is added If Right$(strFrom_Path, 1) <> "\" Then strFrom_Path = strFrom_Path & "\" If Right$(strTo_Path, 1) <> "\" Then strTo_Path = strTo_Path & "\" 'find the files with the extension as *.* for all files in the current path strFile = Dir(strFrom_Path & "*.*") 'list all the file till dir return empty string Do While Len(strFile) Set FSO = New FileSystemObject With FSO 'check if the new folder exist if not create new one If Not .FolderExists(strTo_Path) Then .CreateFolder (strTo_Path) .CopyFile strFrom_Path & strFile, strTo_Path & strFile 'copy the files in the new directory End With Set FSO = Nothing strFile = Dir 'send the next file to variable File Loop Exit Function err_hndl: MsgBox "Error in Copy_Files_Folder()" & vbCrLf & Err.Number & ": " & Err.Description, vbCritical End Function Private Sub Command1_Click() 'test button click Call Copy_Files_Folder(txtForm_Path.Text, txtTo_Path.Text) End Sub