Recently been discussed in the Dutch excel group (and here as well)
This is the final and complete code including optional code for use with
excel97. It seems to work for everybody.. (also in non english excel
versions
The PrinterList function returns an alphabetically sorted 0 based array
of the installed printers ready for use as a string in ActivePrinter.
like:
If you want the first installed HP Laserjet, just loop thru the
Printerlist array
Application.Activeprinter=Printerlist(0)
keepITcool
< email : keepitcool chello nl (with @ and .) >
< homepage:
http://members.chello.nl/keepitcool >
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 Demo()
Dim v As Variant
Dim i As Long
Workbooks.Add xlWBATWorksheet
v = PrinterList
For i = LBound(v) To UBound(v)
Cells(i + 1, 1) = v(i)
Cells(i + 1, 2).Formula = "=printerlist(" & i & ")"
Next
Cells(1, 3).Resize(i, 1).FormulaArray = "=transpose(printerlist())"
Cells(1, 4).Resize(1, i).FormulaArray = "=printerlist()"
Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
MsgBox Join(v, vbNewLine)
End Sub
Function PrinterList(Optional PrinterNr As Integer = -1)
Dim i%, n%, lRet&, sBuf$, sOn$, sPort$, aPrn
Const lSize& = 1024, sKey$ = "devices"
'-----------------------------------------------------------
'Author: keepITcool 1st posted nl.office.excel 23/10/2003
'Function returns a zerobased array of installed printers
'include for xl97: supplemental functions split/join/replace
'-----------------------------------------------------------
'Get localized Connection string
aPrn = Split(Excel.ActivePrinter)
sOn = " " & aPrn(UBound(aPrn) - 1) & " "
'Read Printers
sBuf = Space(lSize)
lRet = GetProfileString(sKey, vbNullString, vbNullString, sBuf, lSize)
If lRet = 0 Then Exit Function
'Make Array from String
aPrn = Split(Left(sBuf, lRet - 1), vbNullChar)
'Add Port for each Printer
For n = LBound(aPrn) To UBound(aPrn)
sBuf = Space(lSize)
lRet = GetProfileString(sKey, aPrn(n), vbNullString, sBuf, lSize)
sPort = Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ","))
aPrn(n) = aPrn(n) & sOn & sPort
Next
'Sort
qSort aPrn
'Return the results
If PrinterNr = -1 Then PrinterList = aPrn Else PrinterList = aPrn( _
PrinterNr)
End Function
Public Sub qSort(v, Optional n& = True, Optional m& = True)
Dim i&, j&, p, t
If n = True Then n = LBound(v): If m = True Then m = UBound(v)
i = n: j = m: p = v((n + m) \ 2)
While (i <= j)
While (v(i) < p And i < m): i = i + 1: Wend
While (v(j) > p And j > n): j = j - 1: Wend
If (i <= j) Then
t = v(i): v(i) = v(j): v(j) = t
i = i + 1: j = j - 1
End If
Wend
If (n < j) Then qSort v, n, j
If (i < m) Then qSort v, i, m
End Sub
'**********************************************************
' Conditional compilation of Functions for xl97
'**********************************************************
#If VBA6 Then
#Else
Function Split(sText As String, _
Optional sDelim As String = " ") As Variant
Dim i%, sFml$, v0, v1
Const sDQ$ = """"
If sDelim = vbNullChar Then
sDelim = Chr(7)
sText = Replace(sText, vbNullChar, sDelim)
End If
sFml = "{""" & Application.Substitute(sText, sDelim, """,""") & """}"
v1 = Evaluate(sFml)
'Return 0 based for compatibility
ReDim v0(0 To UBound(v1) - 1)
For i = 0 To UBound(v0): v0(i) = v1(i + 1): Next
Split = v0
End Function
Function Replace(sText As String, sFind As String, sRepl As String, _
Optional Start As Long = 1, Optional Count As Long = 1, _
Optional Compare As Long = vbTextCompare) As String
Dim n%
n = InStr(1, sText, sFind, Compare)
While n > 0
sText = Left(sText, n - 1) & sRepl & Mid(sText, n + Len(sFind), _
Len(sText) - n - Len(sFind) + 1)
n = InStr(n, sText, sFind)
Wend
Replace = sText
End Function
Function Join(sArray, Optional sDelim As String = " ")
Dim i%, s$
On Error GoTo exitH
If sDelim = vbNullChar Then sDelim = vbNullString
If IsArray(sArray) Then
For i = LBound(sArray) To UBound(sArray)
s = s & sArray(i) & sDelim
Next
If sDelim <> vbNullString Then s = Left(s, Len(s) - 1)
Else
s = sArray
End If
exitH:
Join = s
End Function
#End If
