Combobox a sistemde kurulu yazıcıların listesini getirme

[hsayar]

Yazdır ekranına geçtiğimiz zaman Yazıcı ad kısmında gözüken (sistemde kurulu ) yazıcıların listesini Comboboxa almak mümkün müdür?

 

[Haluk]

Kendinize uyarlarsınız;

Sub PrinterInfo()
    Dim PrinterList As String, oSystem As Object, oPrinter As Object
    Dim i As Single
    '
    Set oSystem = GetObject("winmgmts:").instancesOf("Win32_Printer")
    '
    PrinterList = "Mevcut Printer'lar:" & vbCrLf
    PrinterList = PrinterList & "-----------------------" & vbCrLf
    For Each oPrinter In oSystem
        PrinterList = PrinterList & "Printer" & i + 1 & " = " & oPrinter.Name & vbCrLf
        i = i + 1
    Next
    MsgBox PrinterList, vbInformation, "Rapor !"
    Set oSystem = Nothing
End Sub

 

[hsayar]

Sn Zeki Gürsoy'un bir kodunu buldum

Sub Yazicilar()
Dim Wsh As WshNetwork, a As String, sor As Byte, i As Byte
 
Set Wsh = New WshNetwork
 
'Bilgisayara ait yazıcılar listesi
a = "Varsayılan yazıcıyı değiştirmek ister misiniz?" & Chr(10) & Chr(10) & _
"Değiştirmek isterseniz, 'OK' seçmeden önce bu listede görünen yazıcı kodunu yazın." & Chr(10) & Chr(10)
 
a = a & "Bağlı Yazıcılar..." & Chr(10)
 
For i = 0 To Wsh.EnumPrinterConnections.Count - 1
a = a & Chr(10) & i + 1 & "-) " & Wsh.EnumPrinterConnections(i)
Next
 
sor = Val(InputBox(a, "Excel", 1))
 
If sor = False Then Exit Sub
'Varsayılan yazıcının değişimi
Wsh.SetDefaultPrinter (Wsh.EnumPrinterConnections(sor - 1))
MsgBox "Yazıcı değiştirildi.", vbInformation, "Excel"
End Sub[code]
 
Ancak Benim sistemimde iki yazıcı var HpLazerjet1018 ve xps document writer, bu kodlar 4 adet yazıcı varmış gibi algılayıp
bağlantı noktası, yazıcı olarak Label'e sıralaıyor.
Bana iki adet yazıcı olarak Combobox a almış olanı lazım. yardımcı olabilirseniz sevinirim.

 

[hsayar]

Kendinize uyarlarsınız;

Sub PrinterInfo()
    Dim PrinterList As String, oSystem As Object, oPrinter As Object
    Dim i As Single
    '
    Set oSystem = GetObject("winmgmts:").instancesOf("Win32_Printer")
    '
    PrinterList = "Mevcut Printer'lar:" & vbCrLf
    PrinterList = PrinterList & "-----------------------" & vbCrLf
    For Each oPrinter In oSystem
        PrinterList = PrinterList & "Printer" & i + 1 & " = " & oPrinter.Name & vbCrLf
        i = i + 1
    Next
    MsgBox PrinterList, vbInformation, "Rapor !"
    Set oSystem = Nothing
End Sub

hocam mesajınızı yeni gördüm teşekkür ederim uyarlamaya çalışacağım.

 

[hsayar]

Private Sub UserForm_Initialize()
    Dim PrinterList As String, oSystem As Object, oPrinter As Object
    Dim i As Single
    Set oSystem = GetObject("winmgmts:").instancesOf("Win32_Printer")
CommandButton2.Cancel = True:   TextBox1 = 1
'Aktif Kitaptaki Sayfa Listesini Listbox1 e alır
    For a = 1 To ActiveWorkbook.Sheets.Count
        ListBox1.AddItem Sheets(a).Name
    Next
'Aktif Bilgisayardaki Yazıcı Listesini Combobox1 e alır
    For Each oPrinter In oSystem
        ComboBox1.AddItem oPrinter.Name
    Next
Set oSystem = Nothing
End Sub

Hocam uyarlamasına uyarladıkta seçili olarak varsayılan yazıcı hangisi ise o gelsin demek mümkün mü?

 

[hamitcan]

