نسخ ملف من فولدر الى فولدر اخر

[الفارس محمد رجب]

السلام  عليكم اخوانى الاعزاء --كل عام وانتم بخير --رمضان كريم علينا وعليكم اجمعين 

مرفق شيت اكسيل به فورم يظهر عند فتح الملف ويوجد بالفورم زرار والمطلوب عند الضغط على الزرار يتم فتح صندوق حوارى لاختيار ملف من على جهاز الكمبيوتر  ثم يتم تحديد الملف اى كان ويتم نسخه الى فولدر موجود فى نفس مكان شيت الاكسيل وشكرا

الارشيف الاكترونى.xlsb

[محمد هشام.]

وعليكم السلام ورحمة الله وبركاته 

نعم يمكنك ذالك . .. نسخ اي امتداد سواءا ملفات اكسيل أو نصوص اوصور. او حتى مقاطع فيديو .ووضعه في نفس مسار الملف المفتوح .

يتبقى لك توضيح نقطة واحدة. هل الفولدر المنسوخ إليه موجود مسبقا أو يتم إنشاءه 

[الفارس محمد رجب]

الاخ العزيز Mohamed Hicham شكرا لك 

الفولدر يتم انشاءه

[محمد هشام.]

تفضل اخي 

 

Private Sub Select_and_Copy_File1_Click()
Dim file As Variant
    Dim copyToFolder As String
    Dim p As Long
    Dim filePath As String
    filePath = Application.ActiveWorkbook.path
    
    file = Application.GetOpenFilename(FileFilter:="جميع الملفات (*.*), *.*", MultiSelect:=False, Title:="حدد الملف المراد نسخه")
    If file = False Then Exit Sub
    
    On Error Resume Next
    MkDir filePath & "\" & "اوفيسنا"
     
     ' إنشاء نسخة في مجلد آخر

    copyToFolder = filePath & "\" & "اوفيسنا"  '
    If copyToFolder <> Left(file, InStrRev(file, "\")) Then
        
        p = InStrRev(file, "\")
        If Right(copyToFolder, 1) = "\" Then p = p + 1
        FileCopy file, copyToFolder & Mid(file, p)
    Else
        'إنشاء نسخة في نفس المجلد - اظافة "نسخة من " الى اسم الملف
        p = InStrRev(file, ".")
        FileCopy file, Left(file, p - 1) & "نسخة من" & Mid(file, p)
      
    End If
MsgBox " :تم نسخ الملف بنجاح في مجلد" & vbLf & vbLf & SvAs & "" & copyToFolder & vbLf & "" & vbLf & ":الفارس محمد رجب" & vbCrLf, vbInformation + vbOKOnly, " ! تعليمات"
    
End Sub

او بهدا الشكل 

Private Sub Select_and_Copy_File_Click()
Dim MH As String, folder As String, p As String, NwPath As String
Dim file As Variant
Dim copyToFolder As String
Set wb = ThisWorkbook
p = wb.Path & "\"

    'هنا قم باختيار اسم المجلد الدي سيتم انشاءه
    
    MH = "اوفيسنا"
    
    NwPath = p & MH
      folder = Dir(NwPath, vbDirectory)
        If folder = vbNullString Then
          VBA.FileSystem.MkDir (NwPath)
          
          
    End If
    
    file = Application.GetOpenFilename(FileFilter:="جميع الملفات (*.*), *.*", MultiSelect:=False, Title:="حدد الملف المراد نسخه")
    If file = False Then Exit Sub
    
    copyToFolder = filePath
        If copyToFolder <> Left(file, InStrRev(file, "\")) Then
          p = InStrRev(file, "\")
            If Right(NwPath, 1) = "\" Then p = p + 1
              FileCopy file, NwPath & Mid(file, p)
    
       
    End If
    
MsgBox " :تم نسخ الملف بنجاح في مجلد" & vbLf & vbLf & SvAs & "" & NwPath & vbLf & "" & vbLf & ":الفارس محمد رجب" & vbCrLf, vbInformation + vbOKOnly, " ! تعليمات"

End Sub

 

 

الارشيف الاكترونى_v2.xlsb

تم تعديل مارس 25, 2023 بواسطه Mohamed Hicham

[الفارس محمد رجب]

الاخ العزيز Mohamed Hicham شكرا لك جزاك الله كل خير وجعله فى ميزان حسناتك

[الفارس محمد رجب]

الاخ العزيز Mohamed Hicham شكرا لك 

لو سمحت ارغب فى كتابة الكود فى حالة ان يتم اختيار  الفولدر المطلوب النسخ اليه 

[محمد هشام.]

تفضل اخي 

Private Sub CommandButton2_Click()
Dim p As String, NwPath As String
Dim file As Variant
Dim copyToFolder As String
Set wb = ThisWorkbook

    'قم بتعديل المسار الخاص بك
    NwPath = "C:\Users\hicham\Documents\test"
      
    
    file = Application.GetOpenFilename(FileFilter:="جميع الملفات (*.*), *.*", MultiSelect:=False, Title:="حدد الملف المراد نسخه")
    If file = False Then Exit Sub
    
    copyToFolder = filePath
        If copyToFolder <> Left(file, InStrRev(file, "\")) Then
          p = InStrRev(file, "\")
            If Right(NwPath, 1) = "\" Then p = p + 1
              FileCopy file, NwPath & Mid(file, p)
    
       
    End If
    
MsgBox " :تم نسخ الملف بنجاح في مجلد" & vbLf & vbLf & SvAs & "" & NwPath & vbLf & "" & vbLf & ":الفارس محمد رجب" & vbCrLf, vbInformation + vbOKOnly, " ! تعليمات"

End Sub

 

الارشيف v3.xlsb