mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Получение списка доступных принтеров средствами VB (VBA)

Данный код выводит список всех установленных в системе принтеров:

Sub ПолучениеСпискаПринтеров()
    Set AllPrinters = GetObject("winmgmts://./root/CIMV2").ExecQuery("SELECT * FROM Win32_Printer", , 48)
    For Each printer In AllPrinters
       n = n + 1: Debug.Print "Принтер №" & n & ": " & printer.Name
    Next
    Debug.Print "Всего принтеров: " & n
End Sub

Результат работы макроса:

Принтер №1: PDFCreator
Принтер №2: Microsoft XPS Document Writer
Принтер №3: Microsoft Office Document Image Writer
Принтер №4: \\192.168.0.1\Samsung ML-2010 Series
Всего принтеров: 4

===================================
Ещё один вариант того же макроса (у меня он работает намного быстрее первого варианта):

Sub ПолучениеСпискаПринтеров_версия2()
    With CreateObject("Shell.Application").NameSpace(4).Items
        For n = 1 To .Count - 1
            Debug.Print "Принтер №" & n & ": " & .Item(n).Name
            Debug.Print vbTab & "Путь к принтеру №" & n & ": " & .Item(n).Path
        Next
        Debug.Print "Всего принтеров: " & .Count - 1
    End With
    Debug.Print "Активный принтер: " & Application.ActivePrinter
End Sub

Результат работы макроса:

Принтер №1: PDFCreator
Путь к принтеру №1: PDFCreator
Принтер №2: Microsoft XPS Document Writer
Путь к принтеру №2: Microsoft XPS Document Writer
Принтер №3: Microsoft Office Document Image Writer
Путь к принтеру №3: Microsoft Office Document Image Writer
Принтер №4: Samsung ML-2010 Series на 192.168.0.1
Путь к принтеру №4: \\192.168.0.1\Samsung ML-2010 Series
Всего принтеров: 4
Активный принтер: PDFCreator on NE03:

========================================
Данный код позволяет активировать виртуальный PDF-принтер в Microsoft Word:
(в случае успешной активации функция возвращает TRUE)

Function ActivatePDFprinter() As Boolean
    If Application.ActivePrinter Like "*PDF*" Then ActivatePDFprinter = True: Exit Function
    On Error Resume Next: Err.Clear
    With CreateObject("Shell.Application").NameSpace(4).Items
        For n = 1 To .Count - 1
            ИмяПринтера = .Item(n).Name
            If ИмяПринтера Like "*PDF*" Then
                Application.ActivePrinter = ИмяПринтера
                ActivatePDFprinter = True: Exit For
            End If
        Next
    End With
    If Not (Application.ActivePrinter Like "*PDF*") Then
        MsgBox "Не найден виртуальный принтер для печати в ПДФ", vbExclamation
    End If
    If Err Then MsgBox "Не удалось активировать виртуальный принтер для печати в ПДФ", vbExclamation
End Function

ВНИМАНИЕ: Для Microsoft Excel код будет немного другим (там принтеры именуются несколько иначе)

Данный код позволяет активировать виртуальный PDF-принтер в Microsoft Excel:
(в случае успешной активации функция возвращает TRUE)

Function ActivatePDFprinter() As Boolean
    If Application.ActivePrinter Like "*PDF*" Then ActivatePDFprinter = True: Exit Function
    On Error Resume Next: Err.Clear
    With CreateObject("Shell.Application").Namespace(4).Items
        For n = 1 To .Count - 1
            ИмяПринтераExcel = .Item(n).Name & " (Ne" & Format(n - 1, "00") & ":)"
            If ИмяПринтераExcel Like "*PDF*" Then
                Application.ActivePrinter = ИмяПринтераExcel
                ActivatePDFprinter = True: Exit For
            End If
        Next
    End With
    If Not (Application.ActivePrinter Like "*PDF*") Then
        MsgBox "Не найден виртуальный принтер для печати в ПДФ", vbExclamation
    End If
    If Err Then MsgBox "Не удалось активировать виртуальный принтер для печати в ПДФ", vbExclamation
