Klasör içinden isimleri alıp köprü kurma

[darkp]

Merhaba

Ben windows da bulunan bir klasör içindeki .jpeg formatındaki resimlerin isimleri ve oluşturulma tarihlerini (diğer ayrıntılarda olabilir) excel sayfasına yazdırmak istemekteyim . Ayrıca bu isimleredeki resimlere köprü kurmak istemekteyim . Bunu yapabilecek makro örneği için şimdiden siz arkadaşlarıma teşekür ederim .

 

[kubile]

Merhaba

Ben windows da bulunan bir klasör içindeki .jpeg formatındaki resimlerin isimleri ve oluşturulma tarihlerini (diğer ayrıntılarda olabilir) excel sayfasına yazdırmak istemekteyim . Ayrıca bu isimleredeki resimlere köprü kurmak istemekteyim . Bunu yapabilecek makro örneği için şimdiden siz arkadaşlarıma teşekür ederim .

Alt Klasörleri" ve "Alt Klasörlerdeki Tüm Dosyaları" Listeleme
başlığı ile açılmış olan konuyu ve benzeri birçok örneği bu başlık altında takip edebilirsiniz.
Link buradadır: http://www.excel.web.tr/f142/alt-kl...rlerdeki-tum-dosyalary-listeleme-t101323.html
Saygılarımla,

 

[kubile]

Bir başka kaynak dosyayı da hatırlatmak isterim.
Bogachank adlı üyenin 17-08-2011, 13:02 tarihinde paylaşmış olduğu dosyanın içerisinde dosya uzantıları da listelenmektedir.
Buradan sort ederek .jpeg formatındaki dosyaları (veya diğerlerini) listeleyebilirsiniz.

Link: http://www.excel.web.tr/f48/active-directory-de-ki-kullanycy-ad-soyady-yazdyrma-t103523/sayfa3.html

Saygılarımla,

 

[halit3]

Kod:

Dim uzanti As String

Sub Dosya_Listele()
uzanti = InputBox("Veri Alınacak Dosya uzantısını yazınız.", "Dosya uzantısı", "jpg")
If uzanti = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If

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
Columns("A:A").ClearContents
Columns("A:A").Hyperlinks.Delete
Liste (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 Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
If Right(yol, 1) <> "\" Then ekle = "\"
On Error Resume Next
For Each Dosya In fs
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
If Right(Dosya.Name, InStr(1, StrReverse(Dosya.Name), ".", vbTextCompare) - 1) = uzanti Then
Cells(j, "a").Hyperlinks.Add Anchor:=Cells(j, "a"), Address:=yol & ekle & Dosya.Name, TextToDisplay:=Dosya.Name
End If
Next
On Error GoTo sonraki
For Each f In fL
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

 

[dEdE]

Merhaba,

Aşağıdaki kodları bir modüle yapıştırıp deneyiniz.

Sub darkp()
Dim ds, dc, f, f1, f2

Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder("C:\Deneme") 'Dosya yolunu kendinize göre değiştiriniz.
Set dc = f.Files

Cells.Delete Shift:=xlUp
Cells(1, 1).Value = "Dosya Adı"
Cells(1, 2).Value = "Oluşturma Tarihi"
Cells(1, 3).Value = "Değiştirme Tarihi"
Cells(1, 4).Value = "Son Erişim Tarihi"
Cells(1, 5).Value = "Özellik"
Range("A1:E1").Font.Bold = True

Satir = 2
For Each Dosya In dc
    If Right(Dosya.Name, 4) = "jpeg" Then
        Cells(Satir, 1).Value = Dosya.Name
        Set f1 = ds.GetFile("C:\Deneme\" & Dosya.Name) ''Dosya yolunu kendinize göre değiştiriniz.
        Cells(Satir, 2).Value = f1.DateCreated
        Cells(Satir, 3).Value = f1.DateLastModified
        Cells(Satir, 4).Value = f1.DateLastAccessed
            Select Case f1.Attributes
                Case Is = 0: f2 = "Normal"
                Case Is = 1: f2 = "Salt Okunur"
                Case Is = 2: f2 = "Gizli"
                Case Is = 4: f2 = "Sistem"
                Case Is = 8: f2 = "Volume"
                Case Is = 16: f2 = "Directory"
                Case Is = 32: f2 = "Arşiv"
                Case Is = 64: f2 = "Kısayol"
                Case Is = 128: f2 = "Sıkıştırılmış"
            End Select
        Cells(Satir, 5).Value = f2
        
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(Satir, 1), Address:= _
            "C:\Deneme\" & Cells(Satir, 1).Value 'Dosya yolunu kendinize göre değiştiriniz.
        Satir = Satir + 1
    End If
Next
Cells.EntireColumn.AutoFit
End Sub

Not: halit3 hocam önce davranmış ve her zamanki gibi usta işi olmuş. Bizimkisi halit3 hocamın kodları yanında amatör kaldı. Bu kodlardan ben de yararlandım. Kendisine teşekkür ediyorum.

 

[darkp]

Şu anda örnekleri incelemekteyim ama yukardaki code lardan gerekli çözüme ve kaynağa ulaşabileceğime inanmaktayım. Vermiş olduğunuz cevaplar için sizlere tek tek teşekür ederim kubile ,halit3 ve dEdE arkadaşlarım .

 

[anit35]

slm arkadaşlar klörsör için den excel isileri alma ve isimlere köprü kurma
örnek dosya ekte
saygılarımla
alıcılar sayfasını açınca alıcılar kölasör isimlleri listeliyor. firma köprü oluşturması
sedatabdulioğlu