"难道一个图标文件保存有好几个图标?" 一个dll ocx或exe 有可能包含数个甚至上百个图标."使用picturebox控件载入得时候分辨率却变的非常低" 不会吧,抓到的图标再显示出来并没啥两样.【CBM666 的将系统图标添加进imagelist中】'添加 ImageList1 Command1 Picture1 Image1Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long 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 ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, lpiIcon 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 Dim i&, ticons&, p&()Private Sub Form_Load() With Picture1 .Width = 480 .Height = 480 .BorderStyle = 0 .AutoRedraw = True End With Me.Width = 8000 Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 Me.AutoRedraw = True End SubPrivate Sub Command1_Click() Call Geticonall(Me, Environ("windir") & "\system32\shell32.dll") '改为你自己的路径,OCX DLL皆可. End SubPublic Function Geticonall(pic1 As Object, pathstr As String) As Long On Error Resume Next If TypeOf pic1 Is Form Or TypeOf pic1 Is PictureBox Then pic1.AutoRedraw = False ticons = ExtractIcon(App.hInstance, pathstr, -1) For i = 0 To ticons - 1 ReDim Preserve p&(i) p(i) = ExtractAssociatedIcon(App.hInstance, pathstr, i) '读取每个图标 DrawIcon pic1.hdc, 32 * i, 0, p(i) BitBlt Picture1.hdc, 0, 0, 32, 32, pic1.hdc, i * 32, 0, vbSrcCopy ImageList1.ListImages.Add i + 1, "a" & i + 1, Picture1.Image 'ListView1.SmallIcons = ImageList1 'Set itm = ListView1.ListItems.Add(, "Row" & CStr(i), EXEName, 1, i) Picture1.Picture = Picture1.Image 'picture1可以拖到窗体外面 Picture1.Refresh DestroyIcon p(i) Next i Geticonall = ticons '返回共有几个图标 Image1.Picture = ImageList1.ListImages(3).Picture '验证是否已进入ImageList,别无它用 End Function
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 ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, lpiIcon 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
Dim i&, ticons&, p&()Private Sub Form_Load()
With Picture1
.Width = 480
.Height = 480
.BorderStyle = 0
.AutoRedraw = True
End With
Me.Width = 8000
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
Me.AutoRedraw = True
End SubPrivate Sub Command1_Click()
Call Geticonall(Me, Environ("windir") & "\system32\shell32.dll") '改为你自己的路径,OCX DLL皆可.
End SubPublic Function Geticonall(pic1 As Object, pathstr As String) As Long
On Error Resume Next
If TypeOf pic1 Is Form Or TypeOf pic1 Is PictureBox Then pic1.AutoRedraw = False
ticons = ExtractIcon(App.hInstance, pathstr, -1)
For i = 0 To ticons - 1
ReDim Preserve p&(i)
p(i) = ExtractAssociatedIcon(App.hInstance, pathstr, i) '读取每个图标
DrawIcon pic1.hdc, 32 * i, 0, p(i)
BitBlt Picture1.hdc, 0, 0, 32, 32, pic1.hdc, i * 32, 0, vbSrcCopy
ImageList1.ListImages.Add i + 1, "a" & i + 1, Picture1.Image
'ListView1.SmallIcons = ImageList1
'Set itm = ListView1.ListItems.Add(, "Row" & CStr(i), EXEName, 1, i)
Picture1.Picture = Picture1.Image 'picture1可以拖到窗体外面
Picture1.Refresh
DestroyIcon p(i)
Next i
Geticonall = ticons '返回共有几个图标
Image1.Picture = ImageList1.ListImages(3).Picture '验证是否已进入ImageList,别无它用
End Function
我抓到的所有图标是画在 pic1这个图像匡里面
使用BitBlt将上面图像的一个区块拷到Picture1的影像里面