VB提取EXE真彩色图标并保存为ICO的问题

[平台想钱想疯了]

一般的方法（SavePicture icn, sIco）， 只能保存为256色的，好像不能是真彩色的。。

我从QQ的EXE中提取到，而而显示出来的是真彩色的，可是一保存为ICO文件时，就变色了。。急。。。

请各位仁兄，帮我。。。给我能解决问题的代码。。。谢谢。。。



以下为我现在用的代码，保存为真彩色的图标就失真了。。。


'获取图标
Dim mIcon As Long
mIcon = ExtractAssociatedIcon(App.hInstance, sExeFile, 0)

' 显示图标
DrawIcon Picture1.hDC, 0, 0, mIcon
' DestroyIcon hIcon
Dim icn As StdPicture
Set icn = CreateOlePicture(mIcon, vbPicTypeIcon)



'Dim myicon As Long
'Dim iLng As Long
'Dim myPicDisp As IPictureDisp
'Dim myIconInfo As ICONINFO

'读出一个图标
'GetIconInfo mIcon, myIconInfo
'获得图标信息
'iLng = CreateIconIndirect(myIconInfo)
'Set myPicDisp = IconToPicture(iLng)
'重新创建一个图标
'Me.Picture1.Picture = myPicDisp
' 将创建完成后的图标显示到pic1



SavePicture icn, "c:\a.ico"

[eslbs]

刚测试了一下，图标在资源文件的字段还不完整，需要加22字节左右的文件头
不知道这22个字节的含义是什么

而且如果不是一个图标而是一个图标组有N个图标的话，不知道又是怎样的情况。
要研究一下

[eslbs]

http://blog.ednchina.com/exvision/2006/8/10.aspx
http://www.moon-soft.com/program/FORMAT/graphics/Ico.zip
ICO Ico.zip 115K Microsoft公司 图标文件（.ICO）文件格式详解（ZIP文档）

ICO File Format

Icons are normally stored in ICO files. The ICO file format is documented in the Windows 3.1 SDK Programmer's Reference, Volume 4: Resources, Chapter 1: Graphics File Formats.

The ICO file starts with an ICONDIR structure. The ICONDIR structure is defined as:

typedef struct
{
WORD idReserved; // Reserved
WORD idType; // resource type (1 for icons)
WORD idCount; // how many images?
ICONDIRENTRY idEntries[1]; // entries for each image (idCount of 'em)
} ICONDIR, *LPICONDIR;


The ICONDIRENTRY structure is defined as:

typedef struct
{
BYTE bWidth; // Width of the image
BYTE bHeight; // Height of the image (times 2)
BYTE bColorCount; // Number of colors in image (0 if >=8bpp)
BYTE bReserved; // Reserved
WORD wPlanes; // Color Planes
WORD wBitCount; // Bits per pixel
DWORD dwBytesInRes; // how many bytes in this resource?
DWORD dwImageOffset; // where in the file is this image
} ICONDIRENTRY, *LPICONDIRENTRY;


So, the file consists of the header followed by the bits for each image. The bits for each image can be located by seeking to dwImageOffset in the file. The format of the bits follows:

[eslbs]

http://www.moon-soft.com/program/FORMAT/graphics/Ico.zip
里面有一个vc的源码及一个ico文件的介绍

[laviewpbt]

Private Type ICONDIR
idReserved As Integer ' Reserved
idType As Integer ' resource type (1 for icons)
idCount As Integer ' how many images?

' idEntries() as ICONDIRENTRY array follows.
End Type


Private Type ICONDIRENTRY
bWidth As Byte ' Width of the image
bHeight As Byte ' Height of the image (times 2)
bColorCount As Byte ' Number of colors in image (0 if >=8bpp)
bReserved As Byte ' Reserved
wPlanes As Integer ' Color Planes,1
wBitCount As Integer ' Bits per pixel
dwBytesInRes As Long ' how many bytes in this resource?
dwImageOffset As Long ' where in the file is this image
End Type


22个字节是这个东西

[tongnaifu]

mark，学习

[Soyokaze]

22字节就是9楼说的那样。
补充一下，有的图标里面包含不只一个图标，这时这个字段就不只是22字节了。
ICONDIR 结构是固定的，后面的 ICONDIRENTRY 有几个图标就有几个。

[Soyokaze]

每个图标的数据结构就是一个位图，只是不带前面的14字节 BITMAPFILEHEADER 结构，在加上22字节的文件头。
注意，PE中关于图标有两种资源，一种是图标，一种是图标组。之前分析过，图标组用来存放前面所说的那22字节（6+16n）数据，图表存放后面的数据。
啊~~说的有些不太清楚，总之就是这个意思。

[eslbs]

其实意思就是

如果要获取exe里面的一个图标
就要构造6+16个字节的文件头 然后加资源文件对应的图标数据

如果要获取exe里面的一个图标组（里面有N个图标）
就要构造6+16N个字节的文件头 然后依次加资源文件对应的每个图标的数据

不知道有没有api函数已经做好这个操作了。

[Soyokaze]

啊，看来语言不组织是不行呀~~
下面是当时我用VB写的获取PE文件资源叶子节点信息的函数，贴出供大家参考。

'资源叶子信息
Private Type ResourceLeafInfo
    nTypeID As Long      '资源类型
    pStructRA As Long    '此资源的 IMAGE_RESOURCE_DATA_ENTRY 结构相对地址（从资源段算起）
    pDataAA As Long      '此资源的绝对地址（从文件首部算起）
    cbSize As Long       '资源大小
End Type

'递归遍历资源树，获得叶节点相关数据
Private Sub PickLeaves(hFile As Long, _
                       pResOffset As Long, _
                       pNodeEntry As Long, _
                       nTypeID As Long, _
                       tResLeafInfo() As ResourceLeafInfo)
    
    Dim tResDir As IMAGE_RESOURCE_DIRECTORY
    Dim tResDirEntry As IMAGE_RESOURCE_DIRECTORY_ENTRY
    Dim tResDataEntry As IMAGE_RESOURCE_DATA_ENTRY
    Dim i As Long
    
    Call llseek(hFile, pResOffset + pNodeEntry, FILE_BEGIN)
    Call lread(hFile, tResDir, Len(tResDir))
    For i = 0 To tResDir.NumberOfIdEntries + tResDir.NumberOfNamedEntries - 1
        Call llseek(hFile, pResOffset + pNodeEntry + Len(tResDir) + Len(tResDirEntry) * i, FILE_BEGIN)
        Call lread(hFile, tResDirEntry, Len(tResDirEntry))
        If CBool(tResDirEntry.OffsetToData And &H80000000) Then '指向下一个目录节点
            Call PickLeaves(hFile, pResOffset, tResDirEntry.OffsetToData And &H7FFFFFFF, nTypeID, tResLeafInfo())
        Else '指向数据入口
            Call llseek(hFile, pResOffset + tResDirEntry.OffsetToData, FILE_BEGIN)
            Call lread(hFile, tResDataEntry, Len(tResDataEntry))
            ReDim Preserve tResLeafInfo(UBound(tResLeafInfo) + 1) As ResourceLeafInfo
            With tResLeafInfo(UBound(tResLeafInfo))
                .nTypeID = nTypeID
                .pStructRA = tResDirEntry.OffsetToData
                .pDataAA = tResDataEntry.OffsetToData
                .cbSize = tResDataEntry.Size
            End With
        End If
    Next i
End Sub

[Soyokaze]

参数忘了具体都是什么了（呵呵，人比较懒，程序注释基本没有，时间一长就傻眼了），大概是当前节点的偏移吧。PE文件的偏移很乱，有些是相对于文件起始处的，有些是相对于数据块内的，晕啊~~

[Soyokaze]

调用此函数后，ResourceLeafInfo 数组中的 nTypeID 成员是 RT_ICON 的就是图标资源，RT_GROUP_ICON 的是图标组资源，结合 pDataAA 和 cbSize，就可以自己提取了。

资源 ID 列表：

Private Const RT_CURSOR = 1
Private Const RT_BITMAP = 2
Private Const RT_ICON = 3
Private Const RT_MENU = 4
Private Const RT_DIALOG = 5
Private Const RT_STRING = 6
Private Const RT_FONTDIR = 7
Private Const RT_FONT = 8
Private Const RT_ACCELERATORS = 9
Private Const RT_RCDATA = 10
Private Const RT_MESSAGETABLE = 11
Private Const RT_GROUP_CURSOR = 12
Private Const RT_GROUP_ICON = 14
Private Const RT_VERSION = 16

[迈克揉索芙特]

http://topic.csdn.net/u/20080707/21/fceb937b-6196-43a0-a46a-059c6f1d4a99.html

[平台想钱想疯了]

非常感谢楼上的各位，以下是我找到的一段代码。。可是我保存时，只有一个字节。。不知为什么。。数组中值有几百个字节。

哪位有时间的，能帮偶看一下不？


另外：4楼的兄弟，你给的那个地址我已经下载了，我发现，保存的时候，COLOR还是变成了，灰色的，没有，是我们看到的那种效果。

晕死。。。



Option Explicit
Private Declare Function FindResource Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As String, ByVal lpType As String) As Long
Private Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Function FindResourceByNum Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As String, ByVal lpType As Long) As Long
Private Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function SizeofResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function FreeResource Lib "kernel32" (ByVal hResData As Long) As Long
Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long

Dim hModule As Long

