Harald, Po
Here's a better and simpler alternative to Randy Birch's approach.
(For use in Excel97 i've included the replacements for join/ split/
replace functions introduced in VBA6)
The PrinterList function can be used as a UDF or to generate a simple
array for a combobox on a userform.
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
keepITcool
< email : keepitcool chello nl (with @ and .) >
< homepage:
http://members.chello.nl/keepitcool >