End Function

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Ну и зачем нужен этот огромный макрос с доп. функциями,
который, ко всему прочему, не будет работать в 64-битной версии Office?

Когда оба моих макроса из 5 строк выдают тот же самый результат...

должно работать в любой версии Excel, видоизменить на то чтоб выбирал на печать нужный, а потом возвращал установленный ранее на основе этого кода, думаю труда не составит.

'*************************************************************************
' Copyright ©2004 Karl E. Peterson
' *************************************************************************
' You are free to use this code within your own applications, but you
' are expressly forbidden from selling or otherwise distributing this
' source code, non-compiled, without prior written consent.
' *************************************************************************

' Win32 API declarations
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _
                                          (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, _
                                           ByVal lpReturnedString As String, ByVal nSize As Long) As Long
 
Public Sub DumpPrinterList()
    Dim Buffer As String
    Dim BufSize As Long
    Dim nChars As Long
    Dim Devices() As String
    Dim NetPort As String
    Dim i As Long
 
    ' VB5 fails because it never expands this value!
    ' Start with a reasonably sized buffer.
    BufSize = 512
 
    ' Attempt to get list of installed printers
    ' by looping until successful.
    Do
        Buffer = Space$(BufSize)
        nChars = GetProfileString("Devices", vbNullString, "", Buffer, BufSize)
        If nChars = (BufSize - 2) Then
            ' MSDN: If either lpAppName or lpKeyName is NULL and
            ' the supplied destination buffer is too small to hold
            ' all the strings, the last string is truncated and
            ' followed by two null characters. In this case, the
            ' return value is equal to nSize minus two.
            BufSize = BufSize * 2
        ElseIf nChars = 0 Then
            ' The call failed entirely.
            Exit Do
        Else
            ' We got a reasonable return.
            Exit Do
        End If
    Loop
 
    ' Build a list compatible with Application.ActivePrinter?
    Call ExtractStringZ(Buffer, Devices())
    For i = LBound(Devices) To UBound(Devices)
        nChars = GetProfileString("Devices", Devices(i), "", Buffer, BufSize)
        NetPort = Mid$(TrimNull(Buffer), InStr(Buffer, ",") + 1)
        Debug.Print Devices(i); " on "; NetPort
    Next i
End Sub
 
' *********************************************
' Private Methods
' *********************************************
Private Function ExtractStringZ(Buffer As String, OutArray() As String) As Long
    Dim StartPos As Long
    Dim NullPos As Long
    Dim BuffLen As Long
    Dim Elements As Long
 
    ' Extract null terminated strings from large
    ' double-null terminated buffer.
    StartPos = 1
    Elements = 0
    BuffLen = Len(Buffer)
 
    ' Loop through buffer looking for nulls.
    Do While StartPos < BuffLen
        NullPos = InStr(StartPos, Buffer, vbNullChar)
        If NullPos = StartPos Then
            ' We've hit the double-null terminator.
            Exit Do
        Else
            ' Expand array, store new substring, and
            ' increment counters.
            ReDim Preserve OutArray(0 To Elements) As String
            OutArray(Elements) = Mid$(Buffer, StartPos, NullPos - StartPos)
            StartPos = NullPos + 1
            Elements = Elements + 1
        End If
    Loop
 
    ' Return number of substrings found.
    ExtractStringZ = Elements
End Function
 
Private Function TrimNull(ByVal StrIn As String) As String
    Dim nul As Long
 
    ' Truncate input string at first null.
    ' If no nulls, perform ordinary Trim.
    nul = InStr(StrIn, vbNullChar)
    Select Case nul
        Case Is > 1
            TrimNull = Left$(StrIn, nul - 1)
        Case 1
            TrimNull = ""
        Case 0
            TrimNull = Trim$(StrIn)
    End Select
End Function

Спасибо за ответ, сначала так и сделал http://clip2net.com/s/1OiZ5 но изза ошибки пошёл "обходными путями", может что не включено или еще изза чего. Пишу дома (и принтеров нету кроме виртуальных Офиса) может на работе нормально сработает.