Private Sub Command1_Click()
Dim srcArr As Byte
InitResource "c:\test.exe"
srcArr = GetDataArray(3&, "#1")

If (srcArr = 0) Then
srcArr = GetDataArray(14&, "#1")
End If

SaveData "c:\a.ico", srcArr
End Sub

Public Function GetDataArray(ByVal ResType As String, ByVal ResName As String) As Byte
Dim hRsrc As Long
Dim hGlobal As Long
Dim arrData() As Byte
Dim lpData As Long
Dim arrSize As Long
If IsNumeric(ResType) Then hRsrc = FindResourceByNum(hModule, ResName, CLng(ResType))
If hRsrc = 0 Then hRsrc = FindResource(hModule, ResName, ResType)
If hRsrc = 0 Then Exit Function
hGlobal = LoadResource(hModule, hRsrc)
lpData = LockResource(hGlobal)
arrSize = SizeofResource(hModule, hRsrc)
If arrSize = 0 Then Exit Function
ReDim arrData(arrSize - 1)
Call CopyMemory(arrData(0), ByVal lpData, arrSize)
Call FreeResource(hGlobal)
GetDataArray = arrData
End Function
Public Function InitResource(ByVal sLibName As String) As Boolean
'On Error Resume Next
hModule = LoadLibraryEx(sLibName, 0, 1)
' hModule = LoadLibrary(sLibName)
InitResource = (hModule <> 0)
End Function
Public Sub SaveData(ByVal sFileName As String, arrData As Byte)
Dim nFile As Integer
Dim arr As Byte
arr = arrData
nFile = FreeFile
Open sFileName For Binary As #nFile
Put #nFile, , arr
Close #nFile
End Sub

[平台想钱想疯了]

非常感谢各位，同仁的回复，其中一兄弟提供的大量文档，非常感谢，我已经收藏。准备好好看看
现在，我从下面这位兄弟的代码中，COPY过来，调试时出点问题，现贴出来。。。给有时间的兄弟看一下，
看是什么问题。。。为什么没有报错，就是没有执行下去。。。在调用到CopyMemory 这个API时。。。晕死。


[Quote=引用 17 楼 Modest 的回复:]
http://topic.csdn.net/u/20080707/21/fceb937b-6196-43a0-a46a-059c6f1d4a99.html
[/Quote]



从你的代码中直接COPY过来后，编译报重名错误，然后修改几处，但是执行有问题 （没有报语法错误）



'::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
' VB6中使用32位图标(第二版)
' Programmed by 魏滔序
' WebSite: http://www.chenoe.com
' Blog: http://blog.csdn.net/Modest
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Option Explicit

Private Type ICONDIRENTRY
bWidth As Byte
bHeight As Byte
bColorCount As Byte
bReserved As Byte
wPlanes As Integer
wBitCount As Integer
dwBytesInRes As Long
dwImageOffset As Long
End Type

Private Type ICONDIR
idReserved As Integer
idType As Integer
idCount As Integer
idEntries() As ICONDIRENTRY
End Type

Private Declare Function CreateIconFromResourceEx Lib "user32" (presbits As Byte, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal uFlags As Long) As Long
Private Declare Function DrawIconEx Lib "user32.dll" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private m_Data() As Byte
Private m_iCount As Integer
Private m_iDir As ICONDIR

Public Property Get Count2() As Long '原代码为Count但编译报重名
Count2 = m_iCount
End Property

Public Property Get Height2(Optional ByVal Index As Long) As Long '原代码为Height但编译报重名
Height2 = m_iDir.idEntries(Index).bHeight
End Property

Public Property Get Width2(Optional ByVal Index As Long) As Long '原代码为Width但编译报重名
Width2 = m_iDir.idEntries(Index).bWidth
End Property

Public Property Get Length(Optional ByVal Index As Long) As Long
Length = m_iDir.idEntries(Index).dwBytesInRes
End Property

Public Property Get Data(Optional ByVal Index As Long) As Byte()
On Error GoTo E
Dim o As Long, l As Long, d() As Byte
o = m_iDir.idEntries(Index).dwImageOffset
l = m_iDir.idEntries(Index).dwBytesInRes
ReDim d(l - 1)
CopyMemory d(0), m_Data(o), l '第六步 这里出错没有反应
Data = d
MsgBox ("hello") '第七步 没有执行
E:
MsgBox Err.Description '第八步 没有提示出错
End Property

Public Function LoadFromData(Data() As Byte) As Boolean
Dim i As Long
m_Data = Data
CopyMemory m_iCount, m_Data(4), 2 '取得图标个数
If m_iCount > 0 Then
ReDim m_iDir.idEntries(0 To m_iCount - 1) '图标目录结构数据
For i = 0 To m_iCount - 1
CopyMemory m_iDir.idEntries(i), m_Data(6 + Len(m_iDir.idEntries(i)) * i), Len(m_iDir.idEntries(i))
Next
LoadFromData = True
End If
End Function

