|
本帖最后由 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
复制代码
示例如下:
|
本帖子中包含更多资源
您需要 登录 才可以下载或查看,没有帐号?注册
x
评分
-
查看全部评分
|