Private Sub Command1_Click()
Dim OrgPrinter As WindowsDevice
Call GetDefaultPrinter(OrgPrinter)
Text1.Text = OrgPrinter.WindowsDeviceUserName

Dim NumPrinters As Integer
ReDim InstalledPrinters(0) As WindowsDevice
Call GetInstalledPrinters(InstalledPrinters())
For NumPrinters = 1 To UBound(InstalledPrinters)
List1.AddItem InstalledPrinters(NumPrinters). _
WindowsDeviceUserName + "on " + _
InstalledPrinters(NumPrinters).WindowsDevicePortName
Next

List1.AddItem NO_PRINTER, 0
End Sub

Private Sub GetDefaultPrinter(recDefaultPrinter As WindowsDevice)
Dim StrPos As Integer
Dim DefaultPrinter As String
Dim RC As Integer

DefaultPrinter = GetString(WINDOWS_SECTION_NAME, DEVICE_KEY_NAME, "", "")
StrPos = InStr(DefaultPrinter, ",")
recDefaultPrinter.WindowsDeviceUserName = Left$(DefaultPrinter, StrPos - 1)
DefaultPrinter = Mid$(DefaultPrinter, StrPos + 1)
StrPos = InStr(DefaultPrinter, ",")
recDefaultPrinter.WindowsDeviceShortName = Left$(DefaultPrinter, StrPos - 1)
recDefaultPrinter.WindowsDevicePortName = Mid$(DefaultPrinter, StrPos + 1)
End Sub

Private Sub GetInstalledPrinters(recInstalledPrinters() As WindowsDevice)
Dim StrPos As Integer
Dim PrtSub As Integer
Dim InstalledPrinter As String
ReDim PrinterNames(0) As String

Call GetKeyNames(DEVICES_SECTION_NAME, PrinterNames(), "")
ReDim recInstalledPrinters(UBound(PrinterNames))
For PrtSub = 1 To UBound(PrinterNames)
InstalledPrinter = GetString(DEVICES_SECTION_NAME, _
PrinterNames(PrtSub),"", "") StrPos = InStr(InstalledPrinter, ",")
recInstalledPrinters(PrtSub).WindowsDeviceUserName = PrinterNames(PrtSub)
recInstalledPrinters(PrtSub).WindowsDeviceShortName = _
Left$(InstalledPrinter, StrPos - 1)
InstalledPrinter = Mid$(InstalledPrinter, StrPos + 1)
StrPos = InStr(InstalledPrinter, ",")

If StrPos > 0 Then
recInstalledPrinters(PrtSub).WindowsDevicePortName = _
Left$(InstalledPrinter, StrPos - 1)
Else
recInstalledPrinters(PrtSub).WindowsDevicePortName = _
InstalledPrinter
End If
Next
End Sub

Function GetString(SectionName As String, KeyName As String, DefaultValue _
As String, ProfileName As String) As String

Dim KeyValueLength As Integer
Dim KeyValue As String
KeyValue = Space$(256)
If Trim$(ProfileName) = "" Then
KeyValueLength = GetProfileString(SectionName, KeyName, _
DefaultValue, KeyValue, Len(KeyValue))
Else
KeyValueLength = GetPrivateProfileString(SectionName, KeyName, _
DefaultValue, KeyValue, Len(KeyValue), ProfileName)
End If
GetString = Left$(KeyValue, KeyValueLength)
End Function

Sub GetKeyNames(SectionName As String, KeyNames() As String, ProfileName _
As String) Dim StrPos As Integer Dim KeyCount As Integer

Dim Start As Integer
Dim KeyNamesLength As Integer
Dim KeyNameString As String
KeyNameString = Space$(1024)
If Trim$(ProfileName) = "" Then
KeyNamesLength = GetProfileKeys(SectionName, 0, "", KeyNameString, _
Len(KeyNameString))
Else
KeyNamesLength = GetPrivateProfileKeys(SectionName, 0, "", _
KeyNameString, Len(KeyNameString), ProfileName)
End If

KeyCount = 0
ReDim KeyNames(0)
If KeyNamesLength > 0 Then
KeyNameString = Left$(KeyNameString, KeyNamesLength)
If Right$(KeyNameString, 1) <> Chr$(0) Then
KeyNameString = KeyNameString + Chr$(0)
End If
KeyNamesLength = Len(KeyNameString)
Start = 1
Do
StrPos = InStr(Start, KeyNameString, Chr$(0))
If StrPos > 0 Then
KeyCount = KeyCount + 1
ReDim Preserve KeyNames(KeyCount)
KeyNames(KeyCount) = Mid$(KeyNameString, Start, StrPos - Start)
If StrPos < KeyNamesLength Then
Start = StrPos + 1
Else
Exit Do
End If
Else
Exit Do
End If
Loop
End If
End Sub