设为首页收藏本站Access中国

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步,快速开始

123下一页
返回列表 发新帖
查看: 15324|回复: 22
打印 上一主题 下一主题

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

[复制链接]

点击这里给我发消息

跳转到指定楼层
1#
发表于 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位(真彩色)即可。

模块中的代码:

  1. Private Type icondirentry
  2.     bwidth  As Byte
  3.     bheight  As Byte
  4.     bcolorcount  As Byte
  5.     breserved  As Byte
  6.     wplanes  As Integer
  7.     wbitcount  As Integer
  8.     dwbytesinres  As Long
  9.     dwimageoffset  As Long
  10. End Type
  11. Private Type icondir
  12.     idreserved As Integer
  13.     idtype As Integer
  14.     idcount As Integer
  15.     identries() As icondirentry
  16. End Type

  17. Private Type bitmap
  18.     bmType As Long
  19.     bmWidth As Long
  20.     bmHeight As Long
  21.     bmWidthBytes As Long
  22.     bmPlanes As Integer
  23.     bmBitsPixel As Integer
  24.     bmBits As Long
  25. End Type

  26. Private Type BITMAPINFOHEADER
  27.     biSize          As Long
  28.     biWidth         As Long
  29.     biHeight        As Long
  30.     biPlanes        As Integer
  31.     biBitCount      As Integer
  32.     biCompression   As Long
  33.     biSizeImage     As Long
  34.     biXPelsPerMeter As Long
  35.     biYPelsPerMeter As Long
  36.     biClrUsed       As Long
  37.     biClrImportant  As Long
  38. End Type

  39. Private Type RGBQUAD
  40.     b As Byte
  41.     G As Byte
  42.     r As Byte
  43.     a As Byte
  44. End Type

  45. Private Type BITMAPINFO
  46.     bmiHeader As BITMAPINFOHEADER
  47.     bmiColors(255) As RGBQUAD
  48. End Type

  49. Private Type ICONINFO
  50.     fIcon As Long
  51.     xHotspot As Long
  52.     yHotspot As Long
  53.     hbmMask As Long
  54.     hBMColor As Long
  55. End Type

  56. Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
  57. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  58. 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
  59. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
  60. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long

  61. Private Const DIB_RGB_COLORS = 0
  62. Private Const BI_RGB = 0&


  63. '━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
  64. '  函数名称: IcoToFile
  65. '  功能描述: 从图标句柄创建图标文件
  66. '  输入参数: hIcon  .......... 必选,图标句柄
  67. '            sFileName  ...... 必选,输出文件名
  68. '            iBitsPixel  ..... 可选,图标的色深,2、4、8、16、24、32等值。如果不指定,自动获取色深
  69. '  返回参数: 成功返回 True
  70. '  使用示例: IcoToFile hIcon, "C:\MyIcon.ico", 24  '从图标句柄hIcon创建图标文件,指定色深为24位,输出到C:\MyIcon.ico
  71. '  作    者: t小宝 (QQ:377922812)
  72. '  创建日期: 20013-07-16
  73. '━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
  74. Public Function IcoToFile(ByVal hIcon As Long, ByVal sFileName As String, Optional iBitsPixel As Integer) As Boolean
  75. On Error GoTo Err_Handler

  76.     Dim tIconInfo As ICONINFO
  77.     Dim hBMColor As Long
  78.     Dim hbmMask As Long
  79.     Dim hMemDC As Long
  80.     Dim bm As bitmap
  81.     Dim tBitInfoAND As BITMAPINFO
  82.     Dim tBitInfoXOR As BITMAPINFO
  83.     Dim lBmiHeaderLen As Long
  84.     Dim lColorsLen As Long

  85.     Dim bytDataAND() As Byte
  86.     Dim bytDataXOR() As Byte
  87.     Dim tIconDir As icondir     ' 图标目录结构
  88.     Dim iFileNum As Integer
  89.    
  90.     Dim bytAnd() As Byte
  91.     Dim i As Long, j As Long, k As Long
  92.     Dim bBlank As Boolean
  93.     Dim byt0 As Byte, byt1 As Byte, byt2 As Byte, byt3 As Byte ' 检查所有像素是否相同
  94.    
  95.     If Len(sFileName) = 0 Then Exit Function
  96.    
  97.     ' 从图标句柄获取图标XOR位图和AND位图
  98.     GetIconInfo hIcon, tIconInfo
  99.     hBMColor = tIconInfo.hBMColor
  100.     hbmMask = tIconInfo.hbmMask

  101.     ' 获取XOR位图数据
  102.     lBmiHeaderLen = Len(tBitInfoXOR.bmiHeader)   '40
  103.     GetObject hBMColor, Len(bm), bm
  104.     If iBitsPixel <> 1 And iBitsPixel <> 4 And iBitsPixel <> 8 And iBitsPixel <> 16 _
  105.         And iBitsPixel <> 24 And iBitsPixel <> 32 Then iBitsPixel = bm.bmBitsPixel
  106.     If bm.bmWidth > 255 Or bm.bmHeight > 255 Then Exit Function                         ' 图标尺寸不能大于256*256

  107.     With tBitInfoXOR.bmiHeader
  108.         .biWidth = bm.bmWidth
  109.         .biHeight = bm.bmHeight
  110.         .biBitCount = iBitsPixel
  111.         .biCompression = BI_RGB
  112.         .biPlanes = 1
  113.         .biSize = lBmiHeaderLen
  114.         If .biBitCount = 8 Then
  115.             lColorsLen = 256 * 4
  116.         ElseIf .biBitCount = 4 Then
  117.             lColorsLen = 16 * 4
  118.         ElseIf .biBitCount = 1 Then
  119.             lColorsLen = 2 * 4
  120.         End If
  121.         ReDim bytDataXOR(((.biWidth * .biBitCount / 8 + 3) \ 4) * 4 * .biHeight - 1) As Byte        ' 设置数组大小与位图数据一致
  122.     End With
  123.    
  124.     hMemDC = CreateCompatibleDC(0)                                                           ' 创建内存设备场景
  125.     GetDIBits hMemDC, hBMColor, 0, bm.bmHeight, bytDataXOR(0), tBitInfoXOR, DIB_RGB_COLORS    ' 获得位图数据
  126.    
  127.     ' 获取AND位图数据
  128.     If hbmMask = 0 Then
  129.         tBitInfoAND.bmiHeader.biSizeImage = ((bm.bmWidth * 1 / 8 + 3) \ 4) * 4 * bm.bmHeight
  130.         ReDim bytDataAND(tBitInfoAND.bmiHeader.biSizeImage - 1) As Byte                         ' 设置数组大小与位图数据一致
  131.     Else
  132.         GetObject hbmMask, Len(bm), bm
  133.         With tBitInfoAND.bmiHeader
  134.             .biWidth = bm.bmWidth
  135.             .biHeight = bm.bmHeight
  136.             .biBitCount = 1
  137.             .biCompression = BI_RGB
  138.             .biPlanes = 1
  139.             .biSize = lBmiHeaderLen
  140.         End With
  141.         ReDim bytDataAND(((bm.bmWidth * 1 / 8 + 3) \ 4) * 4 * bm.bmHeight - 1) As Byte        ' 设置数组大小与位图数据一致
  142.         GetDIBits hMemDC, hbmMask, 0, bm.bmHeight, bytDataAND(0), tBitInfoAND, DIB_RGB_COLORS    ' 获得位图数据
  143.     End If

  144.     DeleteDC hMemDC

  145.     '处理图标目录
  146.     ReDim tIconDir.identries(0)
  147.     tIconDir.idreserved = 0                             ' 保留字,必须为0
  148.     tIconDir.idtype = 1                             ' 1为图标,0为光标
  149.     tIconDir.idcount = 1                             ' 图像个数
  150.     With tIconDir.identries(0)
  151.         .bwidth = tBitInfoXOR.bmiHeader.biWidth
  152.         .bheight = tBitInfoXOR.bmiHeader.biHeight
  153.         .bcolorcount = 0
  154.         .breserved = 0
  155.         .wplanes = 1                                                              ' 不设也没有影响
  156.         .wbitcount = tBitInfoXOR.bmiHeader.biBitCount                             ' 每个像素的位数,不设也没有影响
  157.         .dwbytesinres = lBmiHeaderLen + lColorsLen + _
  158.             tBitInfoXOR.bmiHeader.biSizeImage + tBitInfoAND.bmiHeader.biSizeImage '
  159.         .dwimageoffset = 22                                                       ' 图像数据偏移起点,第1个图像是22
  160.     End With
  161.    
  162.     'XOR位图信息头两个成员须要调整
  163.     With tBitInfoXOR.bmiHeader
  164.         .biSizeImage = .biSizeImage + tBitInfoAND.bmiHeader.biSizeImage
  165.         .biHeight = .biHeight * 2
  166.     End With

  167.     '创建文件 写入图标数据
  168.     iFileNum = FreeFile
  169.     Open sFileName For Output As #iFileNum
  170.     Close #iFileNum
  171.     Open sFileName For Binary As #iFileNum
  172.     Put #iFileNum, , tIconDir.idreserved
  173.     Put #iFileNum, , tIconDir.idtype
  174.     Put #iFileNum, , tIconDir.idcount
  175.     Put #iFileNum, , tIconDir.identries(0)                             ' icondirentry 图标目录
  176.     Put #iFileNum, , tBitInfoXOR.bmiHeader                             ' XOR位图头
  177.     If lColorsLen > 0 Then Put #iFileNum, , tBitInfoXOR.bmiColors      ' XOR位图颜色表
  178.     Put #iFileNum, , bytDataXOR                                        ' XOR位图数据
  179.     Put #iFileNum, , bytDataAND                                        ' AND位图数据
  180.     Close #iFileNum
  181.     IcoToFile = True
  182.    
  183. Err_Handler:
  184.     Exit Function
  185. End Function
