i want to list all available printers in cells

[pdpatel81]

I want to list all available printers in a worksheet.
I used to use 32bit computer & it worked fine on it but i upgraded to 64bit computer & now it is giving me compile error : type mismatch on 64bit excel. so i need help

This is 32bit code below

Option Explicit
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const HKCU = HKEY_CURRENT_USER
Private Const KEY_QUERY_VALUE = &H1&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_MORE_DATA = 234

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 LongLong

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 LongLong

Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _
ByVal HKey As Long) As LongLong

Public Function GetPrinterFullNames() As String()
Dim Printers() As String ' array of names to be returned
Dim PNdx As Long ' index into Printers()
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 ValueValueS As String ' ValueValue converted to String
Dim CommaPos As Long ' position of comma character in ValueValue
Dim ColonPos As Long ' position of colon character in ValueValue
Dim M As Long ' string index

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

PNdx = 0
Ndx = 0
' assume printer name is less than 256 characters
ValueName = String$(256, Chr(0))
ValueNameLen = 255
' assume the port name is less than 1000 characters
ReDim ValueValue(0 To 999)
' assume there are less than 1000 printers installed
ReDim Printers(1 To 1000)

' open the key whose values enumerate installed printers
Res = RegOpenKeyEx(HKCU, PRINTER_KEY, 0&, _
KEY_QUERY_VALUE, HKey)
' start enumeration loop of printers
Res = RegEnumValue(HKey, Ndx, ValueName, _
ValueNameLen, 0&, DataType, ValueValue(0), 1000)
' loop until all values have been enumerated
Do Until Res = ERROR_NO_MORE_ITEMS
M = InStr(1, ValueName, Chr(0))
If M > 1 Then
' clean up the ValueName
ValueName = Left(ValueName, M - 1)
End If
' find position of a comma and colon in the port name
CommaPos = InStr(1, ValueValue, ",")
ColonPos = InStr(1, ValueValue, ":")
' ValueValue byte array to ValueValueS string
On Error Resume Next
ValueValueS = Mid(ValueValue, CommaPos + 1, ColonPos - CommaPos)
On Error GoTo 0
' next slot in Printers
PNdx = PNdx + 1
Printers(PNdx) = ValueName & " on " & ValueValueS
' reset some variables
ValueName = String(255, Chr(0))
ValueNameLen = 255
ReDim ValueValue(0 To 999)
ValueValueS = vbNullString
' tell RegEnumValue to get the next registry value
Ndx = Ndx + 1
' get the next printer
Res = RegEnumValue(HKey, Ndx, ValueName, ValueNameLen, _
0&, DataType, ValueValue(0), 1000)
' test for error
If (Res <> 0) And (Res <> ERROR_MORE_DATA) Then
Exit Do
End If
Loop
' shrink Printers down to used size
ReDim Preserve Printers(1 To PNdx)
Res = RegCloseKey(HKey)
' Return the result array
GetPrinterFullNames = Printers
End Function

Sub Printer_List_In_Cell()
Dim Printers() As String
Dim N As Long
Dim S As String
Printers = GetPrinterFullNames()
Range("a1").Activate
For N = LBound(Printers) To UBound(Printers)
S = Printers(N)
ActiveCell.Value = S
ActiveCell.Offset(1, 0).Activate
Next N
'MsgBox S, vbOKOnly, "Printers"
End Sub

 

[Lukums]

I understand where you're coming from on this one as I was trying to achieve the same thing.

I was only ever able to select a specific printer from control panel via VBA when "something" was met.

Just to 100% CONFIRM you want to see all available printers in control panel on your sheet?

I'll have a look into this now.

 

[Lukums]

Please note: I'm not sure what is going wrong but as a helping hand see below code which works wonderfully in column A:B

I'm sure with some revision you can compare the two apples to work out what's going wrong.

PLEASE NOTE: THIS IS NOT MY CODE AND WAS FOUND IN AN ARCHIVE SECTION.

Luke

Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Declare Function RegOpenKeyEx _
Lib "advapi32.dll" _
Alias "RegOpenKeyExA" _
( _
ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long _
) _
As Long
Declare Function RegEnumKeyEx _
Lib "advapi32.dll" _
Alias "RegEnumKeyExA" _
( _
ByVal hKey As Long, _
ByVal dwIndex As Long, _
ByVal lpName As String, _
lpcbName As Long, ByVal _
lpReserved As Long, _
ByVal lpClass As String, _
lpcbClass As Long, _
lpftLastWriteTime As FILETIME _
) _
As Long
Declare Function RegCloseKey _
Lib "advapi32.dll" _
( _
ByVal hKey As Long _
) _
As Long

Public Function fncEnumInstalledPrintersReg() As Collection
Dim tmpFunctionResult As Boolean
Dim aFileTimeStruc As FILETIME
Dim AddressofOpenKey As Long, aPrinterName As String
Dim aPrinterIndex As Integer, aPrinterNameLen As Long
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const HKEY_LOCAL_MACHINE = &H80000002
Set fncEnumInstalledPrintersReg = New Collection
aPrinterIndex = 0
tmpFunctionResult = Not CBool _
( _
RegOpenKeyEx _
( _
hKey:=HKEY_LOCAL_MACHINE, _
lpSubKey:="SYSTEM\CURRENTCONTROLSET\CONTROL\PRINT\PRINTERS", _
ulOptions:=0, _
samDesired:=KEY_ENUMERATE_SUB_KEYS, _
phkResult:=AddressofOpenKey _
) _
)
If tmpFunctionResult = False Then GoTo ExitFunction
Do
aPrinterNameLen = 255
aPrinterName = String(aPrinterNameLen, CStr(0))
tmpFunctionResult = Not CBool _
( _
RegEnumKeyEx _
( _
hKey:=AddressofOpenKey, _
dwIndex:=aPrinterIndex, _
lpName:=aPrinterName, _
lpcbName:=aPrinterNameLen, _
lpReserved:=0, _
lpClass:=vbNullString, _
lpcbClass:=0, _
lpftLastWriteTime:=aFileTimeStruc _
) _
)
aPrinterIndex = aPrinterIndex + 1
If tmpFunctionResult = False Then Exit Do
aPrinterName = Left(aPrinterName, aPrinterNameLen)
On Error Resume Next
fncEnumInstalledPrintersReg.Add aPrinterName
On Error GoTo 0
Loop
Call RegCloseKey(AddressofOpenKey)
'
Exit Function
ExitFunction:
If Not AddressofOpenKey = 0 Then _
Call RegCloseKey(AddressofOpenKey)
Set fncEnumInstalledPrintersReg = Nothing
End Function

Sub Printers()
Application.ScreenUpdating = False
Dim aPrinter As Variant
Dim iRow%, lenPrinter%
Columns(1).Clear: Columns(2).Clear
With Range("A1:B1")
.Value = Array("Printer", "Status")
.Font.Bold = True
End With
iRow = 2
For Each aPrinter In fncEnumInstalledPrintersReg
Cells(iRow, 1).Value = aPrinter
lenPrinter = Len(aPrinter)
If aPrinter <> Left(Application.ActivePrinter, lenPrinter) Then
Cells(iRow, 2).Value = "Not Active"
Else
Cells(iRow, 2).Value = "Active"
With Range(Cells(iRow, 1), Cells(iRow, 2))
.Font.Bold = True
.Interior.ColorIndex = 8
End With

End If
iRow = iRow + 1
Next aPrinter

Columns(1).AutoFit: Columns(2).AutoFit
Application.ScreenUpdating = True
End Sub