• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Dosya sayfa sayısı alma

C

cigerkarakaya

Katılım
22 Kasım 2012
Mesajlar
60
Excel Vers. ve Dili
2007 Türkçe
Halit3 Arkadaşımızın hazırladığı makro sayesinde klasör içerisindeki dosya isimlerini dosyanın yoluyla birlikte alıyoruz, 2. ve 3. sütunlarda da dosyaların boyut bilgilerini elde ediyoruz.
Dosyaların boyut bilgilerinin yanı sıra, oluşturma tarihi, değiştirme tarihi ve sayfa sayısı gibi bilgileri de eklemek için koda nasıl bir ekleme yapmamız gerekir?

http://www.excel.web.tr/f142/alt-kl...m-dosyalary-listeleme-t101323/post675386.html

Kod: 
Sub Dosya_Listele()
Columns("A:C").ClearContents
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Liste2 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste2(yol As String)
Dim fL As Object, f As Object, Dosya As String, j As Long
Dim ekle
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Dosya = Dir(yol & "\*.*")
While Dosya <> ""
DoEvents
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
ekle = ""
If Right(yol, 1) <> "\" Then ekle = "\"
Cells(j, 1).Value = yol & ekle & Dosya
On Error Resume Next
With CreateObject("Scripting.FileSystemObject").GetFile(yol & ekle & Dosya)
Cells(j, 2).Value = Format(.Size / 1024, "#,##0.000") & " Kb"
Cells(j, 3).Value = Format(.Size, "#,###")
End With
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
kod:

Kod: 
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Sub dosyaListele()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Cells.ClearContents
Range("A1") = "Dosya Yolu"
Range("B1") = "Dosya Adı"
Range("C1") = "Dosya Tipi"
Range("D1") = "Dosya Boyutu"
Range("E1") = "Oluşturulma Tarihi"
Range("F1") = "Son Erişim Tarihi"
Range("G1") = "Son Düzenleme Tarihi"
Range("H1") = "Son Düzenleme Zamanı"
Range("I1") = "Süre"
Range("J1") = "Sayfa Sayısı"
AltListe (Kaynak)
MsgBox "işlem tamam !", vbInformation, "DİKKAT"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
Hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub
Private Sub AltListe(yol As String)
Dim yer As String
Dim lRet As Long
Dim sReturn As String
Dim iMin As Integer
Dim iSec As Integer
Dim iSat As Integer

Dim klsrAra, klsrLst As Object, Dosya
Set klsrLst = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
Dosya = Dir(yol & "\*.*")
While Dosya <> ""
DoEvents
sat = [a65000].End(3).Row + 1
Cells(sat, 1) = yol
Cells(sat, 2) = Dosya
On Error Resume Next
With CreateObject("Scripting.FileSystemObject").GetFile(yol & "\" & Dosya)
'ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & sat), Address:=yol & "\" & Dosya
Range("C" & sat) = .Type
Range("D" & sat) = Format(.Size / 1024, "#,##0.0000") & " Kb"
Range("E" & sat) = Format(.DateCreated, "dd.mm.yyyy")
Range("F" & sat) = Format(.DateLastAccessed, "dd.mm.yyyy")
Range("G" & sat) = Format(.DateLastModified, "dd.mm.yyyy")
Range("H" & sat) = Format(.DateLastModified, "hh:mm:ss")
End With

Dosya_adi = yol & "\" & Dosya
yer = Space$(255)
lRet = GetShortPathName(Dosya_adi, yer, Len(yer))
If lRet <> 0 Then
Dosya_adi = Left$(yer, InStr(yer, vbNullChar) - 1)
End If
mciSendString "open " & Dosya_adi & " type MPEGVideo alias mp3audio", 0, 0, 0
sReturn = Space$(256)
lRet = mciSendString("status mp3audio length", sReturn, Len(sReturn), 0&)
mciSendString "close mp3audio", 0, 0, 0
iSec = Int(Val(sReturn) / 1000)
iMin = Int(iSec / 60)
iSec = iSec - (iMin * 60)
If iMin > 59 Then
iSat = Int(iMin / 60)
iMin = iMin - (Int(iMin / 60) * 60)
End If
Range("I" & sat) = Format$(iSat, "00") & ":" & Format$(iMin, "00") & ":" & Format$(iSec, "00")
 
On Error Resume Next
sat1 = 0
Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
Dosya_Yolu = (yol & "\" & Dosya)
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya_Yolu & ";"
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then
sat1 = sat1 + 1
End If
End If
End If
End If
End If
Next
Set Data = Nothing
Set Katalog = Nothing
Range("j" & sat) = sat1
 
Dosya = Dir
Wend
On Error GoTo sonraki
For Each klsrAra In klsrLst
Call AltListe(klsrAra.Path)
sonraki:
Next
End Sub
 
Ayrıca bana tam olarak gerekli olanlar Dosya Yolu, Dosya Adı, sayfa sayısı, oluşturma tarihi, son düzenleme tarihi
 diğerleri gereksiz kalıyor
 
İlgin için teşekkür ederim halit3. Ekte göndermiş oluduğun "aaaaaaaaaaa" klasörünün içindeki excel dosyalarının hepsinin sayfa sayısını veriyor haklısın. Fakat .tif uzantılı imajlarımın sayfa sayısı yine "0" olarak kalıyor.
 
cigerkarakaya' Alıntı:
İlgin için teşekkür ederim halit3. Ekte göndermiş oluduğun "aaaaaaaaaaa" klasörünün içindeki excel dosyalarının hepsinin sayfa sayısını veriyor haklısın. Fakat .tif uzantılı imajlarımın sayfa sayısı yine "0" olarak kalıyor.
Genişletmek için tıkla ...

Excellde .tif uzantılı dosya mevcutmu ?
 
Excell'de öyle birşey yok bildiğim kadarıyla. Benim istediğim zaten seçtiğim klasör içerisindeki .tif, .pdf vesair gibi dosyaların sayfa sayısını almak. Özellikle .tif uzantılı imajların sayfa sayısını.
 
cigerkarakaya' Alıntı:
Excell'de öyle birşey yok bildiğim kadarıyla. Benim istediğim zaten seçtiğim klasör içerisindeki .tif, .pdf vesair gibi dosyaların sayfa sayısını almak. Özellikle .tif uzantılı imajların sayfa sayısını.
Genişletmek için tıkla ...

Bu konuda bir fikrim yok
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst