Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Kasım 2006 Pazartesi

CreateFileList And FileLink




'Module1

Option Explicit
Const Uzantı As String = "*.xls"
Const AnaKlasör As Boolean = True
Dim Yol As String
Dim Büyüklük, Klasör, SonDüzenleme, SonErişim
Dim KlasörNesnesi As Object
Dim DosyaListesi, i As Long
Dim DosyaHafıza() As String, DosyaSayısı As Long
Dim fs, f
Sub CreateFileList_and_FileLink()

On Error GoTo ErrHandler:
Range("A:E").ClearContents
Set KlasörNesnesi = CreateObject("Shell.Application").BrowseForFolder(0, "[PBİD®]Link İçin bir klasör seçin !", 0)
If Not KlasörNesnesi Is Nothing Then
Yol = KlasörNesnesi.Items.Item.Path
DosyaListesi = CreateFileList(Uzantı, False)
For i = 1 To UBound(DosyaListesi)
Cells(i + 1, 1) = Dir(DosyaListesi(i))
Call FileDetails(DosyaListesi(i))
Cells(i + 1, 2) = Büyüklük
Cells(i + 1, 3) = Klasör
Cells(i + 1, 4) = SonDüzenleme
Cells(i + 1, 5) = SonErişim
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 1, 1), Address:=DosyaListesi(i)
Next i
Columns("A:E").AutoFit
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Range("A1").Select
Exit Sub
ErrHandler:
Select Case Err.Number
Case 7
MsgBox "Disket veya CD-ROM/WRITER sürücüsü boş !", vbOKOnly, "[PBİD®] Link Durumu! Toplam Dosya Sayısı: " & VBA.InStr(1, Yol, Application.PathSeparator)
Case 13
MsgBox "Klasorde geçerli *.xls dosyası bulunamadı !", vbOKOnly, "[PBİD®] Link Durumu! Toplam Dosya Sayısı: " & VBA.InStr(1, Yol, Application.PathSeparator)
Case 91
MsgBox "Geçerli bir klasor seçilmedi !", vbOKOnly, "[PBİD®] Link Durumu! Toplam Dosya Sayısı: " & VBA.InStr(1, Yol, Application.PathSeparator)
Case Else
MsgBox "Hata oluştu !" & vbCrLf & vbCrLf & "Hata No: " & Err.Number & vbCrLf & Err.Description, vbOKOnly, "[PBİD®] Link Durumu! Toplam Dosya Sayısı: " & VBA.InStr(1, Yol, Application.PathSeparator)
End Select
Err.Clear
Range("A1:E1").Clear
End If
End Sub
Function CreateFileList(DosyaTipi As String, AnaKlasör As Boolean) As Variant

CreateFileList = ""
Erase DosyaHafıza
With Application.FileSearch
.NewSearch
.LookIn = Yol
.Filename = DosyaTipi
.LastModified = msoLastModifiedAnyTime
.SearchSubFolders = AnaKlasör
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
ReDim DosyaHafıza(.FoundFiles.Count)
For DosyaSayısı = 1 To .FoundFiles.Count
DosyaHafıza(DosyaSayısı) = .FoundFiles(DosyaSayısı)
Next DosyaSayısı
End With
CreateFileList = DosyaHafıza
Erase DosyaHafıza
End Function
Sub FileDetails(DosyaYolu)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(DosyaYolu)
Büyüklük = f.Size / 1024
Klasör = f.ParentFolder
SonDüzenleme = Format(f.DateLastModified, "dd.mmmm.yyyy")
SonErişim = Format(f.DateLastAccessed, "dd.mmmm.yyyy")
Set f = Nothing
Set fs = Nothing
End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul