请问如何提取EXE文件的图标并保存起来？

Question

我想提取EXE文件的图标并保存成一个ICO文件，我找了很多程序，保存以后的ICO文件都是失真的了，效果很差。请问各位有没有比较好的提取EXE文件的图标的代码呢？发一份给小弟我好么。非常感谢

Answer 1

我这有一个，但是有点问题。我找了很长时间没找出来，看你的本事了，我估计问题不大：程序如下：程序中有一个commondialoge控件
Dim sdestfile As String
Dim ssourcepgm As Long
Dim licon 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 ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Sub Command1_Click()
Dim a%
On Error Resume Next
With dlg
.FileName = ssourcepgm
.CancelError = True
.DialogTitle = "请选择包含图示的dll或exe文档"
.Filter = "icon resource(*.ico;*.exe;*.dll)|*.ico;*.exe;*.dll|all files|*.*"
.Action = 1
If Err Then
Err.Clear
Exit Sub
End If
ssourcepgm = .FileName
Label3.Caption = .FileName
DestroyIcon licon
Do
licon = ExtractIcon(App.hInstance, ssourcepgm, a)
If licon = 0 Then Exit Do
a = a + 1
DestroyIcon licon
Loop
If a = 0 Then
MsgBox "在这个文档中没有任何图标"
End If
Label1.Caption = "在这个文档共有" & a & "个图标"
VScroll1.Max = IIf(a = 0, 0, a - 1)
VScroll1.Value = 0
VScroll1_Change
End With
End SubPrivate Sub Command2_Click()
On Error Resume Next
With dlg
.FileName = sdestfile
.CancelError = True
.Action = 2
If Err Then
Err.Clear
Exit Sub
End If
sdestfile = .FileName
SavePicture Picture1.Image, sdestfile
End With
End Sub
Private Sub VScroll1_Change()
Label2.Caption = "正在浏览的图标索引值:" & VScroll1.Value
DestroyIcon licon
Picture1.Cls
licon = ExtractIcon(App.hInstance, ssourcepgm, VScroll1.Value)
Picture1.AutoSize = True
Picture1.AutoRedraw = True
DrawIcon Picture1.hdc, 0, 0, licon
Picture1.Refresh
End Sub