К сожалению, вряд ли смогу помочь.
Я писал этот код, ориентируясь на имена принтеров, выводимых моим Excel (версии 2003)
И нет никакой гарантии, что все версии Excel, и в любой версии Windows, будут именовать принтеры точно также.

Сделайте проще:
1) При открытии формы (событие UserForm_Initialize) заполните комбобокс списком имён принтеров,
используя цикл из моего макроса
2) При щелчке на CommandButton5 просто активируйте выбранный принтер одной строкой кода:

Application.ActivePrinter = ListOfPrint.Value

http://clip2net.com/s/1OiGj
Не подскажете где ошибка? Хочу на форму в Excel добавить ComboBox со списком установленных принтеров (здесь поможет ваш код) и выводить печать на выбранный принтер, но вылезает такая вот ошибка. И еще экспериментировал и выбирал различные принтеры, номер .Item(n).Name & " (Ne" & Format(n - 1, "00") & ":)" и тот номер который показывает Application.ActivePrinter не совпадают.

Проанализируйте свойства всех установленных принтеров, и отфильтруйте подходящие принтеры.

Пример кода для просмотра свойств принтеров, установленных в системе:

Sub ВыводСвойствВсехПринтеров()
    intPrinters = 1
    Set objWMIService = GetObject("winmgmts://./root/CIMV2")
    Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Printer")
 
    For Each PRN In colItems
        txt = "Printers on " & PRN.name & ", Printer Number: " & intPrinters & vbCr & _
               "====================================" & vbCr & "Availability: " & PRN.Availability & vbCr & _
               "Description: " & PRN.Description & vbCr & "Printer: " & PRN.DeviceID & vbCr & _
               "Driver Name: " & PRN.DriverName & vbCr & "Port Name: " & PRN.PortName & vbCr & _
               "Printer State: " & PRN.PrinterState & vbCr & "Printer Status: " & PRN.PrinterStatus & vbCr & _
               "PrintJobDataType: " & PRN.PrintJobDataType & vbCr & "Print Processor: " & PRN.PrintProcessor & vbCr & _
               "Spool Enabled: " & PRN.SpoolEnabled & vbCr & "Separator File: " & PRN.SeparatorFile & vbCr & _
               "Queued: " & PRN.Queued & vbCr & "Status: " & PRN.Status & vbCr & _
               "StatusInfo: " & PRN.StatusInfo & vbCr & "Published: " & PRN.Published & vbCr & _
               "Shared: " & PRN.Shared & vbCr & "ShareName: " & PRN.ShareName & vbCr & _
               "Direct: " & PRN.Direct & vbCr & "Location: " & PRN.Location & vbCr & _
               "Priority: " & PRN.Priority & vbCr & "Work Offline: " & PRN.WorkOffline & vbCr & _
               "Horizontal Res: " & PRN.HorizontalResolution & vbCr & "Vertical Res: " & PRN.VerticalResolution & vbCr
        MsgBox txt, vbInformation, "Информация о принтере № " & intPrinters
        intPrinters = intPrinters + 1
    Next
End Sub

А вот этот код выведет список принтеров, доступных в текущий момент:
(мы в запросе указываем, что нас интересуют только принтеры со статусом Idle)

Sub ВыводСпискаИмёнДоступныхПринтеров()
    Set objWMIService = GetObject("winmgmts://./root/CIMV2")
    Set colItems = objWMIService.ExecQuery _
                   ("SELECT * FROM Win32_Printer WHERE PrinterStatus = '3'")
 
    For Each PRN In colItems
        Debug.Print PRN.name
    Next
End Sub

...список всех установленных в системе принтеров - это хорошо
Но, как отобразить список принтеров кроме выключенных из сети, но подключенных к компьютеру?
Опрос системы должен произойти до начала пуска печати.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
             ____   __        __  _   _   _____   _   _ 
__ __ | _ \ \ \ / / | | | | | ___| | | | |
\ \ /\ / / | |_) | \ \ /\ / / | |_| | | |_ | |_| |
\ V V / | _ < \ V V / | _ | | _| | _ |
\_/\_/ |_| \_\ \_/\_/ |_| |_| |_| |_| |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.