声明画图标函数DrawIcon 声明取得文件句柄函数GetModuleHandle 声明提取图标函数ExtractIcon Dim icon_n As Integer Dim icon_filename As String Dim icon_num As Integer Dim x As Long Dim hmodule As Long Private Sub Command1_Click() CommonDialog1.FileName = "" CommonDialog1.Filter = "程序文件|*.exe" CommonDialog1.ShowOpen icon_filename = CommonDialog1.FileName Picture1.Cls hmodule = GetModuleHandle(icon_filename) '取得文件句柄 icon_num = ExtractIcon(hmodule, icon_filename, -1) '得到文件内图标总数 HScroll1.Max = icon_num Label1.Caption = Str(icon_num) If icon_num - 1 > 0 Then HScroll1.Enabled = True Else HScroll1.Enabled = False End If icon_n = ExtractIcon(hmodule, icon_filename, 0) '提取第一个图标 x = DrawIcon(Picture1.hdc, 0, 0, icon_n) '画出图标 If icon_num = 0 Then HScroll1.Value = 0 Else HScroll1.Value = 1 End If Label2.Caption = HScroll1.Value End Sub Private Sub Command2_Click() End End Sub Private Sub HScroll1_Change() Picture1.Cls icon_n = HScroll1.Value hmodule = GetModuleHandle(icon_filename) icon_n = ExtractIcon(hmodule, icon_filename, icon_n - 1) Label2.Caption = HScroll1.Value x = DrawIcon(Picture1.hdc, 0, 0, icon_n) End Sub
使用下面的示例,你可以方便地从EXE,DLL及ICO文件中提取图标。该示例程序使用ExtractIconEX API函数从文件中提取图标,并返回图标句柄,然后利用该句柄,使用DrawIcon函数将图标绘制到目标设备中。最后清除句柄以释放系统资源。创建新工程后,在工程中添加对Standard OLE Types的引用,然后在工程中添加一个标准模块。将下面的代码粘贴到标准模块中:Option ExplicitPrivate 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 LongPrivate 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 LongPrivate Declare Function DestroyIcon Lib "user32" (ByVal hicon As Long) As LongPublic Function GetIconFromFile(FileName As String, IconIndex As Long, UseLargeIcon As Boolean) As Picture'参数: 'FileName - 包含有图标的文件 (EXE or DLL) 'IconIndex - 欲提取的圉标的索引,从零开始 'UseLargeIcon-如设置为True,则提取大图标,否则提取小图标 '返回值: 包含标标的Picture对象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 GUIDIf ExtractIconEx(FileName, IconIndex, hlargeicon, hsmallicon, 1) > 0 ThenIf 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 = IPicDestroyIcon hsmallicon DestroyIcon hlargeiconEnd If End Function 在窗体中添加一个PictureBox控件和一个命令按钮,把下面的代码加入到命令按钮的Click事件中:Set Picture1.Picture = GetIconFromFile("c:\windows\moricons.dll", _ 0, True)按F5运行程序,点击命令按钮后,PictureBox会将文件moricons.dll中的图标索引为零的图标画到PictureBox中。
一个按钮,一个listview(listview1),一个imagelist(imagelist1): Option ExplicitPrivate Type PictDesc cbSizeofStruct As Long PicType As Long hImage As Long xExt As Long yExt As Long End Type Private Type Guid Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As LongPrivate Function IconToPicture(ByVal hIcon As Long) As StdPicture If hIcon = 0 Then Exit Function Dim oNewPic As Picture Dim tPicConv As PictDesc Dim IGuid As Guid With tPicConv .cbSizeofStruct = Len(tPicConv) .PicType = vbPicTypeIcon .hImage = hIcon End With With IGuid .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 OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic Set IconToPicture = oNewPic End FunctionPrivate Function BitmapToPicture(ByVal hBmp As Long) As StdPicture Dim oNewPic As Picture, tPicConv As PictDesc, IGuid As Guid With tPicConv .cbSizeofStruct = Len(tPicConv) .PicType = vbPicTypeBitmap .hImage = hBmp End With With IGuid .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic Set BitmapToPicture = oNewPic End Function Private Sub Command1_Click() Dim lIcon As Long, a As Long, sSourcePgm As String Dim ret As Long sSourcePgm = "C:\Documents and Settings\mc\桌面\explorer.exe" '换程你的文件路径 Do lIcon = ExtractIcon(App.hInstance, sSourcePgm, a) If lIcon = 0 Then Exit Do Call ImageList1.ListImages.Add(a + 1, , IconToPicture(lIcon)) a = a + 1 DestroyIcon lIcon Loop Set ListView1.Icons = ImageList1 If a = 0 Then MsgBox "No Icons in this file!" End If Dim i As Long For i = 0 To a - 1 ListView1.ListItems.Add Index:=i + 1, Text:="icon" + CStr(i + 1), Icon:=i + 1 Next End Sub
以上为提取显示.
x = DrawIcon(Picture1.hdc, 0, 0, icon_n)
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 LongPrivate 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 LongPrivate Declare Function DestroyIcon Lib "user32" (ByVal hicon As Long) As LongPublic Function GetIconFromFile(FileName As String, IconIndex As Long, UseLargeIcon As Boolean) As Picture'参数:
'FileName - 包含有图标的文件 (EXE or DLL)
'IconIndex - 欲提取的圉标的索引,从零开始
'UseLargeIcon-如设置为True,则提取大图标,否则提取小图标
'返回值: 包含标标的Picture对象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 GUIDIf ExtractIconEx(FileName, IconIndex, hlargeicon, hsmallicon, 1) > 0 ThenIf 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 = IPicDestroyIcon hsmallicon
DestroyIcon hlargeiconEnd If
End Function
在窗体中添加一个PictureBox控件和一个命令按钮,把下面的代码加入到命令按钮的Click事件中:Set Picture1.Picture = GetIconFromFile("c:\windows\moricons.dll", _ 0, True)按F5运行程序,点击命令按钮后,PictureBox会将文件moricons.dll中的图标索引为零的图标画到PictureBox中。
Option ExplicitPrivate Type PictDesc
cbSizeofStruct As Long
PicType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As LongPrivate Function IconToPicture(ByVal hIcon As Long) As StdPicture
If hIcon = 0 Then Exit Function
Dim oNewPic As Picture
Dim tPicConv As PictDesc
Dim IGuid As Guid
With tPicConv
.cbSizeofStruct = Len(tPicConv)
.PicType = vbPicTypeIcon
.hImage = hIcon
End With
With IGuid
.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
OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic
Set IconToPicture = oNewPic
End FunctionPrivate Function BitmapToPicture(ByVal hBmp As Long) As StdPicture
Dim oNewPic As Picture, tPicConv As PictDesc, IGuid As Guid
With tPicConv
.cbSizeofStruct = Len(tPicConv)
.PicType = vbPicTypeBitmap
.hImage = hBmp
End With
With IGuid
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
OleCreatePictureIndirect tPicConv, IGuid, True, oNewPic
Set BitmapToPicture = oNewPic
End Function
Private Sub Command1_Click()
Dim lIcon As Long, a As Long, sSourcePgm As String
Dim ret As Long
sSourcePgm = "C:\Documents and Settings\mc\桌面\explorer.exe" '换程你的文件路径
Do
lIcon = ExtractIcon(App.hInstance, sSourcePgm, a)
If lIcon = 0 Then Exit Do
Call ImageList1.ListImages.Add(a + 1, , IconToPicture(lIcon))
a = a + 1
DestroyIcon lIcon
Loop
Set ListView1.Icons = ImageList1
If a = 0 Then
MsgBox "No Icons in this file!"
End If
Dim i As Long
For i = 0 To a - 1
ListView1.ListItems.Add Index:=i + 1, Text:="icon" + CStr(i + 1), Icon:=i + 1
Next
End Sub