导出ImageList控件中的图像

t小宝 · 发表于 2013-7-16 16:37:17

本帖最后由 t小宝于 2013-7-16 17:04 编辑

ImageList非Access自带，是Activex控件，用于保存多个图像，为TreeView、ListView等兄弟控件提供图像引用。
有时候我们添加到ImageList控件的原始图片找不到了，但ImageList中还有，怎么把它们导出来另作它用呢？
王站已经开了一个好头，在这里：http://www.office-cn.net/access/20130715/8063.html
ImageList控件允许两种图像格式：图标和位图。用常规的SavePicture方法可以正常导出位图，但导出图标会失真（因为色深变成4位）。
于是只能自己动手丰衣足食，写了一个模块，实现正常导出图标，还能够自动区分图标和位图，分别导出。
要注意的是，从ImageList控件中获取的图标丢失了原始色深（位深）信息，所以在代码中设了一个参数，可以手动指定导出图标的色深，一般指定为24位（真彩色）即可。

模块中的代码：

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 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
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD
b As Byte
G As Byte
r As Byte
a As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD
End Type
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hBMColor As Long
End Type
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
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 BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Const DIB_RGB_COLORS = 0
Private Const BI_RGB = 0&
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
' 函数名称: IcoToFile
' 功能描述: 从图标句柄创建图标文件
' 输入参数: hIcon .......... 必选，图标句柄
' sFileName ...... 必选，输出文件名
' iBitsPixel ..... 可选，图标的色深，2、4、8、16、24、32等值。如果不指定，自动获取色深
' 返回参数: 成功返回 True
' 使用示例: IcoToFile hIcon, "C:\MyIcon.ico", 24 '从图标句柄hIcon创建图标文件，指定色深为24位，输出到C:\MyIcon.ico
' 作者: t小宝 (QQ:377922812)
' 创建日期: 20013-07-16
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
Public Function IcoToFile(ByVal hIcon As Long, ByVal sFileName As String, Optional iBitsPixel As Integer) As Boolean
On Error GoTo Err_Handler
Dim tIconInfo As ICONINFO
Dim hBMColor As Long
Dim hbmMask As Long
Dim hMemDC As Long
Dim bm As bitmap
Dim tBitInfoAND As BITMAPINFO
Dim tBitInfoXOR As BITMAPINFO
Dim lBmiHeaderLen As Long
Dim lColorsLen As Long
Dim bytDataAND() As Byte
Dim bytDataXOR() As Byte
Dim tIconDir As icondir ' 图标目录结构
Dim iFileNum As Integer
Dim bytAnd() As Byte
Dim i As Long, j As Long, k As Long
Dim bBlank As Boolean
Dim byt0 As Byte, byt1 As Byte, byt2 As Byte, byt3 As Byte ' 检查所有像素是否相同
If Len(sFileName) = 0 Then Exit Function
' 从图标句柄获取图标XOR位图和AND位图
GetIconInfo hIcon, tIconInfo
hBMColor = tIconInfo.hBMColor
hbmMask = tIconInfo.hbmMask
' 获取XOR位图数据
lBmiHeaderLen = Len(tBitInfoXOR.bmiHeader) '40
GetObject hBMColor, Len(bm), bm
If iBitsPixel <> 1 And iBitsPixel <> 4 And iBitsPixel <> 8 And iBitsPixel <> 16 _
And iBitsPixel <> 24 And iBitsPixel <> 32 Then iBitsPixel = bm.bmBitsPixel
If bm.bmWidth > 255 Or bm.bmHeight > 255 Then Exit Function ' 图标尺寸不能大于256*256
With tBitInfoXOR.bmiHeader
.biWidth = bm.bmWidth
.biHeight = bm.bmHeight
.biBitCount = iBitsPixel
.biCompression = BI_RGB
.biPlanes = 1
.biSize = lBmiHeaderLen
If .biBitCount = 8 Then
lColorsLen = 256 * 4
ElseIf .biBitCount = 4 Then
lColorsLen = 16 * 4
ElseIf .biBitCount = 1 Then
lColorsLen = 2 * 4
End If
ReDim bytDataXOR(((.biWidth * .biBitCount / 8 + 3) \ 4) * 4 * .biHeight - 1) As Byte ' 设置数组大小与位图数据一致
End With
hMemDC = CreateCompatibleDC(0) ' 创建内存设备场景
GetDIBits hMemDC, hBMColor, 0, bm.bmHeight, bytDataXOR(0), tBitInfoXOR, DIB_RGB_COLORS ' 获得位图数据
' 获取AND位图数据
If hbmMask = 0 Then
tBitInfoAND.bmiHeader.biSizeImage = ((bm.bmWidth * 1 / 8 + 3) \ 4) * 4 * bm.bmHeight
ReDim bytDataAND(tBitInfoAND.bmiHeader.biSizeImage - 1) As Byte ' 设置数组大小与位图数据一致
Else
GetObject hbmMask, Len(bm), bm
With tBitInfoAND.bmiHeader
.biWidth = bm.bmWidth
.biHeight = bm.bmHeight
.biBitCount = 1
.biCompression = BI_RGB
.biPlanes = 1
.biSize = lBmiHeaderLen
End With
ReDim bytDataAND(((bm.bmWidth * 1 / 8 + 3) \ 4) * 4 * bm.bmHeight - 1) As Byte ' 设置数组大小与位图数据一致
GetDIBits hMemDC, hbmMask, 0, bm.bmHeight, bytDataAND(0), tBitInfoAND, DIB_RGB_COLORS ' 获得位图数据
End If
DeleteDC hMemDC
'处理图标目录
ReDim tIconDir.identries(0)
tIconDir.idreserved = 0 ' 保留字，必须为0
tIconDir.idtype = 1 ' 1为图标，0为光标
tIconDir.idcount = 1 ' 图像个数
With tIconDir.identries(0)
.bwidth = tBitInfoXOR.bmiHeader.biWidth
.bheight = tBitInfoXOR.bmiHeader.biHeight
.bcolorcount = 0
.breserved = 0
.wplanes = 1 ' 不设也没有影响
.wbitcount = tBitInfoXOR.bmiHeader.biBitCount ' 每个像素的位数，不设也没有影响
.dwbytesinres = lBmiHeaderLen + lColorsLen + _
tBitInfoXOR.bmiHeader.biSizeImage + tBitInfoAND.bmiHeader.biSizeImage '
.dwimageoffset = 22 ' 图像数据偏移起点，第1个图像是22
End With
'XOR位图信息头两个成员须要调整
With tBitInfoXOR.bmiHeader
.biSizeImage = .biSizeImage + tBitInfoAND.bmiHeader.biSizeImage
.biHeight = .biHeight * 2
End With
'创建文件写入图标数据
iFileNum = FreeFile
Open sFileName For Output As #iFileNum
Close #iFileNum
Open sFileName For Binary As #iFileNum
Put #iFileNum, , tIconDir.idreserved
Put #iFileNum, , tIconDir.idtype
Put #iFileNum, , tIconDir.idcount
Put #iFileNum, , tIconDir.identries(0) ' icondirentry 图标目录
Put #iFileNum, , tBitInfoXOR.bmiHeader ' XOR位图头
If lColorsLen > 0 Then Put #iFileNum, , tBitInfoXOR.bmiColors ' XOR位图颜色表
Put #iFileNum, , bytDataXOR ' XOR位图数据
Put #iFileNum, , bytDataAND ' AND位图数据
Close #iFileNum
IcoToFile = True
Err_Handler:
Exit Function
End Function

