Klasör içerisinden dosyaları kopyalama

[ASLAN7410]

Merhaba, herkese hayırlı akşamlar.

Ekte gönderdiğim excel dosyası içerisindeki kod aşağıdaki linkteki
13.mesajındaki Halit Bey'in yazmış olduğu kodlardır.

Kodu çalıştırdığımda klasör içerisindeki değişik klasör içerisindeki
dosyaları kopyalıyor.

Benim istediğim butona bastığımda ekrana gelen diyalog penceresinin
değiştirilmesini istiyorum, bu şekilde istememin sebebi masa üzerindeki
kısayolları görmüyor olması, kısayollarda ağ kısayollarıdır, kod içerisinde değişiklik yapmaya çalıştım ancak hep hata verdi.

Yardımcı olur musunuz?

http://www.excel.web.tr/f48/makro-ile-dosya-kopyalama-t74940/sayfa2.html

 

[ASLAN7410]

Arkadaşlar aslında benim yapmak istediğim, butona bastığımda ekrana
gelen pencere içerisinden seçmiş olduğum klasör içindeki alt klasörler
içerisindeki bütün dosyaları yine belirleyeceğim bir klasör içerisine sadece
dosyaları kopyalamak istiyorum.

Butona bastığımda ekrana gelen pencerede aşağıdaki resimdeki kısayol yok,
bu kısayolda ağ içerisinde bulunuyor.

 

[halit3]

kod:

Dim Kaynak2
Sub Dosyaları_kopyala()

masa = StrMyDesktop = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Kaynak Dosyaları İçeren Klasörü Seçin"
.InitialFileName = masa
.AllowMultiSelect = False
If .Show <> -1 Then MsgBox "Kaynak klasörü seçmesiniz.": GoTo atla
GetFolder = .SelectedItems(1)
kaynak = .SelectedItems(1)
End With

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Hedef Klasörü Seçin"
.InitialFileName = masa
.AllowMultiSelect = False

If .Show <> -1 Then MsgBox "Hedef klasörü seçmesiniz.": GoTo atla
GetFolder = .SelectedItems(1)
Kaynak2 = .SelectedItems(1)

End With

Liste (kaynak)

MsgBox "işlem tamam"
atla:
End Sub


Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

If Right(yol, 1) <> "\" Then ekle = "\"
For Each Dosya In fL.GetFolder(yol).Files
eski = fL.GetFile(Dosya)
yeni = Kaynak2 & "\" & fL.GetFileName(Dosya)
FileCopy eski, yeni
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

End Sub

 

[ASLAN7410]

Sayın Halit Bey, tam istediğim gibi olmuş, ellerinize sağlık, çok teşekkür ediyorum.


Hayırlı günler hayırlı çalışmalar diliyorum.

 

[halit3]

Teşekkürler iyi çalışmalar