ICONES DE ATALHOS

USUARIO.EXCLUIDOS 17/09/2006 19:49:45
#172036 Resposta escolhida

Voce pode usar a seguinte API
'Gerado com: Lizaro Visual Basic Dicas v4.0
'Copyright© 2001-2006, W.C. Rodrigues (Lizaro Soft). Dicas © dos Autores
'17 de setembro de 2006
'------------------------------

Using this simple sub, you can Get icons easily out of
files, including DLLs, EXEs And ICOs. It uses the
ExtractIconEX API To extract the icon from the file,
And create a handle To the icon. It Then uses the
DrawIcon API To paint the icon On To the destination,
And Then destroys the handles To the icons To free up
resources.

--> Declarations

Copy the following code into the declarations
section of a module.

Private Type PicBmp
Size As Long
tType As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type

Private Type GUID

Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Declare Function OleCreatePictureIndirect _
Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Declare Function ExtractIconEx Lib "shell32.dll" _
Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal _
nIconIndex As Long, phiconLarge As Long, phiconSmall As _
Long, ByVal nIcons As Long) As Long

Private Declare Function DestroyIcon Lib "user32" (ByVal _

hicon As Long) As Long

--> Function

Public Function GetIconFromFile(FileName As String, _
IconIndex As Long, UseLargeIcon As Boolean) As Picture

'Parameters:
'FileName - File (EXE or DLL) containing icons
'IconIndex - Index of icon to extract, starting with 0
'UseLargeIcon-True for a large icon, False for a small icon
'Returns: Picture object, containing icon

Dim hlargeicon As Long
Dim hsmallicon As Long
Dim selhandle As Long

' IPicture requires a reference to "Standard OLE Types."

Dim pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID

If ExtractIconEx(FileName, IconIndex, hlargeicon, _
hsmallicon, 1) > 0 Then

If UseLargeIcon Then
selhandle = hlargeicon
Else
selhandle = hsmallicon
End If

' Fill in with IDispatch Interface ID.
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With

' Fill Pic with necessary parts.
With pic
.Size = Len(pic) ' Length of structure.
.tType = vbPicTypeIcon ' Type of Picture (bitmap).
.hBmp = selhandle ' Handle to bitmap.

End With

' Create Picture object.
Call OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)

' Return the new Picture object.
Set GetIconFromFile = IPic

DestroyIcon hsmallicon
DestroyIcon hlargeicon

End If
End Function

--> Example

Set Picture1.Picture = GetIconFromFile("arquivo.lnk", _
0, True)

This will paint the MS-DOS icon onto Picture1 In the
normal sized icon(ie. 32x32). You can Then use the
PaintPicture Function To rearrange And resize it.

Note: You must Select Standard OLE Types In the Project|References box