通过 VBA 设置默认打印机

我正在运行一个在两台打印机之间切换的 Excel 宏，一台名为“RecOffice_Pink”，另一台名为“RecOffice_White”。

这是解决 VBA 无法轻松指定打印托盘问题的一个巧妙的解决方法。粉红色打印机除了一个纸盘之外的所有纸盘都被禁用，其中包含我们的粉红色纸张。

我在用

CreateObject(WScript.Network).SetDefaultPrinter "RecOffice_Pink"
and
CreateObject(WScript.Network).SetDefaultPrinter "RecOffice_White"

这在我们的 Windows 7 电脑上运行得很好，但它似乎不适用于我们的任何 Windows 10 电脑。

没有抛出错误，没有创建消息，只是似乎没有切换打印机。

我尝试过将它们设置为我们网络上的共享打印机，并在每台计算机上设置它们，这两种方法都可以在 Windows 7 上正常运行。

Usage

  SetDefaultPrinter "RecOffice_Pink"

设置默认打印机

 Sub SetDefaultPrinter(PrinterName As String, Optional ComputerName As String = ".")
    Dim Printer As Object, Printers As Object, WMIService As Object
    Set WMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & ComputerName & "\root\cimv2")
    Set Printers = WMIService.ExecQuery("Select * from Win32_Printer Where Name = '" & PrinterName & "'")

    For Each Printer In Printers
        Printer.SetDefaultPrinter
    Next

End Sub

列出新工作簿中的打印机和打印机属性

Sub ListPrinters(Optional ComputerName As String = ".")
    Dim WMIService As Object
    Set WMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & ComputerName & "\root\cimv2")

    Dim Printers As Object
    Set Printers = WMIService.ExecQuery("Select * from Win32_Printer")

    Dim Printer As Object
    Dim Item As Object
    Dim Results
    Dim r As Long, c As Long, NameIndex As Long
    For Each Printer In Printers
        ReDim Results(1 To Printers.Count + 1, 1 To Printer.Properties_.Count)
        r = 1
        For Each Item In Printer.Properties_
            c = c + 1
            If Item.Name = "Name" Then NameIndex = c
            Results(r, c) = Item.Name
        Next
        Exit For
    Next

    For Each Printer In Printers
        r = r + 1
        c = 0
        For Each Item In Printer.Properties_
            c = c + 1
            Results(r, c) = Item.Value
        Next
    Next

    Dim SheetsInNewWorkbook As Long
    SheetsInNewWorkbook = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 2
    With Workbooks.Add
        With Worksheets(1)
            .Range("A1").Resize(UBound(Results), UBound(Results, 2)).Value = Results
            .Columns(NameIndex).Cut
            .Columns(1).Insert Shift:=xlDown
            .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes).Unlist
            .Columns.AutoFit
            .Range("A1").CurrentRegion.Copy
        End With
        With Worksheets(2)
            .Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            Application.CutCopyMode = False
            .Columns.AutoFit
        End With
    End With
    Application.SheetsInNewWorkbook = SheetsInNewWorkbook
End Sub