Public Function LoadFromFile(ByVal FileName As String) As Boolean
Dim hFile As Integer
Dim Data() As Byte

If Dir(FileName) = "" Then Exit Function

hFile = FreeFile
Open FileName For Binary As #hFile
ReDim Data(LOF(hFile) - 1)
Get #hFile, , Data
Close #hFile

LoadFromFile = LoadFromData(Data)
End Function

Public Property Get hIcon(Optional ByVal Index As Long) As Long

Dim d() As Byte, l As Long, w As Long, h As Long
MsgBox 2 '第四步 OK
d = Data(Index): l = m_iDir.idEntries(Index).dwBytesInRes '原代码Length(Index)
MsgBox 3 '第五步错误 没有弹出已经出错 在Data(Index)中 进入
w = m_iDir.idEntries(Index).bWidth: h = m_iDir.idEntries(Index).bHeight '原代码为w=Width(Index):h=Height(Index)
hIcon = CreateIconFromResourceEx(d(0), l, 1, &H30000, w, h, 0)

End Property

Public Function Draw(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, Optional ByVal Index As Long = 0) As Boolean
Dim w As Long, h As Long
w = m_iDir.idEntries(Index).bWidth: h = m_iDir.idEntries(Index).bHeight '原代码为w=Width(Index):h=Height(Index)

Draw = DrawIconEx(hdc, x, y, hIcon(Index), w, h, 0, 0, 3) <> 0
DestroyIcon hIcon
End Function

Public Sub SetFormIcon(ByVal Form As Form, Optional ByVal Index As Long = 0)
SendMessageLong Form.hWnd, &H80, 0, hIcon(Index)
End Sub

Private Sub Class_Terminate()
Erase m_Data
End Sub

Private Sub Command1_Click()

LoadFromFile "C:\flash.exe" '第一步

'Draw Picture1.hdc, 5, 5, 0

'SetFormIcon Form1, 0
MsgBox Count2 '= 3 正确 '第二步

MsgBox hIcon(0) '没有反应 也不报错. '第三步 进入



End Sub

[平台想钱想疯了]

各位，有一个问题，FindResource , FindResourceByNum 为什么找不到图标资源文件，而这个EXE又是有图标的

我通过ExtractAssociatedIcon 方法能获取到一个图标，可用上面的函数，只能取得很少EXE的图标，绝大多数都
提示找不到资源。。。。
'获取图标
'Dim mIcon As Long
'hRsrc = ExtractAssociatedIcon(App.hInstance, m_sFile, 0) ‘OK能正常取得图标




hLibrary = LoadLibraryEx(sFile, ByVal 0&, LOAD_LIBRARY_AS_DATAFILE)
If (hLibrary = 0) Then
' Failed to load the executable. Probably not a Win32 EXE.
Err.Raise vbObjectError + 1048 + 6, App.EXEName & ".cFileIcon", "Can't load library."
LoadIconFromEXE = False
Else
' Find the resource:
If (lpID <> 0) Then
lpName = "#" & CStr(lpID)
hRsrc = FindResource(hLibrary, ByVal lpName, ByVal RT_GROUP_ICON)
If (hRsrc = 0) Then hRsrc = FindResourceByNum(hLibrary, ByVal lpName, ByVal RT_GROUP_ICON)
m_vID = lpID
Else
hRsrc = FindResource(hLibrary, ByVal lpName, ByVal RT_GROUP_ICON)
If (hRsrc = 0) Then hRsrc = FindResourceByNum(hLibrary, ByVal lpName, ByVal RT_GROUP_ICON)
m_vID = lpName
End If

'获取图标
'Dim mIcon As Long
'hRsrc = ExtractAssociatedIcon(App.hInstance, m_sFile, 0)


这段代码的全部源文件是 cFileIcon_Class_and_Demonstration_Project.zip
是从上面一朋友给的地址中，下载到的。。
非常感谢。。

[平台想钱想疯了]

[Quote=引用 20 楼 alan001 的回复:]
用图标资源也不行?UP
[/Quote]

是的，如果用ExtractAssociatedIcon，后面的保存操作，就无法保存为，32X32位的。。。会色彩丢失。。。
但是仅仅是画在FORM1中，是彩色的。。

上面，几位兄弟讲的都很让我受启发。。。。只是问题还没有解决掉。。。晕死。。。

[alan001]

用图标资源也不行?UP

[VirtualDesktop]

http://www.vbaccelerator.com/home/VB/Utilities/Icon_Extractor/article.asp

这个可以没？

[laviewpbt]

我只会将任何格式的图像转换为32位色的ico。

[proer9988]

good