复制代码
在窗体上添加一个ImageList控件,插入一些图标和位图,添加一个命令按钮,窗体模块中添加以下代码:
  1. Private Sub Command1_Click()

  2.     Dim pic As IPictureDisp
  3.     Dim i As Integer
  4.    
  5.     For i = 1 To Me.ImageList0.ListImages.Count
  6.         '.ListImages(i).ExtractIcon:返回的总是图标 '.Overlay(i,i):返回的总是位图
  7.         Set pic = Me.ImageList0.ListImages(i).Picture
  8.         
  9.         ' 3是图标,1是位图
  10.         If pic.Type = 3 Then
  11.             '这里图标的色深是当前屏幕色深,不是原始图标的色深,所以在最后一个参数指定色深。用LoadPicture加载的图片可以取得原始色深。
  12.             IcoToFile pic.handle, "C:\ImageList" & i & ".ico", 24
  13.         Else
  14.             SavePicture pic, "C:\ImageList" & i & ".bmp"
  15.         End If
  16.         Set pic = Nothing
  17.     Next
  18.     MsgBox "已导出到c盘根目录。"
  19.    
  20. End Sub
复制代码

示例如下:

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


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x

评分

参与人数 2经验 +20 收起 理由
roych + 10 很给力!
鱼儿游游 + 10 很给力!

