在网上找了一个类cFileIcon.cls来验证资源管理器中,用鼠标获取到的图标属性是图标文件中按顺序排列的最后一个图标。我改进了一下，并作了简化，原来那个类不能打开24、32位真彩色图标，现在可以了。
演示工程源码下载地址：http://download.csdn.net/source/3119185
类模块：IconClass.clsOption Explicit ' ===================================================================================== ' 文件名: IconClass.cls ' 作 者: chenjl1031(东方之珠) ' 日 期: 2011-03-18 '====================================================================================== '====================================================================================== '结构名: ICONDIRENTRY '结构大小: 16字节 '结构说明: 图标入口信息 '====================================================================================== Private Type ICONDIRENTRY bWidth As Byte '&H0 图标宽度(以像素为单位) bHeight As Byte '&H1 图标高度(以像素为单位)，XOR位图+AND位图高度 bColorCount As Byte '&H2 图标的颜色数(02为单色，00表示>=8bpp) bReserved As Byte '&H3 保留字(该值总为0) wPlanes As Integer '&H4 图标的平面数(即帧数,该值总为1) wBitCount As Integer '&H6 图标的位数 dwBytesInRes As Long '&H8 图标所占字节数 dwImageOffset As Long '&HC 图标在文件中的位置(即偏移量) End Type '====================================================================================== '结构名: ICONDIR '结构大小: 22字节 '结构说明: 图标文件头 '====================================================================================== Private Type ICONDIR '22字节 idReserved As Integer '&H0 保留字(该值总为0) idType As Integer '&H2 资源类型(1表示图标,2表示光标) idCount As Integer '&H4 文件中含有图标的个数 'idEntries() As ICONDIRENTRY '&H6 图标入口信息 End Type '====================================================================================== '结构名: BITMAPINFOHEADER '结构大小: 40字节 '结构说明: BMP位图信息头部 '====================================================================================== Private Type BITMAPINFOHEADER '40个字节 biSize As Long '&H0 BITMAPINFOHEADER结构的大小 biWidth As Long '&H4 图像宽度(以像素为单位) biHeight As Long '&H8 图像高度(XOR图高度＋AND图高度,以像素为单位) biPlanes As Integer '&HC 目标设备的位平面数(该值总为1) biBitCount As Integer '&HE 每个像素所占位数 biCompression As Long '&H10 图像数据的压缩类型(0表示未压缩) biSizeImage As Long '&H14 图像所占字节数(不包括BITMAPINFOHEADER结构) biXPelsPerMeter As Long '&H18 水平方向上的每米的像素个数 biYPelsPerMeter As Long '&H1C 垂直方向上的每米的像素个数 biClrUsed As Long '&H20 调色板中实际使用的颜色数 biClrImportant As Long '&H24 现实位图时必须的颜色数 End Type '====================================================================================== '结构名: RGBQUAD '结构大小: 4字节 '结构说明: XOR(异或)位图调色板 '====================================================================================== Private Type RGBQUAD '4字节 rgbBlue As Byte '&H0 蓝色分量(值范围为0-255) rgbGreen As Byte '&H1 绿色分量(值范围为0-255) rgbRed As Byte '&H2 红色分量(值范围为0-255) rgbReserved As Byte '&H3 保留字(该值总为0) End Type '存放图标的DIB位 Private Type tBits bBits() As Byte End Type ' 资源类型: Private Const IMAGE_BITMAP = 0 Private Const IMAGE_ICON = 1 Private Const IMAGE_CURSOR = 2 ' 通过Win32 API读写文件 Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Const GENERIC_READ = &H80000000 Private Const GENERIC_WRITE = &H40000000 Private Const OPEN_EXISTING = 3 Private Const CREATE_ALWAYS = 2 Private Const FILE_ATTRIBUTE_NORMAL = &H80 Private Const INVALID_HANDLE_VALUE = -1 Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long Private Const FILE_BEGIN = 0 '获取DPI设置 Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Const LOGPIXELSX As Long = 88 '像素/逻辑英寸（水平） Private Const LOGPIXELSY As Long = 90 '像素/逻辑英寸（垂直） 'Resource functions: Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long ' Missing from VB API declarations: Private Const LOAD_LIBRARY_AS_DATAFILE = &H2& Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Private Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long Private Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long ' The FindResource and FindResourceEx functions are a bit annoying in VB because the lpName and lpType ' parameters can take both strings and longs. Declare lpName and lpType as Any and remember to use ByVal ' when placing a parameter into them Private Declare Function FindResource Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, lpName As Any, lpType As Any) As Long Private Declare Function SizeofResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long Private Declare Function FreeResource Lib "kernel32" (ByVal hResData As Long) As Long Private Const RT_CURSOR = 1 Private Const RT_BITMAP = 2 Private Const RT_ICON = 3 ' Missing from VB API declarations: Private Const DIFFERENCE = 11 Private Const RT_GROUP_CURSOR = RT_CURSOR + DIFFERENCE Private Const RT_GROUP_ICON = RT_ICON + DIFFERENCE ' The size of the BITMAPINFO structure depends on whether there is a colour ' table in the DIB or not and its size. For mono (1bpp) DIBs, the colour ' table has two entries, for 16 colour (4bpp) DIBs, there are 16 entries, ' for 256 colour (8bpp) DIBs there are 256 entries, otherwise the DIB is ' 24 bits per pixel and has no colour table. Private Type BITMAPINFO_1BPP bmiHeader As BITMAPINFOHEADER bmiColors(0 To 1) As RGBQUAD End Type Private Type BITMAPINFO_4BPP bmiHeader As BITMAPINFOHEADER bmiColors(0 To 15) As RGBQUAD End Type Private Type BITMAPINFO_8BPP bmiHeader As BITMAPINFOHEADER bmiColors(0 To 255) As RGBQUAD End Type ' Colour table information: Private Const DIB_PAL_COLORS = 1 ' color table in palette indices Private Const DIB_PAL_INDICES = 2 ' No color table indices into surf palette Private Const DIB_PAL_LOGINDICES = 4 ' No color table indices into DC palette Private Const DIB_PAL_PHYSINDICES = 2 ' No color table indices into surf palette Private Const DIB_RGB_COLORS = 0 ' color table in RGBs ' Bitmap compression types: Private Const BI_RGB = 0& Private Const BI_RLE4 = 2& Private Const BI_RLE8 = 1& ' Getting and setting DIB Bits: Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As Any, ByVal wUsage As Long) As Long Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As Any, ByVal wUsage As Long) As Long Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As Any, ByVal wUsage As Long) As Long ' Device dependent Bitmap structure: Private Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type ' General GDI calls for bitmaps and DC: Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateBitmapIndirect Lib "gdi32" (lpBitmap As BITMAP) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private 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 StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long ' Creating an icon from the mask and colour bitmaps and vice-versa: Private Type ICONINFO fIcon As Long xHotspot As Long yHotspot As Long hBmMask As Long hbmColor As Long End Type Private Declare Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As Long Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long ' Declares to allow a hIcon handle to be converted to a VB StdPicture object: Private 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 OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long ' Very much required here: Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) ' ----------- ' =========================================================================== ' Implementation ' =========================================================================== Public Enum ECFIImageConstants ecfiImage ecfiMask End Enum Private m_sFile As String Private m_vID As Variant Private m_tID As ICONDIR Private m_tIDE() As ICONDIRENTRY Private m_tBits() As tBits '返回水平分辩率DPI和垂直分辩率DPI Public Function Logpixelsxy(ByRef Hdpi As Long, ByRef Vdpi As Long) As Boolean Dim hWndDesktop As Long, hDCDesktop As Long hWndDesktop = GetDesktopWindow hDCDesktop = GetDC(hWndDesktop) Hdpi = GetDeviceCaps(hDCDesktop, LOGPIXELSX) Vdpi = GetDeviceCaps(hDCDesktop, LOGPIXELSY) Call ReleaseDC(hWndDesktop, hDCDesktop) If Hdpi <> 0 Or Vdpi <> 0 Then Logpixelsxy = True Else Logpixelsxy = False End If End Function '显示图标到图片框 Private Function IconToPicture(ByVal hIcon As Long) As IPicture If hIcon = 0 Then Exit Function Dim NewPic As Picture, PicConv As PictDesc, IGuid As Guid PicConv.cbSizeofStruct = Len(PicConv) PicConv.picType = vbPicTypeIcon PicConv.hImage = hIcon ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB} 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 PicConv, IGuid, True, NewPic Set IconToPicture = NewPic End Function '取得图标图片 Public Property Get IconPicture(ByVal lHDC As Long, ByVal nIndex As Long) As StdPicture Dim hIcon As Long hIcon = IconHandle(lHDC, nIndex) If (hIcon <> 0) Then Set IconPicture = IconToPicture(hIcon) End If End Property '取得图标句柄 Public Property Get IconHandle(ByVal lHDC As Long, ByVal nIndex As Long) As Long Dim hBmpAND As Long Dim hBmpXOR As Long Dim tII As ICONINFO tII.fIcon = IMAGE_ICON tII.hbmColor = GetIconBitmap(lHDC, nIndex, ecfiImage, False, bReturnBmp:=True) tII.hBmMask = GetIconBitmap(lHDC, nIndex, ecfiMask, False, bReturnBmp:=True) IconHandle = CreateIconIndirect(tII) DeleteObject tII.hbmColor DeleteObject tII.hBmMask End Property Public Property Get ImageCount() As Long ' Number of icons in the currently loaded file or resource. ImageCount = m_tID.idCount End Property Public Property Get ImageWidth(ByVal nIndex As Long) As Long ' Width of Icon at nIndex ImageWidth = m_tIDE(nIndex - 1).bWidth End Property Public Property Get ImageHeight(ByVal nIndex As Long) As Long ' Height of Icon at nIndex ImageHeight = m_tIDE(nIndex - 1).bHeight End Property Public Property Get ImageColourCount(ByVal nIndex As Long) As Currency ' Number of colours in Icon at nIndex If (m_tIDE(nIndex - 1).bColorCount = 0) Then ImageColourCount = 2 ^ m_tIDE(nIndex - 1).wBitCount Else ImageColourCount = m_tIDE(nIndex - 1).bColorCount End If End Property Public Property Get ImageSize(ByVal nIndex As Long) As Long ImageSize = m_tIDE(nIndex - 1).dwBytesInRes End Property '删除图标 Public Function RemoveImage(ByVal nIndex As Long) As Long Dim i As Long Dim tIDE As ICONDIRENTRY Dim lShift As Long Dim bFound As Boolean ' Removes icon at nIndex: If (m_tID.idCount > 1) Then ' Remove the image, then shift up the remaining items ' in the array and fix up the image offsets: For i = 0 To m_tID.idCount - 1 If (nIndex = i + 1) Then bFound = True lShift = m_tIDE(i).dwBytesInRes ElseIf (i + 1 >= nIndex) Then LSet tIDE = m_tIDE(i) LSet m_tIDE(i - 1) = tIDE ReDim Preserve m_tBits(i - 1).bBits(0 To tIDE.dwBytesInRes - 1) As Byte CopyMemory m_tBits(i - 1).bBits(0), m_tBits(i).bBits(0), tIDE.dwBytesInRes m_tIDE(i - 1).dwImageOffset = m_tIDE(i).dwImageOffset - lShift End If Next i m_tID.idCount = m_tID.idCount - 1 ReDim Preserve m_tIDE(0 To m_tID.idCount - 1) As ICONDIRENTRY ReDim Preserve m_tBits(0 To m_tID.idCount - 1) As tBits For i = 0 To m_tID.idCount - 1 m_tIDE(i).dwImageOffset = m_tIDE(i).dwImageOffset + bFound * Len(tIDE) Next i Else ' no icons left: Erase m_tIDE Erase m_tBits m_tID.idCount = 0 End If End Function '新增图标 Public Function AddImage(ByVal nWidth As Long, ByVal nHeight As Long, ByVal nColourCount As Long) As Long Dim i As Long Dim iItem As Long Dim lMaxImageOffset As Long Dim lNewImageOffset As Long Dim tBMI As BITMAPINFOHEADER Dim tRGBQ As RGBQUAD Dim lPosition As Long ' Adds a new icon to the image: If (m_tID.idCount > 1) Then ' Check we don't already have it: For i = 0 To m_tID.idCount - 1 With m_tIDE(i) If (.bHeight = nHeight) And (.bWidth = nWidth) And ImageColourCount(i + 1) = nColourCount Then ' we already have it Err.Raise vbObjectError + 1048 + 1, App.EXEName & ".cFileIcon", "Icon already exists." Exit Function Else ' check for the last image in the icon directory: If .dwImageOffset > lMaxImageOffset Then lMaxImageOffset = .dwImageOffset lNewImageOffset = lMaxImageOffset + .dwBytesInRes End If End If End With Next i ' Increment all the image offsets to account for the new icon ' directory entry: For i = 0 To m_tID.idCount - 1 m_tIDE(i).dwImageOffset = m_tIDE(i).dwImageOffset + Len(m_tIDE(i)) Next i lNewImageOffset = lNewImageOffset + Len(m_tIDE(0)) End If ' If we don't, then add it: m_tID.idCount = m_tID.idCount + 1 iItem = m_tID.idCount - 1 ' Add the ICONDIRENTRY header: ReDim Preserve m_tIDE(0 To iItem) As ICONDIRENTRY With m_tIDE(iItem) If (nColourCount = 2) Then .wBitCount = 1 .bColorCount = nColourCount ElseIf (nColourCount = 16) Then .wBitCount = 4 .bColorCount = nColourCount ElseIf (nColourCount = 256) Then .wBitCount = 8 .bColorCount = 0 Else .wBitCount = 24 .bColorCount = 0 End If .wPlanes = 1 .bWidth = nWidth .bHeight = nHeight If (iItem = 0) Then .dwImageOffset = Len(m_tID) + Len(m_tIDE(iItem)) Else .dwImageOffset = lNewImageOffset End If ' Add Bitmap Info Header size + Palette Size: If (.bColorCount <= 256) Then .dwBytesInRes = Len(tBMI) + nColourCount * Len(tRGBQ) Else ' > 256 colours, true colour icon. .dwBytesInRes = Len(tBMI) End If ' Add XOR (colour) image size: .dwBytesInRes = .dwBytesInRes + nHeight * WidthBytes(nWidth * .wBitCount * .wPlanes) ' Add AND (mask) image size: .dwBytesInRes = .dwBytesInRes + nHeight * WidthBytes(nWidth) End With ' Add the Bitmap bits: ReDim Preserve m_tBits(0 To iItem) As tBits ReDim Preserve m_tBits(iItem).bBits(0 To m_tIDE(iItem).dwBytesInRes - 1) As Byte ' Generate the Bitmap Info Header: tBMI.biSize = Len(tBMI) tBMI.biWidth = nWidth ' Note that icons have a height of x2 tBMI.biHeight = nHeight * 2 tBMI.biPlanes = 1 tBMI.biBitCount = m_tIDE(iItem).wBitCount tBMI.biCompression = BI_RGB tBMI.biClrUsed = 0 ' Put it into the bits. CopyMemory m_tBits(iItem).bBits(0), tBMI, Len(tBMI) ' Now you have an all black mask (no transparent pixels) ' and an all black image. ' Lets generate a palette as required: If (tBMI.biBitCount = 1) Then ' 1 bit, 2 colours, set the second colour to white tRGBQ.rgbBlue = 255 tRGBQ.rgbRed = 255 tRGBQ.rgbGreen = 255 lPosition = Len(tBMI) + Len(tRGBQ) CopyMemory m_tBits(iItem).bBits(lPosition), tRGBQ, Len(tRGBQ) ElseIf (tBMI.biBitCount = 4) Then ' 4 bits, 16 colours, set the colours to (?) ElseIf (tBMI.biBitCount = 8) Then ' 8 bits, 256 colours, set the colours to (?) End If End Function '装入图标文件 Public Function LoadIcon(ByVal sFile As String) As Boolean Dim hFile As Long Dim iValue As Long Dim iType As Long Dim iEntry As Long Dim i As Long Dim dwBytesRead As Long Dim bFail As Boolean Dim sFail As String Dim tBMI As BITMAPINFOHEADER m_sFile = sFile m_vID = Empty Erase m_tIDE Erase m_tBits With m_tID .idCount = 0 .idReserved = 0 .idType = 0 End With hFile = CreateFile(sFile, GENERIC_READ, 0, ByVal 0&, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0) If (hFile <> 0) Then ReadFile hFile, m_tID, Len(m_tID), dwBytesRead, ByVal 0& If (m_tID.idReserved = 0) Then If (m_tID.idType = IMAGE_ICON) Then '为图标 Debug.Print "Icon contains " & m_tID.idCount & " images." If (m_tID.idCount > 0) Then ReDim m_tIDE(0 To m_tID.idCount - 1) As ICONDIRENTRY For iEntry = 1 To m_tID.idCount ReadFile hFile, m_tIDE(iEntry - 1), Len(m_tIDE(iEntry - 1)), dwBytesRead, ByVal 0& If (dwBytesRead <> Len(m_tIDE(iEntry - 1))) Then sFail = "Icon Directory Array is Corrupt." bFail = True Exit For End If Next If Not (bFail) Then ReDim m_tBits(0 To m_tID.idCount - 1) As tBits For iEntry = 1 To m_tID.idCount ' Move to the image position: SetFilePointer hFile, m_tIDE(iEntry - 1).dwImageOffset, ByVal 0&, FILE_BEGIN ' Prepare the correct number of bits for the image: ReDim m_tBits(iEntry - 1).bBits(0 To m_tIDE(iEntry - 1).dwBytesInRes) As Byte ' Get them from the file: ReadFile hFile, m_tBits(iEntry - 1).bBits(0), m_tIDE(iEntry - 1).dwBytesInRes, dwBytesRead, ByVal 0& ' Check if we got the right number: If (dwBytesRead <> m_tIDE(iEntry - 1).dwBytesInRes) Then sFail = "Icon Images Array is Corrupt." bFail = True Exit For End If Next iEntry LoadIcon = Not (bFail) End If Else sFail = "Icon contains no images." End If Else sFail = "File is not icon type (idType <> IMAGE_ICON)" End If Else sFail = "File is not icon type (reserved member is 0)" End If ' Close file handle: CloseHandle hFile ' Did we succeed? If (bFail) Then Err.Raise vbObjectError + 1048 + 2, App.EXEName & ".cFileIcon", "Failed to load icon: " & sFail ' ensure clear: sFile = "" Erase m_tIDE Erase m_tBits m_tID.idCount = 0 End If End If End Function '保存图标数据到文件中 Public Function SaveIcon( _ Optional ByVal sFileName As String = "" _ ) As Boolean Dim hFile As Long Dim dwBytesWritten As Long Dim iEntry As Long Dim bFail As Boolean ' General error checking: If (m_sFile = "") Then If (sFileName = "") Then Err.Raise vbObjectError + 1048 + 3, App.EXEName & ".cFileIcon", "No filename specified." Exit Function End If End If If (m_tID.idCount = 0) Then Err.Raise vbObjectError + 1048 + 4, App.EXEName & ".cFileIcon", "Icon contains no images." Exit Function End If ' Now start writing: If (sFileName <> "") Then m_sFile = sFileName End If ' Open the file for write: hFile = CreateFile(m_sFile, GENERIC_WRITE, 0, ByVal 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, ByVal 0&) If (hFile = INVALID_HANDLE_VALUE) Then Err.Raise vbObjectError + 1048 + 4, App.EXEName & ".cFileIcon", "Couldn't open file for writing." Else ' Write the header: WriteFile hFile, m_tID, Len(m_tID), dwBytesWritten, ByVal 0& If (dwBytesWritten = Len(m_tID)) Then ' Write the ICONDIRENTRY structures: For iEntry = 0 To m_tID.idCount - 1 WriteFile hFile, m_tIDE(iEntry), Len(m_tIDE(iEntry)), dwBytesWritten, ByVal 0& If (dwBytesWritten <> Len(m_tIDE(iEntry))) Then bFail = True Exit For End If Next iEntry ' Write the icon bits: If Not (bFail) Then For iEntry = 0 To m_tID.idCount - 1 WriteFile hFile, m_tBits(iEntry).bBits(0), m_tIDE(iEntry).dwBytesInRes, dwBytesWritten, ByVal 0& If (m_tIDE(iEntry).dwBytesInRes <> dwBytesWritten) Then bFail = True Exit For End If Next iEntry End If Else bFail = True End If ' Close the file: CloseHandle hFile ' Did we succeed? If (bFail) Then Err.Raise vbObjectError + 1048 + 5, App.EXEName & ".cFileIcon", "General failure writing icon." End If SaveIcon = Not (bFail) End If End Function '绘制图标图像 Public Sub DrawIconImage( _ ByVal lHDC As Long, _ ByVal nIndex As Long, _ Optional ByVal eType As ECFIImageConstants = ecfiImage, _ Optional ByVal X As Long = 0, Optional ByVal Y As Long = 0, _ Optional ByVal lWidth As Long = 0, Optional ByVal lHeight As Long = 0, _ Optional ByVal eRasterOp As RasterOpConstants = vbSrcCopy _ ) ' Draws either the Image (XOR) or Mask (AND) parts of the icon to an HDC: GetIconBitmap lHDC, nIndex, eType, True, X, Y, lWidth, lHeight, eRasterOp End Sub '取得图标位图 Private Function GetIconBitmap( _ ByVal lHDC As Long, _ ByVal nIndex As Long, _ ByVal eType As ECFIImageConstants, _ Optional ByVal bDrawToDC As Boolean = True, _ Optional ByVal X As Long, Optional ByVal Y As Long, _ Optional ByVal lWidth As Long, Optional ByVal lHeight As Long, _ Optional ByVal eOp As RasterOpConstants, _ Optional ByVal bReturnBmp As Boolean = False _ ) As Long Dim hdc As Long Dim lR As Long Dim lAnd As Long, lXor As Long Dim tBMIH As BITMAPINFOHEADER Dim tBMIMono As BITMAPINFO_1BPP Dim hBmp As Long Dim hBmpOld As Long ' Returns or draws a device dependent bitmap containing the Image (XOR) ' or Mask (AND) image from an icon If (eType = ecfiImage) Then ' Extract the XOR (colour) part of the icon image: ' First create a compatible DC: hdc = CreateCompatibleDC(lHDC) ' we can replace this with desktop DC If (hdc <> 0) Then ' Create a Bitmap compatible with the device: hBmp = CreateCompatibleBitmap(lHDC, m_tIDE(nIndex - 1).bWidth, m_tIDE(nIndex - 1).bHeight) If (hBmp <> 0) Then ' Select the object into the DC: hBmpOld = SelectObject(hdc, hBmp) If (hBmpOld <> 0) Then ' Icons have 2 x correct height, so temporarily correct the ' BitmapInfoHeader structure whilst we create the bitmap: CopyMemory tBMIH, m_tBits(nIndex - 1).bBits(0), Len(tBMIH) tBMIH.biHeight = tBMIH.biHeight / 2 CopyMemory m_tBits(nIndex - 1).bBits(0), tBMIH, Len(tBMIH) ' find the XOR (image) bits within the icon: lXor = FindDIBits(tBMIH) ' Set the Compatible Bitmap to the colour bits in the DIB within the icon: lR = SetDIBitsToDevice(hdc, 0, 0, m_tIDE(nIndex - 1).bWidth, m_tIDE(nIndex - 1).bHeight, 0, 0, 0, m_tIDE(nIndex - 1).bHeight, m_tBits(nIndex - 1).bBits(lXor), m_tBits(nIndex - 1).bBits(0), DIB_RGB_COLORS) ' Draw it if required: If (bDrawToDC) Then If (lWidth = 0) And (lHeight = 0) Then BitBlt lHDC, X, Y, m_tIDE(nIndex - 1).bWidth, m_tIDE(nIndex - 1).bHeight, hdc, 0, 0, eOp Else ' NB only allowing a larger version to be drawn here. If (lWidth = 0) Then lWidth = m_tIDE(nIndex - 1).bWidth End If If (lHeight = 0) Then lHeight = m_tIDE(nIndex - 1).bHeight End If StretchBlt lHDC, X, Y, lWidth, lHeight, hdc, 0, 0, m_tIDE(nIndex - 1).bWidth, m_tIDE(nIndex - 1).bHeight, eOp End If End If ' Put the x2 icon height back again: CopyMemory tBMIH, m_tBits(nIndex - 1).bBits(0), Len(tBMIH) tBMIH.biHeight = tBMIH.biHeight * 2 CopyMemory m_tBits(nIndex - 1).bBits(0), tBMIH, Len(tBMIH) ' Remove the bitmap from the DC SelectObject hdc, hBmpOld End If ' Delete created bitmap if required: If (bReturnBmp) Then GetIconBitmap = hBmp Else DeleteObject hBmp End If End If ' Clear up memory DC: DeleteDC hdc End If Else ' Extract the AND (mask) part of the icon image: ' Create a monochrome DC: hdc = CreateCompatibleDC(0&) If (hdc <> 0) Then ' Create a monochrome bitmap: hBmp = CreateCompatibleBitmap(hdc, m_tIDE(nIndex - 1).bWidth, m_tIDE(nIndex - 1).bHeight) If (hBmp <> 0) Then ' Select the mono-bitmap into the DC: hBmpOld = SelectObject(hdc, hBmp) If (hBmpOld <> 0) Then ' We need to create a BitmapInfo structure is a monochrome ' version of the one provided in the Icon. ' First, get a copy of the BitmapInfoHeader structure: CopyMemory tBMIMono.bmiHeader, m_tBits(nIndex - 1).bBits(0), Len(tBMIH) ' Find the Mask bits within the icon. These directly follow the XOR bits ' so we find the XOR bits and then add the size of the AND DIB: lXor = FindDIBits(tBMIMono.bmiHeader) lAnd = lXor + m_tIDE(nIndex - 1).bHeight * 1# * WidthBytes(tBMIMono.bmiHeader.biWidth * tBMIMono.bmiHeader.biPlanes * tBMIMono.bmiHeader.biBitCount) ' Fix up the BitmapInfo structure to represent a monochrome ' DIB: With tBMIMono With .bmiHeader ' In icons the height = 2x the actual height: .biHeight = .biHeight / 2 .biPlanes = 1 .biBitCount = 1 .biCompression = BI_RGB .biSizeImage = 0 .biXPelsPerMeter = 0 .biYPelsPerMeter = 0 .biClrUsed = 0 .biClrImportant = 0 End With ' Set up monochrome colour palette: With .bmiColors(0) .rgbRed = 0 .rgbGreen = 0 .rgbBlue = 0 .rgbReserved = 0 End With With .bmiColors(1) .rgbRed = 255 .rgbGreen = 255 .rgbBlue = 255 .rgbReserved = 0 End With End With ' Set the Compatible Bitmap to the mask bits in the DIB within the icon: lR = SetDIBitsToDevice(hdc, 0, 0, m_tIDE(nIndex - 1).bWidth, m_tIDE(nIndex - 1).bHeight, 0, 0, 0, m_tIDE(nIndex - 1).bHeight, m_tBits(nIndex - 1).bBits(lAnd), tBMIMono, DIB_RGB_COLORS) ' Draw it if required: If (bDrawToDC) Then If (lWidth = 0) And (lHeight = 0) Then BitBlt lHDC, X, Y, m_tIDE(nIndex - 1).bWidth, m_tIDE(nIndex - 1).bHeight, hdc, 0, 0, eOp Else ' NB only allowing a larger version to be drawn here. If (lWidth = 0) Then lWidth = m_tIDE(nIndex - 1).bWidth End If If (lHeight = 0) Then lHeight = m_tIDE(nIndex - 1).bHeight End If StretchBlt lHDC, X, Y, lWidth, lHeight, hdc, 0, 0, m_tIDE(nIndex - 1).bWidth, m_tIDE(nIndex - 1).bHeight, eOp End If End If ' Remove bitmap from DC: SelectObject hdc, hBmpOld End If ' Clear up bitmap if required: If (bReturnBmp) Then GetIconBitmap = hBmp Else DeleteObject hBmp End If End If ' Clear up memory DC. DeleteObject hdc End If End If End Function Private Function FindDIBits(ByRef tBMI As BITMAPINFOHEADER) As Long Dim tRGBQ As RGBQUAD ' Returns the position of the DIB bitmap bits within a ' DIB bitmap array: FindDIBits = Len(tBMI) + DIBNumColors(tBMI) * Len(tRGBQ) End Function Private Function DIBNumColors(ByRef tBMI As BITMAPINFOHEADER) As Long '{ Dim wBitCount As Long Dim dwClrUsed As Long ' Returns the number of colour entries in a DIB: dwClrUsed = tBMI.biClrUsed If (dwClrUsed <> 0) Then DIBNumColors = dwClrUsed Else wBitCount = tBMI.biBitCount Select Case wBitCount Case 1 DIBNumColors = 2 Case 4 DIBNumColors = 16 Case 8 DIBNumColors = 256 Case Else DIBNumColors = 0 End Select End If ' } '/* End DIBNumColors() ******************************************************/ End Function Private Function WidthBytes(ByVal lWidth As Long) As Long '#define WIDTHBYTES(bits) ((((bits) + 31)>>5)<<2) ' Returns the width of a row in a DIB Bitmap given the ' number of bits. DIB Bitmap rows always align on a DWORD boundary. WidthBytes = ((lWidth + 31) / 32) * 4 End Function
演示窗体：
测试窗体Form1模块：
'窗体添加控件如下（添加的控件按照上图布局）： '1、添加三个图片框控件： Pictureicon,Pictureimage,Picturemask； ' 再分别添加三个标签控件：Labelicon,Labelimage,Labelmask '2、添加一个列表框控件：ListIcons；再加上一个标签控件：LabelListIcon '3、添加一个文本框控件：TxtIconIfo；再加上一个标签控件：LabelIconIfo '4、添加二个文本框控件：TxtWidth,TxtHeight；再分别加上二个标签控件：LabelWidth,LabelHeight '5、添加一个组合框控件：ComboColours，再加上一个标签控件：LabelColours '6、添加五个命令按钮：Command1,Command2,Command3,Command4,Command5 '7、最后添加一个通用对话框控件：CommonDialog1 Option Explicit Private m_cIcon As IconClass '定义图标类 '列出ICON文件中所有图标 Private Sub pDisplayIcons() Dim i As Long Dim Hdpi As Long, Vdpi As Long Dim Ret As Boolean ListIcons.Clear If m_cIcon.ImageCount > 0 Then For i = 1 To m_cIcon.ImageCount ListIcons.AddItem m_cIcon.ImageWidth(i) & "x" & m_cIcon.ImageHeight(i) & ", " & m_cIcon.ImageColourCount(i) & " Colours" If i = m_cIcon.ImageCount Then Ret = m_cIcon.Logpixelsxy(Hdpi, Vdpi) TxtIconIfo.Text = "宽度： " & m_cIcon.ImageWidth(i) & vbCrLf & "高度： " & m_cIcon.ImageHeight(i) TxtIconIfo.Text = TxtIconIfo.Text & vbCrLf & "水平分辨率：" & Hdpi & vbCrLf & "垂直分辨率：" & Vdpi End If Next ListIcons.ListIndex = 0 End If End Sub '打开图标文件 Private Sub Command1_Click() '设置“CancelError”为 True CommonDialog1.CancelError = True On Error GoTo ErrHandler ' 设置标志 CommonDialog1.Flags = cdlOFNHideReadOnly ' 设置过滤器 CommonDialog1.Filter = "图标文件(*.ico)|*.ico|" ' 指定缺省的过滤器 CommonDialog1.FilterIndex = 1 ' 显示“打开”对话框 CommonDialog1.ShowOpen ' 显示选定文件的名字 m_cIcon.LoadIcon CommonDialog1.FileName Me.Caption = Me.Caption & "-" & CommonDialog1.FileName pDisplayIcons Exit Sub ErrHandler: ' 用户按了“取消”按钮 Exit Sub End Sub '保存图标资源到文件 Private Sub Command2_Click() '列表框中不含图标资源（或者未打开图标资源） If ListIcons.ListCount = 0 Then MsgBox ("不存在已打开的图标资源！"): Exit Sub '设置“CancelError”为 True CommonDialog1.CancelError = True On Error GoTo ErrHandler ' 设置标志 CommonDialog1.Flags = cdlOFNHideReadOnly ' 设置过滤器 CommonDialog1.Filter = "图标文件(*.ico)|*.ico|" ' 指定缺省的过滤器 CommonDialog1.FilterIndex = 1 '设置缺省的文件名 CommonDialog1.FileName = App.Path & "/ICONTest.ico" ' 显示“打开”对话框 CommonDialog1.ShowSave ' 显示选定文件的名字 m_cIcon.SaveIcon CommonDialog1.FileName Exit Sub ErrHandler: ' 用户按了“取消”按钮 Exit Sub End Sub '添加图标 Private Sub Command3_Click() LabelWidth.Visible = True LabelHeight.Visible = True LabelColours.Visible = True TxtWidth.Visible = True TxtHeight.Visible = True ComboColours.Visible = True Command5.Visible = True End Sub '删除图标 Private Sub Command4_Click() If vbYes = MsgBox("你确想删除所选图标吗?", vbYesNo Or vbQuestion) Then ' todo m_cIcon.RemoveImage ListIcons.ListIndex + 1 If ListIcons.ListIndex = -1 Then Exit Sub Else ListIcons.RemoveItem (ListIcons.ListIndex) End If 'listIcons.Refresh End If End Sub '确定添加图标 Private Sub Command5_Click() If ListIcons.ListCount = 0 Then MsgBox ("请打开一个图标文件！"): Exit Sub m_cIcon.AddImage CLng(TxtWidth.Text), CLng(TxtHeight.Text), CLng(ComboColours.ItemData(ComboColours.ListIndex)) pDisplayIcons LabelWidth.Visible = False LabelHeight.Visible = False LabelColours.Visible = False TxtWidth.Visible = False TxtHeight.Visible = False ComboColours.Visible = False Command5.Visible = False End Sub Private Sub Form_Load() Me.ScaleMode = 1 Pictureicon.ScaleMode = 3 Pictureimage.ScaleMode = 3 Picturemask.ScaleMode = 3 Pictureicon.Width = 255 * Screen.TwipsPerPixelX Pictureicon.Height = 255 * Screen.TwipsPerPixelY Pictureimage.Width = 255 * Screen.TwipsPerPixelX Pictureimage.Height = 255 * Screen.TwipsPerPixelY Picturemask.Width = 255 * Screen.TwipsPerPixelX Picturemask.Height = 255 * Screen.TwipsPerPixelY Labelicon.Caption = "图标" Labelimage.Caption = "图像" Labelmask.Caption = "掩模" Command1.Caption = "打开图标文件" Command2.Caption = "保存图标" Command3.Caption = "添加图标" Command4.Caption = "删除图标" Command5.Caption = "确定添加图标" LabelListIcon.Caption = "列出ICON文件中所有图标" LabelWidth.Caption = "图标宽度" LabelHeight.Caption = "图标高度" LabelColours.Caption = "图标颜色" LabelIconIfo.Caption = "当前图标信息" TxtIconIfo.Text = "" TxtWidth.Text = "8" TxtHeight.Text = "8" With ComboColours .AddItem "2 Colours (Monochrome" .ItemData(.NewIndex) = 2 .AddItem "16 Colours" .ItemData(.NewIndex) = 16 .AddItem "256 Colours" .ItemData(.NewIndex) = 256 .AddItem "Millions of Colours" .ItemData(.NewIndex) = 2 ^ 24 .ListIndex = 1 End With LabelWidth.Visible = False LabelHeight.Visible = False LabelColours.Visible = False TxtWidth.Visible = False TxtHeight.Visible = False ComboColours.Visible = False Command5.Visible = False Me.Caption = "Icon 应用程序" Set m_cIcon = New IconClass End Sub Private Sub Form_Unload(Cancel As Integer) Set m_cIcon = Nothing End Sub '单击列表框,显示相应图标 Private Sub ListIcons_Click() Dim lIndex As Long lIndex = ListIcons.ListIndex + 1 If (lIndex > 0) Then Set Pictureicon = m_cIcon.IconPicture(Pictureicon.hdc, lIndex) Pictureimage.Cls Picturemask.Cls m_cIcon.DrawIconImage Pictureimage.hdc, lIndex, ecfiImage m_cIcon.DrawIconImage Picturemask.hdc, lIndex, ecfiMask End If End Sub
