• DİKKAT

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

Klasör İçeriğini Toplu Yazdırma

U

Utekiner

Katılım
9 Haziran 2019
Mesajlar
221
Excel Vers. ve Dili
Office 2016 Eng.
Merhaba;

Bir klasör içerisinde çok sayıda dosyalar yer almaktadır. (pdf - xls - jpg uzantılı). (50 ile 200 Adet)

Kod yardımı ile toplu yazdırma işlemi yapmak istiyorum.

-İlk adım Klasör seçeneğinin açılması
-İkinci adım ise Sistem üzerindeki çıktıları alacağım yazıcıyı belirlemek istiyorum.

Eğer mümkün ise Sayfanın A:A sutünuna çıktı alınan dosyanın adını yazmasını B:B sütununa ise Çıktı Alındı yazması yapılabilir mi_? Konu hakkında desteğinizi bekliyorum.
Saygılarımla.
 
Merhaba;
Sitede bir kaç örnek var ama sizin isteğinizi karşılayabilir. Sistemde tanımlı yazıcıya otomatik gönderiyor. Başka bir işlem yapmıyor. Sitedeki üstadlar konu hakkında size destek olabilir.
 
Öncelikle dosya isimlerini listeleyin. Sonrasında o belgeleri yazdırın. Ama pdf yazdırmak ve jpg yazdırmak için ayrı kodlar yazmak gerek diye biliyorum.
 
Klasör içindeki dosya uzantılarını .pdf olarak düşününüz.
 
Merhaba;

Konu güncel. Bu şekilde bir şey yapılamıyor mu _? hiç olmadı bir üstad olur yada olmaz diye dönüş yaparsa süper olur.
 
Evde yazıcım olmadığı için deneme şansım olmadı. Siz deneyip sonucu bildirir misiniz?

Kod: 
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
 
Sn. Korhan Bey çok teşekkür ederim her zaman ki gibi hızır gibi yetiştiniz. Yarın sunucu belirteceğim. Evde benimde yazıcım yok.
 
@Korhan Ayhan Bey Selamlar,
Kodu denedim. Kod çalışıyor ama şöyle bir durum var, "Adobe ve OneNote" uygulamalarını otomatik çalıştırıyor. Bunun için bir kodda revize yapılabilir mi_?
 
Merhaba,

Kodu deneme fırsatınız oldu mu?
 
@Korhan Ayhan Bey Merhaba;
Kodu denedim. Adobe Reader açılıyor ve klasör içeriğini yazıyor. @gicimi Bey'in dediği gibi Abode açılmasa olur mu veya açıldığında tüm belgeleri yazdırdıktan sonra adobe programını kapatabilir mi.
 
Merhaba,

#6 nolu mesajımdaki kodu revize ettim. Tekrar deneyip sonucu bildirir misiniz?
 
Korhan Ayhan' Alıntı:
Evde yazıcım olmadığı için deneme şansım olmadı. Siz deneyip sonucu bildirir misiniz?

Kod: 
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
Genişletmek için tıkla ...

Korhan Hocam Selam,

Yazmış olduğunuz kodda güncelleme konusunda destek olabilir misiniz.

Kodu sadeleştirmeye çalıştım ama yapamadım.
Klasör seçimi, Yazıcı Seçimi,
Farklı bir çalışmama eklenti olarak klasör içerisindeki dosyaları yazdırmak istedim.

PHP: 
Option Explicit

Sub Klasordeki_Dosyalari_Yazdir()
Dim Tanimli_Printer As String, Printer_Secimi As Variant
Dim Gorev_Yoneticisi 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
   
    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")
    Wend
       
     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
   
     On Error GoTo 0
   
    Application.ActivePrinter = Tanimli_Printer
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
    MsgBox "Seçtiğiniz klasördeki dosyalar yazdırılmıştır.", vbInformation
   
    End Sub
 
Sadeleştirmekten kastınız nedir?
 
Korhan Hocam,
Klasör seçimi, Yazıcı Seçimi, yapıp çıktı almak istiyorum.
Excele herhangi bir şey yazdırmasına gerek yok.
 
Deneyiniz.

C++: 
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, Say 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
        
    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
        Say = Say + 1
        CreateObject("Shell.Application").Namespace(0).ParseName(Yol & Dosya).InvokeVerb ("Print")
        Dosya = Dir
    Wend
    
    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
    
    Set Klasor = Nothing
    Set Gorev_Yoneticisi = Nothing
    Set Uygulamalar = Nothing
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    If Say = 0 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
 
Teşekkürler…
 
Merhaba ben Excel de A sutunun da yazılan jpg ya da jpeg dosyalarının excelde ki sırayla yazılmasını istiyorum ne yapmam gerek
 

Ekli dosyalar

Bu dosyalar nerede? Dosya yolu belli mi?
 
Printer seçimi yapmak istiyor musunuz?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst