这是我最终想到的。你需要
IShellFolder Extended Type Library v1.2
Option Explicit
Private Const CSIDL_PRINTERS As Long = &H4
Private Const SHGFI_PIDL As Long = &H8
Private Const SHGFI_ICON As Long = &H100
Private Const SHGFI_DISPLAYNAME As Long = &H200
Private Const MAX_PATH As Long = 260
Private Declare Function SHGetDesktopFolder Lib "shell32" (ppshf As IShellFolder) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" (pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, ppRet As IPicture) As Long
Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Private Type PICTDESC
Size As Long
Type As Long
hBmpOrIcon As Long
hPal As Long
End Type
Private Sub Command1_Click()
Dim IID_IShellFolder As IShellFolderEx_TLB.GUID
Dim IID_IPicture(0 To 3) As Long
Dim pidlPrinters() As Byte
Dim pidlCurrent() As Byte
Dim pidlAbsolute() As Byte
Dim pDesktopFolder As IShellFolder
Dim pPrintersFolder As IShellFolder
Dim pEnumIds As IEnumIDList
Dim lPtr As Long
Dim uInfo As SHFILEINFO
Dim uPict As PICTDESC
Dim sPrinterName As String
Dim oPrinterIcon As StdPicture
'--- init consts
IID_IShellFolder.Data1 = &H214E6 '--- {000214E6-0000-0000-C000-000000000046}
IID_IShellFolder.Data4(0) = &HC0
IID_IShellFolder.Data4(7) = &H46
IID_IPicture(0) = &H7BF80980 '--- {7BF80980-BF32-101A-8BBB-00AA00300CAB}
IID_IPicture(1) = &H101ABF32
IID_IPicture(2) = &HAA00BB8B
IID_IPicture(3) = &HAB0C3000
'--- init local vars
uPict.Size = Len(uPict)
uPict.Type = vbPicTypeIcon
Call SHGetDesktopFolder(pDesktopFolder)
'--- retrieve enumerator of Printers virtual folder
Call SHGetSpecialFolderLocation(0, CSIDL_PRINTERS, lPtr)
pidlPrinters = pvToPidl(lPtr)
Call pDesktopFolder.BindToObject(VarPtr(pidlPrinters(0)), 0, IID_IShellFolder, pPrintersFolder)
Call pPrintersFolder.EnumObjects(0, SHCONTF_NONFOLDERS, pEnumIds)
'--- loop printers
Do While pEnumIds.Next(1, lPtr, 0) = 0 '--- S_OK
pidlCurrent = pvToPidl(lPtr)
'--- combine pidls: Printers + Current
ReDim pidlAbsolute(0 To UBound(pidlPrinters) + UBound(pidlCurrent))
Call CopyMemory(pidlAbsolute(0), pidlPrinters(0), UBound(pidlPrinters) - 1)
Call CopyMemory(pidlAbsolute(UBound(pidlPrinters) - 1), pidlCurrent(0), UBound(pidlCurrent) - 1)
'--- retrieve info
Call SHGetFileInfo(pidlAbsolute(0), 0, uInfo, Len(uInfo), SHGFI_PIDL Or SHGFI_DISPLAYNAME Or SHGFI_ICON)
sPrinterName = Left(uInfo.szDisplayName, InStr(uInfo.szDisplayName, Chr$(0)) - 1)
'--- extract icon
uPict.hBmpOrIcon = uInfo.hIcon
Call OleCreatePictureIndirect(uPict, IID_IPicture(0), True, oPrinterIcon)
'--- show
Set Picture = oPrinterIcon
MsgBox sPrinterName
Loop
End Sub
Private Function pvToPidl(ByVal lPtr As Long) As Byte()
Dim lTotal As Long
Dim nSize As Integer
Dim baPidl() As Byte
Do
Call CopyMemory(nSize, ByVal (lPtr + lTotal), 2)
lTotal = lTotal + nSize
Loop While nSize <> 0
ReDim baPidl(0 To lTotal + 1)
Call CopyMemory(baPidl(0), ByVal lPtr, lTotal + 2)
Call CoTaskMemFree(lPtr)
pvToPidl = baPidl
End Function