Ben de Api ile yapılmış bir örnek buldum.

Option Explicit

Const PRINTER_ENUM_CONNECTIONS = &H4
Const PRINTER_ENUM_LOCAL = &H2

Private Declare Function EnumPrinters Lib "winspool.drv" Alias "EnumPrintersA" _
        (ByVal flags As Long, ByVal name As String, ByVal Level As Long, _
        pPrinterEnum As Long, ByVal cdBuf As Long, pcbNeeded As Long, _
        pcReturned As Long) As Long

Private Declare Function PtrToStr Lib "kernel32" Alias "lstrcpyA" _
        (ByVal RetVal As String, ByVal Ptr As Long) As Long

Private Declare Function StrLen Lib "kernel32" Alias "lstrlenA" _
       (ByVal Ptr As Long) As Long


Public Function ListPrinters() As Variant

Dim bSuccess As Boolean
Dim iBufferRequired As Long
Dim iBufferSize As Long
Dim iBuffer() As Long
Dim iEntries As Long
Dim iIndex As Long
Dim strPrinterName As String
Dim iDummy As Long
Dim iDriverBuffer() As Long
Dim StrPrinters() As String

iBufferSize = 3072

ReDim iBuffer((iBufferSize \ 4) - 1) As Long

'EnumPrinters will return a value False if the buffer is not big enough
bSuccess = EnumPrinters(PRINTER_ENUM_CONNECTIONS Or _
        PRINTER_ENUM_LOCAL, vbNullString, _
        1, iBuffer(0), iBufferSize, iBufferRequired, iEntries)

If Not bSuccess Then
    If iBufferRequired > iBufferSize Then
        iBufferSize = iBufferRequired
        Debug.Print "iBuffer too small. Trying again with "; _
        iBufferSize & " bytes."
        ReDim iBuffer(iBufferSize \ 4) As Long
    End If
    'Try again with new buffer
    bSuccess = EnumPrinters(PRINTER_ENUM_CONNECTIONS Or _
            PRINTER_ENUM_LOCAL, vbNullString, _
            1, iBuffer(0), iBufferSize, iBufferRequired, iEntries)
End If

If Not bSuccess Then
    'Enumprinters returned False
    MsgBox "Error enumerating printers."
    Exit Function
Else
    'Enumprinters returned True, use found printers to fill the array
    ReDim StrPrinters(iEntries - 1)
    For iIndex = 0 To iEntries - 1
        'Get the printername
        strPrinterName = Space$(StrLen(iBuffer(iIndex * 4 + 2)))
        iDummy = PtrToStr(strPrinterName, iBuffer(iIndex * 4 + 2))
        StrPrinters(iIndex) = strPrinterName
    Next iIndex
End If

ListPrinters = StrPrinters

End Function
   

'You could call the function as follows:



Sub Test()

Dim StrPrinters As Variant, x As Long

StrPrinters = ListPrinters

'Fist check whether the array is filled with anything, by calling another function, IsBounded.
If IsBounded(StrPrinters) Then
    For x = LBound(StrPrinters) To UBound(StrPrinters)
        'Debug.Print StrPrinters(x)
    ComboBox1.AddItem StrPrinters(x)
    Next x
Else
    ComboBox1.Text = "No printers found"
    'Debug.Print "No printers found"
End If

End Sub



Public Function IsBounded(vArray As Variant) As Boolean

    'If the variant passed to this function is an array, the function will return True;
    'otherwise it will return False
    On Error Resume Next
    IsBounded = IsNumeric(UBound(vArray))

End Function



Private Sub CommandButton1_Click()
Test
End Sub

 

[hsayar]

hamitcan hocam sizin kodu birazdan denyeceğim ama açıkçası gözüm korktu, nasıl alacam ben bu koadların arasından combaya veriyi?

Sub Makro1()
'
' Makro1 Makro
'
'
    Application.ActivePrinter = "Ne00: üzerindeki Microsoft XPS Document Writer "
    Application.ActivePrinter = "Ne01: üzerindeki HP LaserJet 1018 "
    ExecuteExcel4Macro "PRINT(1,,,1,,,,,,,,2,,,TRUE,,FALSE)"
End Sub

Haluk hocam seçili yazıcının Ne?? değerlelerini nasıl bulacağız.

 

