Bilgisayardaki klasörleri listelemek ve bunlara link vermek

[darzamat]

Merhaba Arkadaşlar,

Aranıza yeni katıldım. Makro bilgim yok. Ancak yarım saat kadar forumu araştırarak bu işin temelini kavradım sayılır. En azından makro kodlarını çalıştırmayı öğrendim. Ayrıca yapmak istediğim şeyin de bir makro kodu ile yapılabileceğini tahmin ediyorum. Sorum şu:

Elimde onlarca alt klasörden oluşan yüklü bir database var. Ana klasörün adı 1 olsun. 1'in altında A, B, C isimli 3 klasör var. Bunların da her birisinin içinde A1, A2, A3... gibi klasörler ve bunların içinde de A1-1, A1-2... gibi çeşitli dosyalar var (jpg'ler, pdf'ler, exceller vs). Bu böyle sürüp gidiyor.

Ben tek bir excel dosyasında bunları listeletmek ve excelde listelenen dosya ismine tıkladığımda ilgili dosyanın/klasörün açılmasını istiyorum (tüm hücrelerde köprü olacak). Yani listelemeyi yaparken o dosyanın yolunu da köprü olarak oluşturacak bu makro.

Ekte kafamdaki klasörleme sistemini de örnek olması için veriyorum. Databasedeki dosyaları bu şekilde bir ağaç gibi listelemem mümkün olabilir mi?

Office 2010 kullandığımı da ekleyeyim. Yardımlarınızı merakla bekliyorum.

 

[Korhan Ayhan]

Merhaba,

Ekteki örnek dosyayı incelermisiniz. Listeleme sizin istediğiniz ağaç biçiminde değilde alt alta yapılıyor.

 

[darzamat]

Sayın Korhan Ayhan, öncelikle ilginize çok teşekkür ederim. Soruyu sorduktan sonra, dünden beri epey araştırma yaptım. Aşağıdaki koda ulaştım ve bu kod işimi gördü. Tabi isteklerin sonu yok. Bu kod üzerinde de şöyle böyle olsa dediğim şeyler var. Mesela kod ile linkini aldığım bir jpg dosyasına tıkladığımda explorerda açılıyor. Keşke bilgisayarda kullandığım default jpg görüntüleyicide açılsaydı resimler.

Bir de acaba excel üzerinde aşağıdaki kod ile görüntülediğim dosyaların dosya isimlerini yine bu excel içinden değiştirme imkanım olur mu onu merak ediyorum. Bu konuda bilginiz var mı acaba?

'______________________________________________________________________________________________________________
'<<=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 '>>|
'Felâket başa gelmeden evvel, onu önleyecek ve ona karşı savunulacak gerekleri düşünmek lâzımdır. '>>|
'Geldikten sonra dövünmenin faydası yoktur.ATATÜRK '>>|
'<<=H=>> <<=S=>> <<=A=>> <<=Y=>> <<=A=>> <<=R=>> <<=™=>> <<==>> <<=www=>> . <<=excel=>> . <<=web=>> . <<=tr=>>|
'¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨'

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki linklerde benzer konular işlenmiş. İncelermisiniz.

DOSYA VE KLASÖR İŞLEMLERİ
MP3 DOSYALARINI TOPLU OLARAK DEĞİŞTİRMEK