复制代码

在窗体上添加一个ImageList控件，插入一些图标和位图，添加一个命令按钮，窗体模块中添加以下代码：

Private Sub Command1_Click()
Dim pic As IPictureDisp
Dim i As Integer
For i = 1 To Me.ImageList0.ListImages.Count
'.ListImages(i).ExtractIcon：返回的总是图标 '.Overlay(i,i)：返回的总是位图
Set pic = Me.ImageList0.ListImages(i).Picture
' 3是图标，1是位图
If pic.Type = 3 Then
'这里图标的色深是当前屏幕色深，不是原始图标的色深，所以在最后一个参数指定色深。用LoadPicture加载的图片可以取得原始色深。
IcoToFile pic.handle, "C:\ImageList" & i & ".ico", 24
Else
SavePicture pic, "C:\ImageList" & i & ".bmp"
End If
Set pic = Nothing
Next
MsgBox "已导出到c盘根目录。"
End Sub

复制代码

示例如下：

游客，如果您要查看本帖隐藏内容请回复

tmtony · 发表于 2013-7-16 17:13:14

好贴, 用小宝的工具解决了我的图片的导出问题. 且图片不失真.
小宝对图片的处理的确很到位

cylphoenix · 发表于 2013-7-16 17:32:33

seesee

XB2009 · 发表于 2013-7-16 18:01:51

{:soso_e163:}感谢分享!!

zhuyiwen · 发表于 2013-7-16 18:41:28

顶一个！

yanwei82123300 · 发表于 2013-7-16 20:59:26

谢谢分享

t小宝 · 发表于 2013-7-16 21:17:08

模块代码中有些变量声明忘记删了{:soso_e101:}

xie62 · 发表于 2013-7-18 06:43:25

感谢分享!!

tanandersen · 发表于 2013-7-18 10:03:22

感谢分享！

gnoy · 发表于 2013-7-18 11:15:52

学习一下

帐号		自动登录	找回密码
密码			注册

群介绍
Access培训群 (792054000)
Access免费培训群2 (792054000)
Access经典源码培训群 (77130759)
Access源码技巧群 (138920637)
access vba (307776555)

主题相关群

地区相关群[您还没设置居住地]

[模块/函数] 导出ImageList控件中的图像

本帖子中包含更多资源

评分

本帖被以下淘专辑推荐:

群介绍
主题无相 (随机显示版	同地区群块其他地区)