Tabloda Dosya Uzantısı Yazılı Olanları Kopyala

Sn üstadlarim kolay gelsin.
Aşağıdaki kod ile bir dosyayı istedigim klasöre farklı bir adla kayıt yapıyorum.
Benim şuan yapmaya çalıştığım ise, Yedekle tablosunda dosya yolu ve adı yazılı 2 tane dosyam var. Bu dosyaları butona tıklamak suretiyle ikisinide tarih ve saati başına ekleyerek istediğim klasöre kaydetmesi.
Aşağıdaki koda nasıl bir ekleme yaparak bu işlemi tek tıklamayla çözebilirim.
Yardım ve önerileriniz için şimdiden teşekkürler.

Dim fso As Object
Dim kaynakDosya As String
Dim HedefDosya As String
Set fso = CreateObject("Scripting.FileSystemObject")
kaynakDosya = KaynakDosyaAdresiveAdi
HedefDosya = hedefKlasor & "\"  & yeniad & ".png"
fso.MoveFile kaynakDosya, HedefDosya
Set fso = Nothing

Yeniad=date() & time() & yeniad
Yukardai şekilde dener mısınız?

Tabloda iki tane kayıt var. Dosya yolu ve adı yazılı. Bu iki dosyayida aynı anda kopyalamak istiyorum.

For döngüsü ile tüm kayıtları ekleyebilrsiniiz

Sn hocam,
kullandığım form aşağıda,
listedeki yedekveritabı alanındaki dosyayı yedekklasor alanındaki dizine kopyalayacak.

kodu aşağıdaki ile değiştirip dener misiniz?

'hy taşı__________________________

Dim DosyaRs As New ADODB.Recordset

Dim sOrGu As String



Dim fso As Object

Dim kaynakDosya As String

Dim HedefDosya As String

Set fso = CreateObject("Scripting.FileSystemObject")



sOrGu = "select * from YEDEKLEME" 'tablo seç

    DosyaRs.Open sOrGu, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

If DosyaRs.RecordCount = 0 Then Exit Sub

    Do While Not DosyaRs.EOF

        kaynakDosya = DosyaRs.Fields(1)

    yeniad = Date & "_" & Format(Time(), "hh.nn.ss") & "_" & Mid(Replace(DosyaRs.Fields(1), ".png", ""), InStrRev(DosyaRs.Fields(1), "\") + 1)

    Debug.Print Mid(Replace(DosyaRs.Fields(1), ".png", ""), InStrRev(DosyaRs.Fields(1), "\") + 1)

    HedefDosya = Me.yedeklasor & "\" & yeniad & ".png"

    fso.MoveFile kaynakDosya, HedefDosya

        DosyaRs.MoveNext

    Loop

Set fso = Nothing

'hy taşı__________________________Bitti