Excel Klasör İçindeki Tüm Dosyaları Yazdır

[ridvanucok]

Merhaba,

Klasör içerisinde yer alan (.rtf,.doc,.docx,.pdf,.tiff,.xlsx v.s) dosya uzantılarının excel makro ile toplu olarak yazdırılabilmesi mümkün mü?

Değerli bilgi ve yönlendirmelerinizi rica ederim.

Saygılarımla, iyi çalışmalar.

 

[Haluk]

Yazdırılması istenilen; dosyaların adları mı, uzantıların isimleri mi, dosyaların yazıcıya gönderilerek çıktılarının alınması mı?

 

[Haluk]

Aşağıdaki kodlardan hangisi işinize yarıyorsa, kendinize göre uyarlayabilirsiniz.

Declare Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'
Sub DosyalarıYazdir()
    Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
    Set Klasor = DosyaSistemi.GetFolder("C:\DenemeKlasoru")
    Set Dosyalar = Klasor.Files
    For Each Dosya In Dosyalar
        x = apiShellExecute(Application.hwnd, "print", Dosya, vbNullString, vbNullString, 0)
    Next
End Sub
'
Sub DosyaOzellikleri()
    Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
    Set Klasor = DosyaSistemi.GetFolder("C:\DenemeKlasoru")
    Set Dosyalar = Klasor.Files
    For Each Dosya In Dosyalar
        i = i + 1
        Range("A" & i) = Dosya.Name
        Range("E" & i) = Dosya
        Range("I" & i) = DosyaSistemi.GetExtensionName(Dosya)
        Range("K" & i) = Format(Dosya.Size / 1024, "#.00") & " Kb"
        Range("M" & i) = Dosya.DateCreated
    Next
End Sub

 

[ridvanucok]

Aşağıdaki kodlardan hangisi işinize yarıyorsa, kendinize göre uyarlayabilirsiniz.

Declare Function apiShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'
Sub DosyalarıYazdir()
    Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
    Set Klasor = DosyaSistemi.GetFolder("C:\DenemeKlasoru")
    Set Dosyalar = Klasor.Files
    For Each Dosya In Dosyalar
        x = apiShellExecute(Application.hwnd, "print", Dosya, vbNullString, vbNullString, 0)
    Next
End Sub
'
Sub DosyaOzellikleri()
    Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
    Set Klasor = DosyaSistemi.GetFolder("C:\DenemeKlasoru")
    Set Dosyalar = Klasor.Files
    For Each Dosya In Dosyalar
        i = i + 1
        Range("A" & i) = Dosya.Name
        Range("E" & i) = Dosya
        Range("I" & i) = DosyaSistemi.GetExtensionName(Dosya)
        Range("K" & i) = Format(Dosya.Size / 1024, "#.00") & " Kb"
        Range("M" & i) = Dosya.DateCreated
    Next
End Sub

Üstadım,

64 bit sürüm uyumsuzluğu var şuan, birkaç deneme yapıp kodları deneyeyim.

İlginiz için teşekkür ederim.