Получение списка доступных принтеров средствами VB (VBA)

'*************************************************************************
' Copyright ©2004 Karl E. Peterson
' *************************************************************************
' You are free to use this code within your own applications, but you
' are expressly forbidden from selling or otherwise distributing this
' source code, non-compiled, without prior written consent.
' *************************************************************************

' Win32 API declarations
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _
                                          (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, _
                                           ByVal lpReturnedString As String, ByVal nSize As Long) As Long
 
Public Sub DumpPrinterList()
    Dim Buffer As String
    Dim BufSize As Long
    Dim nChars As Long
    Dim Devices() As String
    Dim NetPort As String
    Dim i As Long
 
    ' VB5 fails because it never expands this value!
    ' Start with a reasonably sized buffer.
    BufSize = 512
 
    ' Attempt to get list of installed printers
    ' by looping until successful.
    Do
        Buffer = Space$(BufSize)
        nChars = GetProfileString("Devices", vbNullString, "", Buffer, BufSize)
        If nChars = (BufSize - 2) Then
            ' MSDN: If either lpAppName or lpKeyName is NULL and
            ' the supplied destination buffer is too small to hold
            ' all the strings, the last string is truncated and
            ' followed by two null characters. In this case, the
            ' return value is equal to nSize minus two.
            BufSize = BufSize * 2
        ElseIf nChars = 0 Then
            ' The call failed entirely.
            Exit Do
        Else
            ' We got a reasonable return.
            Exit Do
        End If
    Loop
 
    ' Build a list compatible with Application.ActivePrinter?
    Call ExtractStringZ(Buffer, Devices())
    For i = LBound(Devices) To UBound(Devices)
        nChars = GetProfileString("Devices", Devices(i), "", Buffer, BufSize)
        NetPort = Mid$(TrimNull(Buffer), InStr(Buffer, ",") + 1)
        Debug.Print Devices(i); " on "; NetPort
    Next i
End Sub
 
' *********************************************
' Private Methods
' *********************************************
Private Function ExtractStringZ(Buffer As String, OutArray() As String) As Long
    Dim StartPos As Long
    Dim NullPos As Long
    Dim BuffLen As Long
    Dim Elements As Long
 
    ' Extract null terminated strings from large
    ' double-null terminated buffer.
    StartPos = 1
    Elements = 0
    BuffLen = Len(Buffer)
 
    ' Loop through buffer looking for nulls.
    Do While StartPos < BuffLen
        NullPos = InStr(StartPos, Buffer, vbNullChar)
        If NullPos = StartPos Then
            ' We've hit the double-null terminator.
            Exit Do
        Else
            ' Expand array, store new substring, and
            ' increment counters.
            ReDim Preserve OutArray(0 To Elements) As String
            OutArray(Elements) = Mid$(Buffer, StartPos, NullPos - StartPos)
            StartPos = NullPos + 1
            Elements = Elements + 1
        End If
    Loop
 
    ' Return number of substrings found.
    ExtractStringZ = Elements
End Function
 
Private Function TrimNull(ByVal StrIn As String) As String
    Dim nul As Long
 
    ' Truncate input string at first null.
    ' If no nulls, perform ordinary Trim.
    nul = InStr(StrIn, vbNullChar)
    Select Case nul
        Case Is > 1
            TrimNull = Left$(StrIn, nul - 1)
        Case 1
            TrimNull = ""
        Case 0
            TrimNull = Trim$(StrIn)
    End Select
End Function