Option Explicit
Private Const SE_ERR_FNF = 2&
Private Const SE_ERR_PNF = 3&
Private Const SE_ERR_ACCESSDENIED = 5&
Private Const SE_ERR_OOM = 8&
Private Const SE_ERR_DLLNOTFOUND = 32&
Private Const SE_ERR_SHARE = 26&
Private Const SE_ERR_ASSOCINCOMPLETE = 27&
Private Const SE_ERR_DDETIMEOUT = 28&
Private Const SE_ERR_DDEFAIL = 29&
Private Const SE_ERR_DDEBUSY = 30&
Private Const SE_ERR_NOASSOC = 31&
Private Const SE_ERR_BAD_FORMAT = 11&
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const kTypALL = 0
Private Const kTypBRO = 1
Private Const kTypTAG = 2
Private Const HWND_BROADCAST As Long = &HFFFF&
Private Const WM_WININICHANGE As Long = &H1A
' The following code allows one to read, and write to the WIN.INI files
' In win 2000 the printer settings are actually in the registry. However, windows
' handles this correctly
#If Win64 Then 'Public Dclare PtrSafe Function
Public Declare PtrSafe Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hWnd As Long, ByVal lpszOp As String, _
ByVal lpszFile As String, _
ByVal lpszParams As String, _
ByVal lpszDir As String, _
ByVal FsShowCmd As Long _
) As Long
Public Declare PtrSafe 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
Public Declare PtrSafe Function WriteProfileString Lib "kernel32" _
Alias "WriteProfileStringA" _
(ByVal lpszSection As String, _
ByVal lpszKeyName As String, _
ByVal lpszString As String) As Long
Public Declare PtrSafe Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
#Else '----32 bit
Public Declare Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hWnd As Long, ByVal lpszOp As String, _
ByVal lpszFile As String, _
ByVal lpszParams As String, _
ByVal lpszDir As String, _
ByVal FsShowCmd As Long _
) As Long
Public 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
Public Declare Function WriteProfileString Lib "kernel32" _
Alias "WriteProfileStringA" _
(ByVal lpszSection As String, _
ByVal lpszKeyName As String, _
ByVal lpszString As String) As Long
Public Declare PtrSafe Function SendMessage Lib "user32" _
Alias "" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
#End If
Public Sub getPrintersList()
' this routine returns a list of printers, separated by
' a ";", and thus the results are suitable for stuffing into a combo box
Dim strBuffer As String
Dim strOnePtr As String
Dim intPos As Integer
Dim lngChars As Long
Dim vList
Dim sPort As String
Range("A1").Select
strBuffer = Space(2048)
lngChars = GetProfileString("PrinterPorts", vbNullString, "", strBuffer, Len(strBuffer))
If lngChars > 0 Then
intPos = InStr(strBuffer, Chr(0))
Do While intPos > 1
strOnePtr = Left(strBuffer, intPos - 1)
strBuffer = Mid(strBuffer, intPos + 1)
GoSub Add1Ptr
'Debug.Print strOnePtr
intPos = InStr(strBuffer, Chr(0))
Loop
End If
Exit Sub
Add1Ptr:
ActiveCell.Value = strOnePtr
sPort = GetPrinterPort(strOnePtr)
ActiveCell.Offset(0, 1).Value = sPort
ActiveCell.Offset(1, 0).Select 'next row
Return
End Sub
Public Function GetPrinterPort(strPrinterName As String) As String
Dim objReg As Object, strRegVal As String, strValue As String
Const HKEY_CURRENT_USER = &H80000001
Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
strRegVal = "Software\Microsoft\Windows NT\CurrentVersion\PrinterPorts\"
objReg.getstringvalue HKEY_CURRENT_USER, strRegVal, strPrinterName, strValue
GetPrinterPort = Split(strValue, ",")(1)
End Function
