Microsoft Office Forums - View Single Post

hhorber · 04-04-2018, 02:21 AM

Dear all

VBA, unlike VB, does not provide a Printers Collection. But you may use the following code to get the available printers from the registry to a combobox.

The code is valid for a maximal 10 available printers but may be adapted.

Module 1

Code:

Sub Test()
    Dim SaveActivePrinter As String
    Dim ch5 As String
    Dim PrinterNames() As String
    
    SaveActivePrinter = ActivePrinter
    
    ReDim PrinterNames(0 To 9)
    Call GetPrinterNames(PrinterNames())
    Call GetPrinterNameFromUser(PrinterNames(), ch5)
    ActivePrinter = ch5
    
    ' Your Code
    
    ActivePrinter = SaveActivePrinter
    
End Sub

Module 2

Code:

Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const KEY_QUERY_VALUE = &H1&

Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32" _
    Alias "RegOpenKeyExA" ( _
    ByVal HKey As Long, _
    ByVal lpSubKey As String, _
    ByVal ulOptions As Long, _
    ByVal samDesired As Long, _
    phkResult As Long) As Long

Private Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" _
    Alias "RegEnumValueA" ( _
    ByVal HKey As Long, _
    ByVal dwIndex As Long, _
    ByVal lpValueName As String, _
    lpcbValueName As Long, _
    ByVal lpReserved As Long, _
    lpType As Long, _
    lpData As Byte, _
    lpcbData As Long) As Long

Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _
    ByVal HKey As Long) As Long
Sub GetPrinterNameFromUser(ByRef PrinterNames As Variant, ByRef ch5 As String)

    Dim cBox    As ComboBox
    Dim cBut    As CommandButton

    Set cBox = UserForm1.ComboBox1
    Set cBut = UserForm1.CommandButton1

    cBut.Caption = "OK"
    cBut.Left = 100

    cBox.Clear
    cBox.AddItem PrinterNames(0)
    cBox.AddItem PrinterNames(1)
    cBox.AddItem PrinterNames(2)
    cBox.AddItem PrinterNames(3)
    cBox.AddItem PrinterNames(4)
    cBox.AddItem PrinterNames(5)
    cBox.AddItem PrinterNames(6)
    cBox.AddItem PrinterNames(7)
    cBox.AddItem PrinterNames(8)
    cBox.AddItem PrinterNames(9)

    i = 0
    Do While i <= 9
      If (PrinterNames(i) = ActivePrinter) Then
        Exit Do
      End If
      i = i + 1
    Loop

    cBox.ListIndex = i

    UserForm1.Caption = "Name of the printer?"

    UserForm1.Show

    ch5 = cBox.Value

End Sub

Sub GetPrinterNames(ByRef PrinterNames As Variant)

    Dim PNdx As Long                ' index
    Dim HKey As Long                ' registry key handle
    Dim Res As Long                  ' result of API calls
    Dim Ndx As Long                 ' index for RegEnumValue
    Dim ValueName As String      ' name of each value in the printer key
    Dim ValueNameLen As Long    ' length of ValueName
    Dim DataType As Long          ' registry value data type
    Dim ValueValue() As Byte      ' byte array of registry value value
    Dim M As Long                     ' string index
    Dim i As Integer

    'registry key in HKCU listing printers
    Const PRINTER_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Devices"

    PNdx = 0
    Ndx = 0
    ValueName = String$(256, Chr(0))  ' assume printer name is less than 256 characters
    ValueNameLen = 255
    ReDim ValueValue(0 To 999)           ' assume the port name is less than 1000 characters
    Res = RegOpenKeyEx(HKCU, PRINTER_KEY, 0&, _
          KEY_QUERY_VALUE, HKey)
    Res = RegEnumValue(HKey, Ndx, ValueName, ValueNameLen, _
          0&, DataType, ValueValue(0), 1000)

    i = 0
    Do Until Res <> 0

      M = InStr(1, ValueName, Chr(0))
      If M > 1 Then
        ValueName = Left(ValueName, M - 1)
        PrinterNames(i) = ValueName
        i = i + 1
      End If
      PNdx = PNdx + 1
      ValueName = String(255, Chr(0))
      ValueNameLen = 255
      ReDim ValueValue(0 To 999)      ' get the next registry value
      Ndx = Ndx + 1                         ' get the next printer
      Res = RegEnumValue(HKey, Ndx, ValueName, ValueNameLen, _
            0&, DataType, ValueValue(0), 1000)

    Loop

    Res = RegCloseKey(HKey)

End Sub

Form 1

Code:

Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} UserForm1 
   Caption         =   "UserForm1"
   ClientHeight    =   2685
   ClientLeft      =   120
   ClientTop       =   465
   ClientWidth     =   7065
   OleObjectBlob   =   "UserForm1.frx":0000
   StartUpPosition =   2  'CenterScreen
End
Attribute VB_Name = "UserForm1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub CommandButton1_Click()
    Unload Me
End Sub

Private Sub UserForm_Click()
End Sub