Klasördeki Dosya İsimlerini Ve Klasörleri veri tabanına yazma

[ismailerkan15]

Slm
Yardımlarınız İçin Şimdiden Teşekkürler

Bilgisayarımın D: Sürücüsündeki Dosya İsimlerini Ve Bulunduğu Klasörü Dosyaya Yazdırabilmem İcin Kodda yardımcı olursanız Sevinirim.
Dostayken
Dir d:\*.*/s/b Deyip Entere bastığımız vermiş oldugu liste gibi


Tablomuzda

KlasörAdı DosyaAdı Uzantısı Tarihi
--------------------------------- ---------------------------------- ------- ---------- D:\MP3\TR\HALK\ XXXX111XXX111 MP3 01.01.2008
D:\MP3\12\YBC\ XXXXXXXX123112 MP3 03.01.2007
D:\PDF\ERKAN\BEYANAME\ XXXXXXXXXXXXXX MP3 21.01.2008
D:\PDF\ERKAN\TAHAKKUK\ XXXXX111XXXX11X MP3 31.03.2008
Şeklinde

 

[ismailerkan15]

Excel icin yapılım bir kod buldum Bunu Access' uyarlaya bilirmiyiz

'______________________________________________________________________________________________________________
'<<=H=>> <<=S=>> <<=A=>> <<=Y=>> <<=A=>> <<=R=>> <<=™=>> <<==>> <<=www=>> . <<=excel=>> . <<=web=>> . <<=tr=>>|
Public ui As Long '>>|
Sub SubHsr_KlasorIceriginiListele() '>>|
'Seçilen Klasörün ve AltKlasörlerinin içindeki dosyaların yol, isim, değişme zamanı gibi özelliklerini, '>>|
'aktif çalışma sayfasına yazar. '>>|
'Sn. Zeki Gürsoy ve. Sn Haluk'un çalışmalarından Hsayar tarafından derlenmiştir. '>>|
' Çalışması için AnaListe, AltListe ve Dosya Özellikleri prosodürlerinin, '>>|
'bu modülden silinmemiş olması gerekir. '>>|
Dim soru As String '>>|
10 If Application.Workbooks.Count = 0 Then '>>|
11 soru = "Açık Çalışma Kitabı bulunmamaktadır, sizin için yeni çalışma kitabı açılsın mı?" '>>|
12 If MsgBox(soru, vbYesNo) = vbYes Then '>>|
13 Workbooks.Add: GoTo 18 '>>|
14 Else '>>|
15 MsgBox "Açık çalışma kitabı olmadığından çıklacaktır": GoTo 117 '>>|
16 End If '>>|
17 Else '>>|
18 soru = ActiveWorkbook.Name & " kitabının " & ActiveSheet.Name '>>|
19 soru = soru & " sayfasına Dosyalar listelenecektir." & vbLf & "Devam Etmek istiyormusunuz?" '>>|
20 If MsgBox(soru, vbYesNo) = vbYes Then '>>|
21 GoTo 101 '>>|
22 Else '>>|
23 GoTo 117 '>>|
24 End If '>>|
25 End If '>>|
101 Dim klsrSec As Object '>>|
102 Dim klsrMsUstu, dosya, yol As String '>>|
103 Set klsrSec = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1) '>>|
104 klsrMsUstu = CreateObject("WScript.Shell").SpecialFolders("Desktop") '>>|
105 If klsrSec Is Nothing Then GoTo 117 '>>|
106 If klsrSec = "Masaüstü" Or klasor = "Desktop" Then '>>|
107 yol = klsrMsUstu '>>|
108 AnaListe (yol) '>>|
109 AltListe (yol) '>>|
110 ElseIf klsrSec <> "Masaüstü" Then '>>|
111 yol = klsrSec.Items.Item.Path '>>|
112 AnaListe (yol) '>>|
113 AltListe (yol) '>>|
114 Else '>>|
115 GoTo 117 '>>|
116 End If '>>|
117 Set klsrSec = Nothing: ui = 0 '>>|
End Sub '>>|
Private Sub AnaListe(yol As String) '>>|
201 Dim dosya As String '>>|
202 Cells.ClearContents '>>|
203 Range("A1") = "Dosya Yolu": Range("B1") = "Dosya Adı" '>>|
204 Range("C1") = "Dosya Tipi": Range("D1") = "Dosya Boyutu" '>>|
205 Range("E1") = "Oluşturulma Tarihi": Range("F1") = "Son Erişim Tarihi" '>>|
206 Range("G1") = "Son Düzenleme Tarihi": Range("H1") = "Son Düzenleme Zamanı" '>>|
207 dosya = Dir(yol & "\*.*") '>>|
208 ui = 1 '>>|
209 While dosya <> "" '>>|
210 DoEvents '>>|
211 ui = ui + 1 '>>|
212 Cells(ui, 1) = yol '>>|
213 Cells(ui, 2) = dosya '>>|
214 Call DosyaOzellikleri(yol & Application.PathSeparator & dosya) '>>|
215 dosya = Dir '>>|
216 Wend '>>|
End Sub '>>|
Private Sub AltListe(yol As String) '>>|
On Error Resume Next '>>|
301 Dim klsrAra, klsrLst As Object, dosya, dsyTYl As String '>>|
302 Set klsrLst = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders '>>|
303 On Error GoTo 316 '>>|
304 For Each klsrAra In klsrLst '>>|
305 dosya = Dir(klsrAra.Path & "\*.*") '>>|
306 While dosya <> "" '>>|
307 DoEvents '>>|
308 ui = [a65000].End(3).Row + 1 '>>|
309 Cells(ui, 1) = klsrAra.Path & "\" '>>|
310 Cells(ui, 2) = dosya '>>|
311 Call DosyaOzellikleri(klsrAra.Path & Application.PathSeparator & dosya) '>>|
312 dosya = Dir '>>|
313 Wend '>>|
314 AltListe (klsrAra.Path) '>>|
315 Next '>>|
316 Set klsrAra = Nothing: Set klsrLst = Nothing '>>|
End Sub '>>|
Private Sub DosyaOzellikleri(dsyBak As String) '>>|
401 Dim DsSisKnt, Dosyam As Object '>>|
402 Set DsSisKnt = CreateObject("Scripting.FileSystemObject") '>>|
403 Set Dosyam = DsSisKnt.GetFile(dsyBak) '>>|
404 With Dosyam '>>|
405 ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & ui), Address:=dsyBak '>>|
406 Range("C" & ui) = .Type '>>|
407 Range("D" & ui) = Format(.Size / 1024, "#,##0.0000") & " Kb" '>>|
408 Range("E" & ui) = Format(.DateCreated, "dd.mm.yyyy") '>>|
409 Range("F" & ui) = Format(.DateLastAccessed, "dd.mm.yyyy") '>>|
410 Range("G" & ui) = Format(.DateLastModified, "dd.mm.yyyy") '>>|
411 Range("H" & ui) = Format(.DateLastModified, "hh:mm:ss") '>>|
412 End With '>>|
413 Set DsSisKnt = Nothing '>>|
414 Set Dosyam = Nothing '>>|
End Sub '>>|