[hsayar]

Hamitcan hocam yeni bir kitap açtım ona userform ekleyip kodları arkasına yapıştırdım ama combo boş döndü

 

[hsayar]

Private Sub UserForm_Initialize()
    Dim PrinterList As String, oSystem As Object, oPrinter As Object
    Dim i As Single
    Set oSystem = GetObject("winmgmts:").instancesOf("Win32_Printer")
CommandButton2.Cancel = True:   TextBox1 = 1
'Aktif Kitaptaki Sayfa Listesini Listbox1 e alır
    For a = 1 To ActiveWorkbook.Sheets.Count
        ListBox1.AddItem Sheets(a).Name
    Next
'Aktif Bilgisayardaki Yazıcı Listesini Combobox1 e alır
    For Each oPrinter In oSystem
        ComboBox1.AddItem oPrinter.Name
    Next
Set oSystem = Nothing
End Sub

Hocam uyarlamasına uyarladıkta seçili olarak varsayılan yazıcı hangisi ise o gelsin demek mümkün mü?

hocam ben aşağıda bir kaç kod buldum ama anlayamadım

[FONT=Courier New]set cprtr=getobject("winmgmts:").instancesof ("win32_printer")
for each oprtr in cprtr
    if ((oprtr.attributes or &h04)=oprtr.attributes) then
        wscript.echo "default printer" & vbcrlf & "name:" & vbtab & oprtr.name & vbcrlf & "portname:" & vbtab & oprtr.portname
    else
        wscript.echo "non-default printer" & vbcrlf & "name:" & vbtab & oprtr.name & vbcrlf & "portname:" & vbtab & oprtr.portname
    end if
next
set cprtr=nothing[/FONT]

.portname xps001, usb001 gibi bağlantı noktalırını çevirdi
.attributes ne dediğini anlamadım.

Birde varsayılan(default) yazıcı tesdbiti yapılmış ama nasıl?

bizim şu şekilde sonuç almamız mümkün mü?
"Ne01: üzerindeki HP LaserJet 1018 "

 

[hamitcan]

Hamitcan hocam yeni bir kitap açtım ona userform ekleyip kodları arkasına yapıştırdım ama combo boş döndü

Bir düğmeye bağlamıştım.

Private Sub CommandButton1_Click()
Test
End Sub

 

[hsayar]

hocam ben direk test makrosunu çalıştırmıştım, emeğinize sağlık. Ama bu kodlar neden bu kadar kalabalık ne nereye gidiyor belli değil.
sonuçta haluk hocamla aynı noktadayız.
ne?? kodlarının nasıl bulacağız bunların peki?

 

[tahsinanarat]

