leadergl
18-02-2006, 14:53
salve vorrei fare in modo che una mia ImageList venga "riempita" con le varie icone di sistema riguardanti le "Unità Disco", le icone dei files...etc...
ora riguardo le icone dei files non ho molti problemi ma per ottenere e disegnare le altre invece trovo difficoltà e non riesco a capire il perchè:
Option Explicit
Public Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Public Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * 260
szTypeName As String * 80
End Type
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Function IconaFile(ByVal Ext As String, IML As ImageList, _
Optional ByVal SmallIcon As Boolean = False) As Integer
' aggiunge l'icona legata al tipo di file (ext = estensione) ad IML (ImageList)
' e restituisce l'indice della nuova icona aggiunta ad IML
Dim esisteIco As Boolean
Dim xImage As ListImage
Dim retval As Long
Dim info As SHFILEINFO ' receives information about the file
retval = SHGetFileInfo("x." & Ext, FILE_ATTRIBUTE_ARCHIVE, info, Len(info), _
SHGFI_USEFILEATTRIBUTES Or SHGFI_TYPENAME Or SHGFI_ICON Or SHGFI_SMALLICON)
IML.ListImages.Add , Ext, ConvertIcon(info.hIcon)
IconaFile = IML.ListImages(Ext).Index
' Destroy the icon handle to save resources.
retval = DestroyIcon(info.hIcon)
End Function
Public Function ConvertIcon(hIcon) As Picture
Dim NewPic As Picture
Dim PicConv As PicBmp
Dim IGuid As GUID
On Error GoTo GestioneErrori
If hIcon = 0 Then Exit Function
With PicConv
.Size = Len(PicConv)
.Type = vbPicTypeIcon
.hBmp = hIcon
End With
IGuid.Data1 = &H20400
IGuid.Data4(0) = &HC0
IGuid.Data4(7) = &H46
Call OleCreatePictureIndirect(PicConv, IGuid, True, NewPic)
Set ConvertIcon = NewPic
Exit Function
GestioneErrori:
Debug.Print Err.Number, Err.Description
End Function
ma modificandolo anche leggermente al fine di ottenere le icone di:
"Desktop"
"Unità Disco"
"Directory Speciali"
non mi funziona più niente....chi sa come aiutarmi?
P.S. riesco però a stampare la giusta icona all'interno di una form tramite il comando:
Private Sub Form_Load()
Dim hImage As Long
Dim udtFI As SHFILEINFO
'set the graphics mode of form1 to persistent
Me.AutoRedraw = True
'get the handle of the system image list that contains the large icon images
hImage = SHGetFileInfo("c:\", ByVal 0&, udtFI, Len(udtFI), SHGFI_SYSICONINDEX Or SHGFI_LARGEICON)
'draw the icon (normal)
ImageList_Draw hImage, udtFI.iIcon, Me.hDC, 0, 0, ILD_TRANSPARENT
End Sub
ora riguardo le icone dei files non ho molti problemi ma per ottenere e disegnare le altre invece trovo difficoltà e non riesco a capire il perchè:
Option Explicit
Public Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Public Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * 260
szTypeName As String * 80
End Type
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Function IconaFile(ByVal Ext As String, IML As ImageList, _
Optional ByVal SmallIcon As Boolean = False) As Integer
' aggiunge l'icona legata al tipo di file (ext = estensione) ad IML (ImageList)
' e restituisce l'indice della nuova icona aggiunta ad IML
Dim esisteIco As Boolean
Dim xImage As ListImage
Dim retval As Long
Dim info As SHFILEINFO ' receives information about the file
retval = SHGetFileInfo("x." & Ext, FILE_ATTRIBUTE_ARCHIVE, info, Len(info), _
SHGFI_USEFILEATTRIBUTES Or SHGFI_TYPENAME Or SHGFI_ICON Or SHGFI_SMALLICON)
IML.ListImages.Add , Ext, ConvertIcon(info.hIcon)
IconaFile = IML.ListImages(Ext).Index
' Destroy the icon handle to save resources.
retval = DestroyIcon(info.hIcon)
End Function
Public Function ConvertIcon(hIcon) As Picture
Dim NewPic As Picture
Dim PicConv As PicBmp
Dim IGuid As GUID
On Error GoTo GestioneErrori
If hIcon = 0 Then Exit Function
With PicConv
.Size = Len(PicConv)
.Type = vbPicTypeIcon
.hBmp = hIcon
End With
IGuid.Data1 = &H20400
IGuid.Data4(0) = &HC0
IGuid.Data4(7) = &H46
Call OleCreatePictureIndirect(PicConv, IGuid, True, NewPic)
Set ConvertIcon = NewPic
Exit Function
GestioneErrori:
Debug.Print Err.Number, Err.Description
End Function
ma modificandolo anche leggermente al fine di ottenere le icone di:
"Desktop"
"Unità Disco"
"Directory Speciali"
non mi funziona più niente....chi sa come aiutarmi?
P.S. riesco però a stampare la giusta icona all'interno di una form tramite il comando:
Private Sub Form_Load()
Dim hImage As Long
Dim udtFI As SHFILEINFO
'set the graphics mode of form1 to persistent
Me.AutoRedraw = True
'get the handle of the system image list that contains the large icon images
hImage = SHGetFileInfo("c:\", ByVal 0&, udtFI, Len(udtFI), SHGFI_SYSICONINDEX Or SHGFI_LARGEICON)
'draw the icon (normal)
ImageList_Draw hImage, udtFI.iIcon, Me.hDC, 0, 0, ILD_TRANSPARENT
End Sub