This is what I use to not only detect ALL available printers but also to add their Network Ports. Whereas Word will print to a printer name, Excel for some curious reason will not, it requires the full path, eg. \\X06 on Ne:02
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
Range("PrinterListRef").Offset(iIndex + 2, 0) = strPrinterName
Next iIndex
End If
ListPrinters = StrPrinters
ActiveWorkbook.Names.Add name:="PrinterList", RefersToR1C1:="=Config!R16C6:R" & 19 + iEntries & "C6"
End Function
Sub GetAvailablePrinters() 'MAIN ROUTINE _GETS LIST OF ALL PRINTERS WITH NE: PORTS
Dim StrPrinters As Variant, x As Long
Range("PrinterListRange").ClearContents
Range("DefaultPrinter").Offset(0, 1) = Application.ActivePrinter
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)
'Range("PrinterRef").Offset(x + 2, 1) = StrPrinters(x)
Range("DefaultPrinter").Offset(x + 2, 0) = GetFullNetworkPrinterName(CStr(StrPrinters(x)))
Next x
Else
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
'Change the default printer
'This example macro shows how to print a selected document to another
'printer then the default printer. This is done by changing the property Application.ActivePrinter:
Sub PrintToAnotherPrinter()
Dim strCurrentPrinter As String
strCurrentPrinter = Application.ActivePrinter ' store the current active printer
On Error Resume Next ' ignore printing errors
Application.ActivePrinter = "microsoft fax on fax:" ' change to another printer
ActiveSheet.PrintOut ' print the active sheet
Application.ActivePrinter = strCurrentPrinter ' change back to the original printer
On Error GoTo 0 ' resume normal error handling
End Sub
'Print to a network printer
'The example macros below shows how to get the full network printer name
'(useful when the network printer name can change) and print a worksheet to this printer:
Sub PrintToNetworkPrinterExample()
Dim strCurrentPrinter As String, strNetworkPrinter As String
strNetworkPrinter = GetFullNetworkPrinterName("HP LaserJet 8100 Series PCL")
If Len(strNetworkPrinter) > 0 Then ' found the network printer
strCurrentPrinter = Application.ActivePrinter
' change to the network printer
Application.ActivePrinter = strNetworkPrinter
Worksheets(1).PrintOut ' print something
' change back to the previously active printer
Application.ActivePrinter = strCurrentPrinter
End If
End Sub
Function GetFullNetworkPrinterName(strNetworkPrinterName As String) As String
' returns the full network printer name
' returns an empty string if the printer is not found
' e.g. GetFullNetworkPrinterName("HP LaserJet 8100 Series PCL")
' might return "HP LaserJet 8100 Series PCL on Ne04:"
Dim strCurrentPrinterName As String, strTempPrinterName As String, i As Long
strCurrentPrinterName = Application.ActivePrinter
i = 0
Do While i < 100
strTempPrinterName = strNetworkPrinterName & " on Ne" & Format(i, "00") & ":"
On Error Resume Next ' try to change to the network printer
Application.ActivePrinter = strTempPrinterName
On Error GoTo 0
If Application.ActivePrinter = strTempPrinterName Then
' the network printer was found
GetFullNetworkPrinterName = strTempPrinterName
i = 100 ' makes the loop end
End If
i = i + 1
Loop
' remove the line below if you want the function to change the active printer
'Application.ActivePrinter = strCurrentPrinterName ' change back to the original printer
End Function
Sub ChangePrinter()
Dim ChangeToPrinter As String
ChangeToPrinter = "Jaws PDF Creator"
MsgBox (GetFullNetworkPrinterName(ChangeToPrinter))
End Sub