Private Declare Function EnumPrintersA Lib "Winspool.drv" _
(ByVal Flags As Long, ByVal name As String, ByVal Level As Long, _
pPrinterEnum As Long, ByVal cdBuf As Long, _
pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function lstrlenA Lib "Kernel32" _
(ByVal lpString As Any) As Long
Private Declare Function lstrcpyA Lib "Kernel32" _
(ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Function Printer()
Dim PrinterEnum() As Long, Impr() As String
Dim Needed As Long, Returned As Long, I As Integer
EnumPrintersA 2, vbNullString, 5, 0, 0, Needed, 0
If Needed = 0 Then Exit Function
ReDim PrinterEnum(Needed / 4)
EnumPrintersA 2, vbNullString, 5, PrinterEnum(0), _
Needed, Needed, Returned
ReDim Impr(1 To Returned)
For I = 1 To Returned
Impr(I) = Space$(lstrlenA(PrinterEnum(I * 5 - 5)))
lstrcpyA Impr(I), PrinterEnum(I * 5 - 5)
Next I
Printer = Impr
End Function
Sub Test()
Dim Impr
Impr = Printer
If IsEmpty(Impr) Then
MsgBox "No Printer", vbCritical
Else
Application.ScreenUpdating = False
Application.ThisWorkbook.Activate
With Range("A1").Resize(UBound(Impr))
.Value = WorksheetFunction.Transpose(Impr)
.Sort [A1]
End With
Columns(1).AutoFit
End If
End Sub

 

[hsayar]

Arkadaşlar ekleyeceğim dosyasının biçim menüsüne eklenen dosyada Toplu yazdır test komutunu çalıştırınca
combobox1 de seçili yazıcıdan Textbox1 de seçili adet kadar yaz komutunu verdirmem için gerekli olna değişiklikler nedir?

 

[hsayar]

Aşağıdaki kodlar ile Combobox1 den seçilen yazıcıdan, textboxta yazılı adet kadar yazdırabiliyorum.
Sormak istediğim Combobox1.value = VarsayılanYazıcı demek mümkün mü?

'#########################################################################################################'
'#########         Aktif Çalışma kitabındaki sayfaları Listboxa alır,                            #########'
'#########         ve seçilenleri Combobox1 deki yazıcıdan,                                      #########'
'#########         Textbox1 deki adet kadar yazdırır.                                            #########'
'#########         [URL="http://www.excel.web.tr/hsayar"]www.excel.web.tr/hsayar[/URL] 29/08/2008-12:30.                                     #########'
'#########################################################################################################'
Private Sub UserForm_Initialize()
CommandButton2.Cancel = True:   TextBox1 = 1
    Dim Wsh As WshNetwork
    Dim i As Single
    Set Wsh = New WshNetwork
'Aktif Kitaptaki Sayfa Listesini Listbox1 e alır
    For i = 1 To ActiveWorkbook.Sheets.Count
        ListBox1.AddItem Sheets(i).Name
    Next
'Aktif Bilgisayardaki Yazıcı Listesini Combobox1 e alır
    For i = 1 To Wsh.EnumPrinterConnections.Count - 1 Step 2
        ComboBox1.AddItem Wsh.EnumPrinterConnections(i)
    Next
'Set oSystem = Nothing
Set Wsh = Nothing
End Sub
Private Sub UserForm_Activate()
Call KlsrDgr
'Dim dsyIco$:  dsyIco = klsrAddIns & AppPthSept & "AddInsResim" & AppPthSept & "A.ico"   'icon yolu
'Call UserformlardaEkOzellik(Me, False, True, True, True, False, True, False, False, True, True, dsyIco)
End Sub
 
Private Sub CommandButton1_Click()
Dim col As New Collection
Dim Wsh As WshNetwork
Dim DefaultPrint As String
'Aktif yazıcıyı değişkene al
DefaultPrint = Application.ActivePrinter
'MsgBox DefaultPrint
With ListBox1
        For i = .ListCount - 1 To 0 Step -1
            If .Selected(i) Then
                Say = Say + 1
                col.Add i
            End If
        Next i
    If Say = 0 Then
        MsgBox "Seçili veri bulunamadı"
        Else
        If MsgBox(Say & " adet Sayfayı Yazdırmak İstiyor musunuz?", vbYesNo) = vbYes Then
            'Yazdır
            For i = 1 To col.Count
                Sheets(ListBox1.List(col.Item(i))).PrintOut _
                Copies:=TextBox1.Value, ActivePrinter:=ComboBox1.Value
            Next i
        End If
    End If
End With
Set col = Nothing
Unload Me
End Sub
Private Sub CommandButton2_Click()
    Unload Me
End Sub
Private Sub Label5_Click()
On Error Resume Next
ActiveWorkbook.FollowHyperlink address:="[URL]http://www.excel.web.tr[/URL]", NewWindow:=True
End Sub
Private Sub SpinButton1_SpinDown()
If TextBox1 = 1 Then        'Textbox1 deki değer 1 e eşitse
    TextBox1 = 1            '1 kalsın
Else                        'Değilse
    TextBox1 = TextBox1 - 1 'Textbox1 deki değeri bir eksilt.
End If
End Sub
Private Sub SpinButton1_SpinUp()
    TextBox1 = TextBox1 + 1 'Textbox1 deki değeri bir artır.
End Sub
'#########################################################################################################'

 

[hsayar]

dosyanın son hali
http://www.excel.web.tr/attachment.php?attachmentid=48015&d=1220158680

 

[mnz]

Tabi dosyanın son hali uçmuş durumda...
Kodları ekleyebilirmisiniz?
Ve ya İstenilen Yazıcıyı varsayılan yapan bir kod rica edebilirmiyim.
Benim bilgisayarımda her seferinde yazıcıyı yeniden varsayılan yapmak gerekiyor.