修改VBA网络打印机列表代码：将结果输出至工作表单元格

问题背景 #

现有VBA代码可正常读取注册表中的网络打印机名称和端口信息，但仅能通过消息框展示结果，无法直接在工作表公式中调用，也不能批量写入单元格用于后续打印配置。

修改后的完整代码 #

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 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 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 Function RegCloseKey Lib "advapi32.dll" ( _
    ByVal HKey As Long) As Long

' 核心函数：获取所有打印机完整信息（保留原有逻辑）
Public Function GetPrinterFullNames() As String()
Dim Printers() As String ' 存储返回的打印机信息数组
Dim PNdx As Long    ' 打印机数组索引
Dim HKey As Long    ' 注册表键句柄
Dim Res As Long     ' API调用结果
Dim Ndx As Long     ' RegEnumValue的索引
Dim ValueName As String ' 注册表中每个值的名称（打印机名）
Dim ValueNameLen As Long    ' ValueName的长度
Dim DataType As Long        ' 注册表值的数据类型
Dim ValueValue() As Byte    ' 注册表值的字节数组
Dim ValueValueS As String   ' 转换后的注册表值字符串（端口信息）
Dim CommaPos As Long        ' 端口字符串中逗号的位置
Dim ColonPos As Long        ' 端口字符串中冒号的位置
Dim M As Long               ' 字符串处理索引

' 存储打印机信息的注册表路径
Const PRINTER_KEY = "Software\Microsoft\Windows NT\CurrentVersion\Devices"

PNdx = 0
Ndx = 0
' 初始化打印机名称缓冲区（假设不超过256字符）
ValueName = String$(256, Chr(0))
ValueNameLen = 255
' 初始化端口信息缓冲区（假设不超过1000字符）
ReDim ValueValue(0 To 999)
' 初始化打印机数组（假设不超过1000台打印机）
ReDim Printers(1 To 1000)

' 打开注册表键
Res = RegOpenKeyEx(HKCU, PRINTER_KEY, 0&, _
    KEY_QUERY_VALUE, HKey)
' 开始枚举第一个打印机
Res = RegEnumValue(HKey, Ndx, ValueName, _
    ValueNameLen, 0&, DataType, ValueValue(0), 1000)
' 循环枚举所有打印机
Do Until Res = ERROR_NO_MORE_ITEMS
    M = InStr(1, ValueName, Chr(0))
    If M > 1 Then
        ' 清理打印机名称中的空字符
        ValueName = Left(ValueName, M - 1)
    End If
    ' 定位端口字符串中的逗号和冒号
    CommaPos = InStr(1, ValueValue, ",")
    ColonPos = InStr(1, ValueValue, ":")
    ' 将字节数组转换为端口字符串
    On Error Resume Next
    ValueValueS = Mid(ValueValue, CommaPos + 1, ColonPos - CommaPos)
    On Error GoTo 0
    ' 存储打印机完整信息
    PNdx = PNdx + 1
    Printers(PNdx) = ValueName & " on " & ValueValueS
    ' 重置缓冲区变量
    ValueName = String(255, Chr(0))
    ValueNameLen = 255
    ReDim ValueValue(0 To 999)
    ValueValueS = vbNullString
    ' 枚举下一个打印机
    Ndx = Ndx + 1
    Res = RegEnumValue(HKey, Ndx, ValueName, ValueNameLen, _
        0&, DataType, ValueValue(0), 1000)
    ' 处理非预期错误
    If (Res <> 0) And (Res <> ERROR_MORE_DATA) Then
        Exit Do
    End If
Loop
' 收缩数组到实际使用大小
ReDim Preserve Printers(1 To PNdx)
Res = RegCloseKey(HKey)
' 返回结果数组
GetPrinterFullNames = Printers
End Function

' 工作表函数：根据索引返回指定打印机信息，索引从1开始
Public Function GetPrinterInfo(Optional printerIndex As Long = 1) As String
    Dim printers() As String
    printers = GetPrinterFullNames()
    
    If printerIndex < 1 Or printerIndex > UBound(printers) Then
        GetPrinterInfo = "无效索引"
        Exit Function
    End If
    
    GetPrinterInfo = printers(printerIndex)
End Function

' 批量将打印机信息写入工作表，默认从A1单元格开始
Sub WritePrintersToSheet(Optional startCell As Range = Nothing)
    Dim printers() As String
    Dim targetRange As Range
    
    ' 设置默认起始单元格为当前工作表的A1
    If startCell Is Nothing Then
        Set startCell = ActiveSheet.Range("A1")
    End If
    
    printers = GetPrinterFullNames()
    
    ' 将数组转置后写入单元格区域
    Set targetRange = startCell.Resize(UBound(printers), 1)
    targetRange.Value = Application.Transpose(printers)
    
    ' 自动调整列宽以适配内容
    startCell.EntireColumn.AutoFit
    
    MsgBox "打印机信息已写入工作表，共" & UBound(printers) & "条记录", vbInformation
End Sub

' 测试子过程
Sub Test()
    ' 测试批量写入功能
    WritePrintersToSheet
    ' 可选：测试单个打印机信息获取
    ' MsgBox GetPrinterInfo(1), vbInformation, "第一个打印机信息"
End Sub

使用说明 #

1. 工作表公式调用：在单元格中输入=GetPrinterInfo(1)可获取第1台打印机的信息，修改数字可切换不同打印机；直接输入=GetPrinterInfo()默认返回第1台
2. 批量写入：运行WritePrintersToSheet宏，所有打印机信息会自动写入当前工作表的A1开始的单元格区域，列宽会自动调整
3. 自定义写入位置：可指定起始单元格，比如运行WritePrintersToSheet Range("C3")，信息会从C3开始写入

内容的提问来源于stack exchange，提问作者312kclark