Я создаю пользовательскую форму для пользователей в моем отделе, которая позволит им выбирать файлы / подпапки из шаблонов для создания рабочей папки. Это делается с помощью VBA7 до Excel 2010 (единственный инструмент, доступный для этого отдела ...) на 64-битном настольном компьютере Windows 10 Enterprise. Голые кости, это прекрасно работает. Я даже успешно использовал другие функции API, чтобы пользовательская форма Excel отображалась пользователю как его отдельное приложение. Сейчас я просто пытаюсь добавить некоторые значки файлов, чтобы пользователям было проще (и красивее) их визуализировать.
Логика c добавления значков во время инициализации пользовательской формы сводится к:
1) Заполните словарь путей к исходным шаблонам файлов во время выполнения
2) Заполните TreeView узлами, которые представляют файлы, используя этот словарь
3) Используйте то же самое пути к файлам в словаре для назначения значков каждому узлу с помощью функций API для извлечения значков из файлов
Я просмотрел множество форумов и баз данных кода об использовании функций API для извлечения значков из файлов и их преобразования каким-то образом в полезное изображение для пользовательских элементов управления. Я экспериментировал с несколькими функциями и постоянными значениями и комбинациями каждого из них. Но я врезался в стену месяцами go, и я постоянно бился головой об это без какого-либо прогресса.
Ниже приведен соответствующий код из модуля API, который я настроил в рабочей книге, сокращенный до простого копирования в новый модуль, в новую рабочую книгу с помощью пользовательского модуля fre sh, который содержит только новый элемент управления TreeView. Это в значительной степени copypasta с форумов и сильно аннотировано ради меня самого. Комментарии должны также объяснить мои рассуждения, которые могут быть неверными. Наконец, я также отметил ('ПРИМЕЧАНИЕ - ...) проблемы и варианты кода в некоторых комментариях.
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
'https://stackoverflow.com/questions/1507385
' /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
Вся эта иконка даже не является приоритетом. Иконки с изображениями всегда были хорошими. Но это было так долго, и я потратил столько усилий, чтобы понять это, что теперь это вендетта. Я отчаянно хочу знать, что не так в моем коде ради моего здравомыслия; это стало моим белым китом ...