- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
-
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
[ÇÖZÜLDÜ] Dosyanın bulunduğu sürücünün SerialNumber, RootPath, DiskType, Name Bilgilerini öğren
Aşağıdaki kodlar ile Sürücü/Klasör içersindeki dosyaların "Dosya Yolu", "Dosya Adı", "Dosya Tipi", "Dosya boyutu" , "Oluşturulma Tarihi", "Son Erişim Tarihi", "Son Düzenleme Tarihi", "Son Düzenleme Zamanı gibi bilgileri alıyorum. bunlara ilaver olarak Dosyanın bulunduğu sürücünün SerialNumber, RootPath, DiskType, Name Bilgilerini (En alttaki Resimlerdeki biligler) öğren I-J-K-L sütunlarına yaz demek mümkün müdür?
Aşağıdaki kodlar ile Sürücü/Klasör içersindeki dosyaların "Dosya Yolu", "Dosya Adı", "Dosya Tipi", "Dosya boyutu" , "Oluşturulma Tarihi", "Son Erişim Tarihi", "Son Düzenleme Tarihi", "Son Düzenleme Zamanı gibi bilgileri alıyorum. bunlara ilaver olarak Dosyanın bulunduğu sürücünün SerialNumber, RootPath, DiskType, Name Bilgilerini (En alttaki Resimlerdeki biligler) öğren I-J-K-L sütunlarına yaz demek mümkün müdür?
Kod:
'______________________________________________________________________________________________________________
'<<=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=>>|
'¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨'