尝试使用 API 函数将从文件中提取的图标设置为 TreeView Node.Image
Trying to set an icon extracted from a file to a TreeView Node.Image using API functions
我正在为我部门的用户创建一个用户表单，允许他们从模板 select files/subfolders 创建一个工作文件夹。这是在 Windows 10 Enterprise 64 位桌面上使用 VBA7 到 Excel 2010（该部门唯一可用的工具...）完成的。裸露的骨头，效果很好。我什至成功地使用了其他 API 函数来使 Excel 用户窗体在用户看来就像它自己的独立应用程序一样。现在我只是想添加一些文件图标，让用户更容易（更漂亮）地进行可视化。
在用户窗体初始化期间添加图标的逻辑归结为：
1) 在 运行 时间
填充文件模板源路径的字典
2) 使用此字典用表示文件的节点填充 TreeView
3) 使用字典中相同的文件路径为每个节点分配图标，使用API函数从文件中提取图标
我浏览了很多关于使用 API 函数从文件中提取图标并以某种方式将它们转换为用户窗体控件可用图像的论坛和代码数据库。我已经尝试了几个函数和常数值以及每个函数的组合。但我几个月前就碰壁了，而且我经常用头撞墙，但没有任何进展。
下面是我在工作簿中设置的 API 模块的相关代码，被简化为可以轻松复制到新模块中，在新工作簿中，带有一个新的用户窗体模块仅包含一个新的 TreeView 控件。它几乎是从论坛上复制过来的，并且为了我自己的缘故做了很多注释。评论还应该解释我的推理，这可能是不正确的。最后，我还在一些评论中指出了 ('NOTE - ...) 代码的问题和变化。
Option Explicit
'Function GetFileIcon constants and variables
'Constants define values in UDT and enum variables
'Variables used in function parameters and declared function SHGetFileInfo,
' which is called by GetFileIcon
Private Const MAX_PATH As Long = 260
Private Const SHGFI_ICON As Long = &H100
Private Const SHGFI_SMALLICON As Long = &H1
Private Const SHGFI_LARGEICON As Long = &H0
'Structure that contains file info
Private Type SHFILEINFO
'Handle to the file icon
hIcon As Long
'Icon image index within system image list
iIcon As Long
'Flag for one or more file attribute
dwAttributes As Long
'Path and file name as it appears in the Windows shell
szDisplayName As String * MAX_PATH
'File type description
szTypeName As String * 80
End Type
'Icon size in pixels
Public Enum isccIconSizeConst
'32x32 icon
isccLargeIcon = SHGFI_LARGEICON
'16x16 icon
isccSmallIcon = SHGFI_SMALLICON
End Enum
'Icon type, seems to be defined by usage
Public Enum itccIconTypeConst
'Normal icon, unclear how normal is defined
itccNormalIcon = SHGFI_ICON
End Enum
'UDT that stores a Globally Unique IDentifier (GUID), a 128-bit integer
' used to identify resources
'Used by function IconToPicture and declared function
' OleCreatePictureIndirect, which is called by IconToPicture
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'Conditional compilation of API declared functions, evaluating
' Version of VBA installed (VBA7 or VBA6) and
' Windows system type (64- or 32-bit environment)
'Compatibility of long variable type (Long vs LongPtr), library file,
' and alias within the library file vary with VBA version and Windows
' system type
#If VBA7 Then
'UDT that stores bitmap info
'Used by function IconToPicture and declared function
' OleCreatePictureIndirect, which is called by IconToPicture
'Long variable type of some elements varies depending VBA version
Private Type uPicDesc
cbSize As Long 'Size of structure
picType As Long 'Type of picture
hImage As LongPtr 'Handle to image
hPal As LongPtr 'Handle to palette
End Type
#If Win64 Then 'also VBA7
'Convert a handle into an Object Linking and Embedding (OLE)
' IPicture interface object
'IPicture parameter type is an interface that manages a picture
' object and its properties
'Called by IconToPicture
Private Declare PtrSafe Function OleCreatePictureIndirect _
Lib "oleaut32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As LongPtr, _
ByRef IPic As IPicture) _
As LongPtr
#Else 'Win32 and VBA7
'See previous instance of function for description
Private Declare PtrSafe Function OleCreatePictureIndirect _
Lib "olepro32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As LongPtr, _
ByRef IPic As IPicture) _
As LongPtr
'NOTE - assuming that "oleaut32.dll" is the only option available for Win32
'This shouldn't be a factor currently since the machine used runs Win64
#End If 'the following are Win32 or Win64 but still VBA7
'Get the handle of an icon from an executable file (EXE),
' dynamic-link library (DLL), or icon file (ICO)
Private Declare PtrSafe Function ExtractIcon _
Lib "SHELL32.DLL" Alias "ExtractIconA" ( _
ByVal hInst As LongPtr, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) _
As LongPtr
'Get info about an object in the file system (e.g. file, folder,
' directory, drive root)
'Description of parameters
' spszPath, string that contains file path and name,
' absolute or relative
' dwFileAttributes, flags that represent what file info to assume
' psfi, SHFILEINFO structure that contains file info
' cbFileInfo, file size in bytes of the SHFILEINFO structure
' uFlags, flags that represent what file info to retrieve
'To get info from existing file system object
' pszPath must be a valid path or name
' dwFileAttributes value is ignored, set to 0
' psfi must be empty SHFILEINFO variable
' cbFileInfo should be LenB of psfi
' uFlags should be variable with flags added via
' bitwise operation
'To get info from file type/extension in general
' pszPath can be just the file extension
' dwFileAttributes must include FILE_ATTRIBUTE_NORMAL
' psfi must be empty SHFILEINFO variable
' cbFileInfo should be LenB of psfi
' uFlags must include SHGFI_USEFILEATTRIBUTES, along with flags
' that represent what file info to retrieve
'Microsoft suggests that, if this function returns an icon
' handle, freeing system memory after with DestroyIcon function
'Called by GetFileIcon
Private Declare PtrSafe Function SHGetFileInfo _
Lib "Shell32" Alias "SHGetFileInfoA" ( _
ByVal pszPath As String, _
ByVal dwFileAttributes As LongPtr, _
ByRef psfi As SHFILEINFO, _
ByVal cbFileInfo As LongPtr, _
ByVal uFlags As LongPtr _
) As LongPtr
#Else 'VBA6 or earlier, either Win32 or Win64
'See previous instance of UDT for description
Private Type uPicDesc
cbSize As Long
picType As Long
hImage As Long
hPal As Long
End Type
'See previous instance of function for description
Private Declare Function ExtractIcon _
Lib "SHELL32.DLL" Alias "ExtractIconA" ( _
ByVal hInst As Long, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) _
As Long
'See previous instance of function for description
Private Declare Function SHGetFileInfo _
Lib "Shell32" Alias "SHGetFileInfoA" ( _
ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _
ByRef psfi As SHFILEINFO, _
ByVal cbFileInfo As Long, _
ByVal uFlags As Long) _
As Long
'See previous instance of function for description
Private Declare Function OleCreatePictureIndirect _
Lib "oleaut32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPicture) _
As Long
#End If
Public Sub TestPopulateTreeView(ByRef rtvwView As MSComctlLib.TreeView)
'Set TreeView nodes and node properties
'Called by UserForm_Initialize event
'Assume simple UserForm with single TreeView control
'Arguments for TreeView.Nodes.Add:
'Relative
'String that matches the key of the parent
'Relationship
'tvwFirst , tvwLast, tvwNext, tvwPrevious, tvwChild
'If tvwChild, then Relative is required
'key
'Unique string
'Text
'String to be displayed in the tree
'Image
'Index in an ImageList control, shown by default
'SelectedImage
'Index in an ImageList control, shown when selected
Dim varKey As Variant
Dim imlTvw As MSComctlLib.ImageList
Set imlTvw = New MSComctlLib.ImageList
'Set TreeView properties
With rtvwView
'Clear the TreeView of existing nodes
.Nodes.Clear
'Turn on checkboxes so user can select options
.CheckBoxes = True
'Set the behavior of the branch lines
'Tree lines disables any collapsing of the tree
'Root lines allow the tree to be collapsed at root level
.LineStyle = tvwTreeLines
'Set style of branch lines to exclude minimize and maximize buttons
.Style = tvwTreelinesText
'Set the behavior of the node text
'Manual prevents user from editing the text in the tree
'Automatic allows user to edit the text in the tree
.LabelEdit = tvwManual
End With
'Build ImageList of icons for use in the TreeView
With imlTvw.ListImages
'Extract the icon from a simple MS Word document
.Add 1, "test1", _
GetFileIcon("C:\Temp\New Microsoft Word Document.docx")
'NOTE - after this line, values for imlTvw.ListImages.Item(1).Picture from
'the variable Watch window are:
' Handle = 10-digit integer
' varies as I experiment with source files, which is expected
' Height = 423
' I assumed this would be 16, given that the
' GetFileIcon iscIconSize = isccSmallIcon = 16
' hPal = <Automation error>
' that "value" is what the Watch window reports verbatim
' I strongly suspect this is what's causing the issue
' Type = 3
' I honestly don't know if this is correct, but the one site that
' addressed it has named the constant vbPicTypeIcon, seemed relevant
' Width = 423
' same thing as Height, I assumed this would be 16
End With
'Set ImageList to TreeView
Set rtvwView.ImageList = imlTvw
'Populate node(s) in TreeView
With rtvwView
'Create node with no parent, added to root level
.Nodes.Add _
Relationship:=tvwNext, _
key:="node1"
'Set node default properties
With .Nodes("node1")
.Checked = True
.Text = "node1"
.Expanded = True
.Image = 1
'NOTE - there is no error after setting the .Image property, but once the
'UserForm is loaded, there is no icon image displayed in the TreeView
End With
End With
End Sub
Public Function GetFileIcon( _
ByVal strPath As String, _
Optional ByVal iscIconSize As isccIconSizeConst = isccSmallIcon, _
Optional ByVal itcIconType As itccIconTypeConst = itccNormalIcon) _
As IPicture
'Retrieve the icon associated to a file/folder
'Return the description of the specified file/folder
'For example "Folder", "Executable File", "Bmp Image", etc
'Uses the IconToPicture function
'NOTE - also tried StdPicture and IPictureDisp types
Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Const SHGFI_USEFILEATTRIBUTES As Long = &H10
Dim sfiInfo As SHFILEINFO
Dim lngIconType As Long
'Set the icon flag to include size and normal type
'Overrides any other type accidentally passed to function when called
If itcIconType = itccNormalIcon Then
lngIconType = iscIconSize Or itcIconType
Else
lngIconType = iscIconSize Or itccNormalIcon
End If
'Retrieve the file's icon handle
Call SHGetFileInfo(strPath, 0, sfiInfo, LenB(sfiInfo), lngIconType)
'NOTE - also tried retrieving from the general file type/extension
'defined by the system:
' Call SHGetFileInfo(strPath, FILE_ATTRIBUTE_NORMAL, sfiInfo, LenB(sfiInfo), _
' SHGFI_USEFILEATTRIBUTES Or lngIconType)
' 'Convert the icon handle to a picture object
Set GetFileIcon = IconToPicture(sfiInfo.hIcon)
'TESTING, trying out extracticon to see if that has better luck
'NOTE - also tried replacing the code above with an alternative method,
'retrieving an icon from an executable using another API function:
'
' Dim lngIcon As Long
'
' 'Retrieve icon handle from an executable
' lngIcon = ExtractIcon(0, "xwizard.exe", 0)
'
' 'Convert the icon handle to a picture object
' Set GetFileIcon = IconToPicture(lngIcon)
End Function
Public Function IconToPicture( _
hIcon As Long) _
As IPicture
'Convert an icon handle into a picture object
'Constant sourced on 2019-11-22 from
'
' /how-do-i-convert-a-stdole-stdpicture-to-a-different-type
Const vbPicTypeIcon As Long = 3
Dim pic As uPicDesc
Dim IID_IDispatch As GUID
Dim ipdIcon As IPicture
Dim lngResult As Long
'Initialize the uPicDesc structure
With pic
.cbSize = LenB(pic)
.picType = vbPicTypeIcon
.hImage = hIcon
'NOTE - hPal is not set and defaults to 0
End With
'Create the interface GUID
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
'NOTE - this is the most common GUID I've found across forums
'I have also encountered and tried the following one, sourced from
'http://www.vbforums.com/showthread.php
' ?770797-How-do-I-use-OleCreatePictureIndirect
' With IID_IDispatch
' .Data1 = &H7BF80980
' .Data2 = &HBF32
' .Data3 = &H101A
' .Data4(0) = &H8B
' .Data4(1) = &HBB
' .Data4(2) = &H0
' .Data4(3) = &HAA
' .Data4(4) = &H0
' .Data4(5) = &H30
' .Data4(6) = &HC
' .Data4(7) = &HAB
' End With
'Create the picture and return an object reference as the function result
lngResult = OleCreatePictureIndirect(pic, IID_IDispatch, True, ipdIcon)
'Confirm that the image was captured before setting function to picture
If lngResult = 0 Then
Set IconToPicture = ipdIcon
End If
'NOTE - assuming that 0 means successful
'found return value names (but no numeric values) listed at
'http://allapi.mentalis.org/apilist/OleCreatePictureIndirect.shtml
End Function
整个图标的事情甚至都不是优先事项。图像图标一直是 "nice to have." 但是已经过去了这么久，我花了很多精力试图弄清楚它现在是仇杀。为了我的理智，我很想知道我的代码有什么问题；它变成了我的白鲸...
要查看图标，请更改此行
.Style = tvwTreelinesText
给这个：
.Style = tvwTreelinesPictureText
我正在为我部门的用户创建一个用户表单，允许他们从模板 select files/subfolders 创建一个工作文件夹。这是在 Windows 10 Enterprise 64 位桌面上使用 VBA7 到 Excel 2010（该部门唯一可用的工具...）完成的。裸露的骨头，效果很好。我什至成功地使用了其他 API 函数来使 Excel 用户窗体在用户看来就像它自己的独立应用程序一样。现在我只是想添加一些文件图标，让用户更容易（更漂亮）地进行可视化。
在用户窗体初始化期间添加图标的逻辑归结为：
1) 在 运行 时间
填充文件模板源路径的字典2) 使用此字典用表示文件的节点填充 TreeView
3) 使用字典中相同的文件路径为每个节点分配图标，使用API函数从文件中提取图标
我浏览了很多关于使用 API 函数从文件中提取图标并以某种方式将它们转换为用户窗体控件可用图像的论坛和代码数据库。我已经尝试了几个函数和常数值以及每个函数的组合。但我几个月前就碰壁了，而且我经常用头撞墙，但没有任何进展。
下面是我在工作簿中设置的 API 模块的相关代码，被简化为可以轻松复制到新模块中，在新工作簿中，带有一个新的用户窗体模块仅包含一个新的 TreeView 控件。它几乎是从论坛上复制过来的，并且为了我自己的缘故做了很多注释。评论还应该解释我的推理，这可能是不正确的。最后，我还在一些评论中指出了 ('NOTE - ...) 代码的问题和变化。
Option Explicit
'Function GetFileIcon constants and variables
'Constants define values in UDT and enum variables
'Variables used in function parameters and declared function SHGetFileInfo,
' which is called by GetFileIcon
Private Const MAX_PATH As Long = 260
Private Const SHGFI_ICON As Long = &H100
Private Const SHGFI_SMALLICON As Long = &H1
Private Const SHGFI_LARGEICON As Long = &H0
'Structure that contains file info
Private Type SHFILEINFO
'Handle to the file icon
hIcon As Long
'Icon image index within system image list
iIcon As Long
'Flag for one or more file attribute
dwAttributes As Long
'Path and file name as it appears in the Windows shell
szDisplayName As String * MAX_PATH
'File type description
szTypeName As String * 80
End Type
'Icon size in pixels
Public Enum isccIconSizeConst
'32x32 icon
isccLargeIcon = SHGFI_LARGEICON
'16x16 icon
isccSmallIcon = SHGFI_SMALLICON
End Enum
'Icon type, seems to be defined by usage
Public Enum itccIconTypeConst
'Normal icon, unclear how normal is defined
itccNormalIcon = SHGFI_ICON
End Enum
'UDT that stores a Globally Unique IDentifier (GUID), a 128-bit integer
' used to identify resources
'Used by function IconToPicture and declared function
' OleCreatePictureIndirect, which is called by IconToPicture
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'Conditional compilation of API declared functions, evaluating
' Version of VBA installed (VBA7 or VBA6) and
' Windows system type (64- or 32-bit environment)
'Compatibility of long variable type (Long vs LongPtr), library file,
' and alias within the library file vary with VBA version and Windows
' system type
#If VBA7 Then
'UDT that stores bitmap info
'Used by function IconToPicture and declared function
' OleCreatePictureIndirect, which is called by IconToPicture
'Long variable type of some elements varies depending VBA version
Private Type uPicDesc
cbSize As Long 'Size of structure
picType As Long 'Type of picture
hImage As LongPtr 'Handle to image
hPal As LongPtr 'Handle to palette
End Type
#If Win64 Then 'also VBA7
'Convert a handle into an Object Linking and Embedding (OLE)
' IPicture interface object
'IPicture parameter type is an interface that manages a picture
' object and its properties
'Called by IconToPicture
Private Declare PtrSafe Function OleCreatePictureIndirect _
Lib "oleaut32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As LongPtr, _
ByRef IPic As IPicture) _
As LongPtr
#Else 'Win32 and VBA7
'See previous instance of function for description
Private Declare PtrSafe Function OleCreatePictureIndirect _
Lib "olepro32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As LongPtr, _
ByRef IPic As IPicture) _
As LongPtr
'NOTE - assuming that "oleaut32.dll" is the only option available for Win32
'This shouldn't be a factor currently since the machine used runs Win64
#End If 'the following are Win32 or Win64 but still VBA7
'Get the handle of an icon from an executable file (EXE),
' dynamic-link library (DLL), or icon file (ICO)
Private Declare PtrSafe Function ExtractIcon _
Lib "SHELL32.DLL" Alias "ExtractIconA" ( _
ByVal hInst As LongPtr, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) _
As LongPtr
'Get info about an object in the file system (e.g. file, folder,
' directory, drive root)
'Description of parameters
' spszPath, string that contains file path and name,
' absolute or relative
' dwFileAttributes, flags that represent what file info to assume
' psfi, SHFILEINFO structure that contains file info
' cbFileInfo, file size in bytes of the SHFILEINFO structure
' uFlags, flags that represent what file info to retrieve
'To get info from existing file system object
' pszPath must be a valid path or name
' dwFileAttributes value is ignored, set to 0
' psfi must be empty SHFILEINFO variable
' cbFileInfo should be LenB of psfi
' uFlags should be variable with flags added via
' bitwise operation
'To get info from file type/extension in general
' pszPath can be just the file extension
' dwFileAttributes must include FILE_ATTRIBUTE_NORMAL
' psfi must be empty SHFILEINFO variable
' cbFileInfo should be LenB of psfi
' uFlags must include SHGFI_USEFILEATTRIBUTES, along with flags
' that represent what file info to retrieve
'Microsoft suggests that, if this function returns an icon
' handle, freeing system memory after with DestroyIcon function
'Called by GetFileIcon
Private Declare PtrSafe Function SHGetFileInfo _
Lib "Shell32" Alias "SHGetFileInfoA" ( _
ByVal pszPath As String, _
ByVal dwFileAttributes As LongPtr, _
ByRef psfi As SHFILEINFO, _
ByVal cbFileInfo As LongPtr, _
ByVal uFlags As LongPtr _
) As LongPtr
#Else 'VBA6 or earlier, either Win32 or Win64
'See previous instance of UDT for description
Private Type uPicDesc
cbSize As Long
picType As Long
hImage As Long
hPal As Long
End Type
'See previous instance of function for description
Private Declare Function ExtractIcon _
Lib "SHELL32.DLL" Alias "ExtractIconA" ( _
ByVal hInst As Long, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) _
As Long
'See previous instance of function for description
Private Declare Function SHGetFileInfo _
Lib "Shell32" Alias "SHGetFileInfoA" ( _
ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _
ByRef psfi As SHFILEINFO, _
ByVal cbFileInfo As Long, _
ByVal uFlags As Long) _
As Long
'See previous instance of function for description
Private Declare Function OleCreatePictureIndirect _
Lib "oleaut32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPicture) _
As Long
#End If
Public Sub TestPopulateTreeView(ByRef rtvwView As MSComctlLib.TreeView)
'Set TreeView nodes and node properties
'Called by UserForm_Initialize event
'Assume simple UserForm with single TreeView control
'Arguments for TreeView.Nodes.Add:
'Relative
'String that matches the key of the parent
'Relationship
'tvwFirst , tvwLast, tvwNext, tvwPrevious, tvwChild
'If tvwChild, then Relative is required
'key
'Unique string
'Text
'String to be displayed in the tree
'Image
'Index in an ImageList control, shown by default
'SelectedImage
'Index in an ImageList control, shown when selected
Dim varKey As Variant
Dim imlTvw As MSComctlLib.ImageList
Set imlTvw = New MSComctlLib.ImageList
'Set TreeView properties
With rtvwView
'Clear the TreeView of existing nodes
.Nodes.Clear
'Turn on checkboxes so user can select options
.CheckBoxes = True
'Set the behavior of the branch lines
'Tree lines disables any collapsing of the tree
'Root lines allow the tree to be collapsed at root level
.LineStyle = tvwTreeLines
'Set style of branch lines to exclude minimize and maximize buttons
.Style = tvwTreelinesText
'Set the behavior of the node text
'Manual prevents user from editing the text in the tree
'Automatic allows user to edit the text in the tree
.LabelEdit = tvwManual
End With
'Build ImageList of icons for use in the TreeView
With imlTvw.ListImages
'Extract the icon from a simple MS Word document
.Add 1, "test1", _
GetFileIcon("C:\Temp\New Microsoft Word Document.docx")
'NOTE - after this line, values for imlTvw.ListImages.Item(1).Picture from
'the variable Watch window are:
' Handle = 10-digit integer
' varies as I experiment with source files, which is expected
' Height = 423
' I assumed this would be 16, given that the
' GetFileIcon iscIconSize = isccSmallIcon = 16
' hPal = <Automation error>
' that "value" is what the Watch window reports verbatim
' I strongly suspect this is what's causing the issue
' Type = 3
' I honestly don't know if this is correct, but the one site that
' addressed it has named the constant vbPicTypeIcon, seemed relevant
' Width = 423
' same thing as Height, I assumed this would be 16
End With
'Set ImageList to TreeView
Set rtvwView.ImageList = imlTvw
'Populate node(s) in TreeView
With rtvwView
'Create node with no parent, added to root level
.Nodes.Add _
Relationship:=tvwNext, _
key:="node1"
'Set node default properties
With .Nodes("node1")
.Checked = True
.Text = "node1"
.Expanded = True
.Image = 1
'NOTE - there is no error after setting the .Image property, but once the
'UserForm is loaded, there is no icon image displayed in the TreeView
End With
End With
End Sub
Public Function GetFileIcon( _
ByVal strPath As String, _
Optional ByVal iscIconSize As isccIconSizeConst = isccSmallIcon, _
Optional ByVal itcIconType As itccIconTypeConst = itccNormalIcon) _
As IPicture
'Retrieve the icon associated to a file/folder
'Return the description of the specified file/folder
'For example "Folder", "Executable File", "Bmp Image", etc
'Uses the IconToPicture function
'NOTE - also tried StdPicture and IPictureDisp types
Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Const SHGFI_USEFILEATTRIBUTES As Long = &H10
Dim sfiInfo As SHFILEINFO
Dim lngIconType As Long
'Set the icon flag to include size and normal type
'Overrides any other type accidentally passed to function when called
If itcIconType = itccNormalIcon Then
lngIconType = iscIconSize Or itcIconType
Else
lngIconType = iscIconSize Or itccNormalIcon
End If
'Retrieve the file's icon handle
Call SHGetFileInfo(strPath, 0, sfiInfo, LenB(sfiInfo), lngIconType)
'NOTE - also tried retrieving from the general file type/extension
'defined by the system:
' Call SHGetFileInfo(strPath, FILE_ATTRIBUTE_NORMAL, sfiInfo, LenB(sfiInfo), _
' SHGFI_USEFILEATTRIBUTES Or lngIconType)
' 'Convert the icon handle to a picture object
Set GetFileIcon = IconToPicture(sfiInfo.hIcon)
'TESTING, trying out extracticon to see if that has better luck
'NOTE - also tried replacing the code above with an alternative method,
'retrieving an icon from an executable using another API function:
'
' Dim lngIcon As Long
'
' 'Retrieve icon handle from an executable
' lngIcon = ExtractIcon(0, "xwizard.exe", 0)
'
' 'Convert the icon handle to a picture object
' Set GetFileIcon = IconToPicture(lngIcon)
End Function
Public Function IconToPicture( _
hIcon As Long) _
As IPicture
'Convert an icon handle into a picture object
'Constant sourced on 2019-11-22 from
'
' /how-do-i-convert-a-stdole-stdpicture-to-a-different-type
Const vbPicTypeIcon As Long = 3
Dim pic As uPicDesc
Dim IID_IDispatch As GUID
Dim ipdIcon As IPicture
Dim lngResult As Long
'Initialize the uPicDesc structure
With pic
.cbSize = LenB(pic)
.picType = vbPicTypeIcon
.hImage = hIcon
'NOTE - hPal is not set and defaults to 0
End With
'Create the interface GUID
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
'NOTE - this is the most common GUID I've found across forums
'I have also encountered and tried the following one, sourced from
'http://www.vbforums.com/showthread.php
' ?770797-How-do-I-use-OleCreatePictureIndirect
' With IID_IDispatch
' .Data1 = &H7BF80980
' .Data2 = &HBF32
' .Data3 = &H101A
' .Data4(0) = &H8B
' .Data4(1) = &HBB
' .Data4(2) = &H0
' .Data4(3) = &HAA
' .Data4(4) = &H0
' .Data4(5) = &H30
' .Data4(6) = &HC
' .Data4(7) = &HAB
' End With
'Create the picture and return an object reference as the function result
lngResult = OleCreatePictureIndirect(pic, IID_IDispatch, True, ipdIcon)
'Confirm that the image was captured before setting function to picture
If lngResult = 0 Then
Set IconToPicture = ipdIcon
End If
'NOTE - assuming that 0 means successful
'found return value names (but no numeric values) listed at
'http://allapi.mentalis.org/apilist/OleCreatePictureIndirect.shtml
End Function
整个图标的事情甚至都不是优先事项。图像图标一直是 "nice to have." 但是已经过去了这么久，我花了很多精力试图弄清楚它现在是仇杀。为了我的理智，我很想知道我的代码有什么问题；它变成了我的白鲸...
要查看图标，请更改此行
.Style = tvwTreelinesText
给这个：
.Style = tvwTreelinesPictureText