Klasör içerisindeki Excel dosyalarını yazdırma,

[Utekiner]

Merhaba,

Klasör içerisindeki mevcut tüm excel dosyalarını yazdırmak istiyorum. VBA ile yapılabilir mi_??

Talep,
*** PC kayıtlı yazıcı seçeneklerinin görülmesi ve seçilmesi, ( Birden fazla yazıcı kullanmaktayız.)
*** Klasör seçebilmek için klasör seçeneğinin açılması,
*** xls. ve .xlsm. uzantılı dosyaların yazdırılması,

 

[gicimi]

@Korhan Ayhan Bey'in kodlarına bakarak uyarlama yapabilrsiniz.

Option Explicit

Sub Klasordeki_Dosyalari_Yazdir()
    Dim Tanimli_Printer As String, Printer_Secimi As Variant
    Dim Klasor As Variant, Yol As String, Dosya As String, Satir As Long
    Dim Gorev_Yoneticisi As Object, Uygulamalar As Variant, Uygulama As Object
    
    Tanimli_Printer = Application.ActivePrinter
    
    Printer_Secimi = Application.Dialogs(xlDialogPrinterSetup).Show
    If Printer_Secimi = False Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Range("A:B").Clear
    Range("A1:B1") = Array("DOSYA ADI", "AÇIKLAMA")
    Range("A1:B1").Font.Bold = True
    Satir = 2
    
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör Seçiniz...", 1)
                        
    If Klasor Is Nothing Then Exit Sub
        
    Yol = Klasor.Items.Item.Path & Application.PathSeparator
    
    Dosya = Dir(Yol & "*.*")
    
    While Dosya <> ""
        DoEvents
        CreateObject("Shell.Application").Namespace(0).ParseName(Yol & Dosya).InvokeVerb ("Print")
        Cells(Satir, 1) = Dosya
        Cells(Satir, 2) = "Çıktı Alındı"
        Satir = Satir + 1
        Dosya = Dir
    Wend
    
    Range("A:B").EntireColumn.AutoFit
    
    Application.Wait Now + TimeValue("00:00:10")
    
    Set Gorev_Yoneticisi = GetObject("winmgmts:")
    Set Uygulamalar = Gorev_Yoneticisi.ExecQuery("Select * from Win32_Process")
    
    On Error Resume Next
    
    For Each Uygulama In Uygulamalar
        If InStr(1, Uygulama.Name, "Adobe", vbTextCompare) > 0 Or _
           InStr(1, Uygulama.Name, "OneNote", vbTextCompare) > 0 Then
            Uygulama.Terminate
        End If
    Next
    
    On Error GoTo 0
    
    Application.ActivePrinter = Tanimli_Printer
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    If Range("A2") = "" Then
        MsgBox "Yazdırılacak dosya bulunamadı!", vbExclamation
    Else
        MsgBox "Seçtiğiniz klasördeki dosyalar yazdırılmıştır.", vbInformation
    End If
End Sub

 

[Utekiner]

@Korhan Ayhan Bey Merhaba,
rica etsem kodları güncelleyebilir misiniz.

 

[Korhan Ayhan]

@Utekiner,

Kod zaten sizin istediklerinizi yapıyor. Siz sadece excel dosyalarını yazdırmak istediğinizi ifade etmişsiniz. Kod bu haliyle tüm dosya uzantısı ayırt etmeden yazdırma işlemi yapıyor.

Aşağıdaki kod satırını;

Dosya = Dir(Yol & "*.*")

Bu şekilde değiştirirseniz sadece excel dosyalarını dikkate alarak işlem yapacaktır.

Dosya = Dir(Yol & "*.xls*")