查看全部评分

本帖被以下淘专辑推荐:

分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏 分享分享 分享淘帖1 订阅订阅

点击这里给我发消息

2#
发表于 2013-7-16 17:13:14 | 只看该作者
好贴, 用小宝的工具解决了我的图片的导出问题. 且图片不失真.
小宝对图片的处理 的确很到位
3#
发表于 2013-7-16 17:32:33 | 只看该作者
seesee
回复

使用道具 举报

点击这里给我发消息

4#
发表于 2013-7-16 18:01:51 | 只看该作者
{:soso_e163:}感谢分享!!

点击这里给我发消息

5#
发表于 2013-7-16 18:41:28 | 只看该作者
顶一个!
回复

使用道具 举报

6#
发表于 2013-7-16 20:59:26 | 只看该作者
谢谢分享
回复

使用道具 举报

点击这里给我发消息

7#
 楼主| 发表于 2013-7-16 21:17:08 | 只看该作者
模块代码中有些变量声明忘记删了{:soso_e101:}
8#
发表于 2013-7-18 06:43:25 | 只看该作者
感谢分享!!
回复

使用道具 举报

9#
发表于 2013-7-18 10:03:22 | 只看该作者
感谢分享!
回复

使用道具 举报

10#
发表于 2013-7-18 11:15:52 | 只看该作者
学习一下
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-11-5 02:38 , Processed in 0.157487 second(s), 38 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表