Option Explicit
Private Declare Function GetProfileString Lib "kernel32" _
Alias "GetProfileStringA" (ByVal lpAppName As String, _
ByVal lpKeyName As String, ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long
Sub Test()
Dim vaList
'Get all printers
vaList = PrinterFind
'Show m
MsgBox Join(vaList, vbLf), , "List of printers"
'Get all printers with A3 paper size
vaList = PrinterFind(Match:="A3")
'Switch to the first "A3 paper size" found
If UBound(vaList) = -1 Then
MsgBox "Printer not found"
ElseIf MsgBox("from " & vbTab & ": " & ActivePrinter & vbLf & _
"to " & vbTab & ": " & vaList(0), _
vbOKCancel, "Switch Printers") = vbOK Then
Application.ActivePrinter = vaList(0)
End If
End Sub
Public Function PrinterFind(Optional Match As String) As String()
Dim n%, lRet&, sBuf$, sCon$, aPrn$()
Const lLen& = 1024, sKey$ = "devices"
'------------------------------------------------------------------
'written by keepITcool
'requires xl2000 or newer.
'returns a zerobased array of complete localized printer strings
'results are filtered on Match string, if no result the ubound = -1
'------------------------------------------------------------------
'Split ActivePrinter string to get localized word for "on"
aPrn = Split(Excel.ActivePrinter)
sCon = " " & aPrn(UBound(aPrn) - 1) & " " '
'Read all installed printers (1k bytes s/b enough)
sBuf = Space(lLen)
lRet = GetProfileString(sKey, vbNullString, vbNullString, sBuf, lLen)
If lRet = 0 Then
Err.Raise vbObjectError + 513, , "Can't read Profile"
Exit Function
End If
'Split buffer string
aPrn = Split(Left(sBuf, lRet - 1), vbNullChar)
'Filter array on Match
If Match <> vbNullString Then aPrn = Filter(aPrn, Match, -1, 1)
For n = LBound(aPrn) To UBound(aPrn)
'Add 16bit portname for each Printer
sBuf = Space(lLen)
lRet = GetProfileString(sKey, aPrn(n), vbNullString, sBuf, lLen)
aPrn(n) = aPrn(n) & " (" & Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ",") - 1) & ":)"
Next
'Return the result
PrinterFind = aPrn
End Function
