一般的方法（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"
'获取图标
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"
想要提取某一个图标，方法是有的，就是不使用API函数，自己来。图标组是PE的资源中的一种，PE的资源数据结构是一棵树，楼主可以看一下介绍PE结构的资料，然后自己来，不算太难的。
http://blog.csdn.net/Modest/archive/2008/05/22/2468937.aspx
Public Function GetDataArray(ByVal ResType As String, ByVal ResName As String) As Variant
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 Sub SaveData(ByVal sFileName As String, arrData As Variant)
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 SaveData cdlg.FileName, srcArr
另外：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 LongDim hModule As LongPrivate 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 SubPublic 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
http://www.moon-soft.com/program/FORMAT/graphics/Ico.zip
ICO Ico.zip 115K Microsoft公司 图标文件（.ICO）文件格式详解（ZIP文档） ICO File FormatIcons 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:
里面有一个vc的源码及一个ico文件的介绍
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个字节是这个东西
补充一下，有的图标里面包含不只一个图标，这时这个字段就不只是22字节了。
ICONDIR 结构是固定的，后面的 ICONDIRENTRY 有几个图标就有几个。
注意，PE中关于图标有两种资源，一种是图标，一种是图标组。之前分析过，图标组用来存放前面所说的那22字节（6+16n）数据，图表存放后面的数据。
啊~~说的有些不太清楚，总之就是这个意思。
就要构造6+16个字节的文件头 然后加资源文件对应的图标数据如果要获取exe里面的一个图标组（里面有N个图标）
就要构造6+16N个字节的文件头 然后依次加资源文件对应的每个图标的数据不知道有没有api函数已经做好这个操作了。
下面是当时我用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
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
现在，我从下面这位兄弟的代码中，COPY过来，调试时出点问题，现贴出来给有时间的兄弟看一下，
看是什么问题为什么没有报错，就是没有执行下去在调用到CopyMemory 这个API时晕死。从你的代码中直接COPY过来后，编译报重名错误，然后修改几处，但是执行有问题 （没有报语法错误） '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
' VB6中使用32位图标(第二版)
' Programmed by 魏滔序
' WebSite: http://www.chenoe.com
' Blog: http://blog.csdn.net/Modest
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Option ExplicitPrivate 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 TypePrivate Type ICONDIR
idReserved As Integer
idType As Integer
idCount As Integer
idEntries() As ICONDIRENTRY
End TypePrivate 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 LongPrivate m_Data() As Byte
Private m_iCount As Integer
Private m_iDir As ICONDIRPublic Property Get Count2() As Long '原代码为Count但编译报重名
Count2 = m_iCount
End PropertyPublic Property Get Height2(Optional ByVal Index As Long) As Long '原代码为Height但编译报重名
Height2 = m_iDir.idEntries(Index).bHeight
End PropertyPublic Property Get Width2(Optional ByVal Index As Long) As Long '原代码为Width但编译报重名
Width2 = m_iDir.idEntries(Index).bWidth
End PropertyPublic Property Get Length(Optional ByVal Index As Long) As Long
Length = m_iDir.idEntries(Index).dwBytesInRes
End PropertyPublic 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 PropertyPublic 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 FunctionPublic 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 FunctionPublic 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 PropertyPublic 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 FunctionPublic Sub SetFormIcon(ByVal Form As Form, Optional ByVal Index As Long = 0)
SendMessageLong Form.hWnd, &H80, 0, hIcon(Index)
End SubPrivate Sub Class_Terminate()
Erase m_Data
End SubPrivate 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
是从上面一朋友给的地址中，下载到的。。
非常感谢。。
是的，如果用ExtractAssociatedIcon，后面的保存操作，就无法保存为，32X32位的会色彩丢失
但是仅仅是画在FORM1中，是彩色的。。上面，几位兄弟讲的都很让我受启发。只是问题还没有解决掉晕死