設(shè)為首頁收藏本站Access中國

Office中國論壇/Access中國論壇

 找回密碼
 注冊

QQ登錄

只需一步，快速開始

123下一頁
返回列表 發(fā)新帖
查看: 16379|回復(fù): 22
打印 上一主題 下一主題

[模塊/函數(shù)] 導(dǎo)出ImageList控件中的圖像

[復(fù)制鏈接]

點(diǎn)擊這里給我發(fā)消息
跳轉(zhuǎn)到指定樓層
1#
發(fā)表于 2013-7-16 16:37:17 | 只看該作者 回帖獎(jiǎng)勵(lì) |倒序?yàn)g覽 |閱讀模式
本帖最后由 t小寶 于 2013-7-16 17:04 編輯

ImageList非Access自帶，是Activex控件，用于保存多個(gè)圖像，為TreeView、ListView等兄弟控件提供圖像引用。
有時(shí)候我們添加到ImageList控件的原始圖片找不到了，但I(xiàn)mageList中還有，怎么把它們導(dǎo)出來另作它用呢？
王站已經(jīng)開了一個(gè)好頭，在這里：http://m.mzhfr.cn/access/20130715/8063.html
ImageList控件允許兩種圖像格式：圖標(biāo)和位圖。用常規(guī)的SavePicture方法可以正常導(dǎo)出位圖，但導(dǎo)出圖標(biāo)會(huì)失真（因?yàn)樯钭兂?位）。
于是只能自己動(dòng)手豐衣足食，寫了一個(gè)模塊，實(shí)現(xiàn)正常導(dǎo)出圖標(biāo)，還能夠自動(dòng)區(qū)分圖標(biāo)和位圖，分別導(dǎo)出。
要注意的是，從ImageList控件中獲取的圖標(biāo)丟失了原始色深（位深）信息，所以在代碼中設(shè)了一個(gè)參數(shù)，可以手動(dòng)指定導(dǎo)出圖標(biāo)的色深，一般指定為24位（真彩色）即可。

模塊中的代碼：

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

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

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

  43. Private Type RGBQUAD
  44.     b As Byte
  45.     G As Byte
  46.     r As Byte
  47.     a As Byte
  48. End Type

  50. Private Type BITMAPINFO
  51.     bmiHeader As BITMAPINFOHEADER
  52.     bmiColors(255) As RGBQUAD
  53. End Type

  55. Private Type ICONINFO
  56.     fIcon As Long
  57.     xHotspot As Long
  58.     yHotspot As Long
  59.     hbmMask As Long
  60.     hBMColor As Long
  61. End Type

  63. Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
  64. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  65. 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
  66. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
  67. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long

  69. Private Const DIB_RGB_COLORS = 0
  70. Private Const BI_RGB = 0&


  73. '━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
  74. '  函數(shù)名稱: IcoToFile
  75. '  功能描述: 從圖標(biāo)句柄創(chuàng)建圖標(biāo)文件
  76. '  輸入?yún)?shù): hIcon  .......... 必選，圖標(biāo)句柄
  77. '            sFileName  ...... 必選，輸出文件名
  78. '            iBitsPixel  ..... 可選，圖標(biāo)的色深，2、4、8、16、24、32等值。如果不指定，自動(dòng)獲取色深
  79. '  返回參數(shù): 成功返回 True
  80. '  使用示例: IcoToFile hIcon, "C:\MyIcon.ico", 24  '從圖標(biāo)句柄hIcon創(chuàng)建圖標(biāo)文件，指定色深為24位，輸出到C:\MyIcon.ico
  81. '  作    者: t小寶 (QQ:377922812)
  82. '  創(chuàng)建日期: 20013-07-16
  83. '━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
  84. Public Function IcoToFile(ByVal hIcon As Long, ByVal sFileName As String, Optional iBitsPixel As Integer) As Boolean
  85. On Error GoTo Err_Handler

  87.     Dim tIconInfo As ICONINFO
  88.     Dim hBMColor As Long
  89.     Dim hbmMask As Long
  90.     Dim hMemDC As Long
  91.     Dim bm As bitmap
  92.     Dim tBitInfoAND As BITMAPINFO
  93.     Dim tBitInfoXOR As BITMAPINFO
  94.     Dim lBmiHeaderLen As Long
  95.     Dim lColorsLen As Long

  97.     Dim bytDataAND() As Byte
  98.     Dim bytDataXOR() As Byte
  99.     Dim tIconDir As icondir     ' 圖標(biāo)目錄結(jié)構(gòu)
  100.     Dim iFileNum As Integer
  101.    
  102.     Dim bytAnd() As Byte
  103.     Dim i As Long, j As Long, k As Long
  104.     Dim bBlank As Boolean
  105.     Dim byt0 As Byte, byt1 As Byte, byt2 As Byte, byt3 As Byte ' 檢查所有像素是否相同
  106.    
  107.     If Len(sFileName) = 0 Then Exit Function
  108.    
  109.     ' 從圖標(biāo)句柄獲取圖標(biāo)XOR位圖和AND位圖
  110.     GetIconInfo hIcon, tIconInfo
  111.     hBMColor = tIconInfo.hBMColor
  112.     hbmMask = tIconInfo.hbmMask

  114.     ' 獲取XOR位圖數(shù)據(jù)
  115.     lBmiHeaderLen = Len(tBitInfoXOR.bmiHeader)   '40
  116.     GetObject hBMColor, Len(bm), bm
  117.     If iBitsPixel <> 1 And iBitsPixel <> 4 And iBitsPixel <> 8 And iBitsPixel <> 16 _
  118.         And iBitsPixel <> 24 And iBitsPixel <> 32 Then iBitsPixel = bm.bmBitsPixel
  119.     If bm.bmWidth > 255 Or bm.bmHeight > 255 Then Exit Function                         ' 圖標(biāo)尺寸不能大于256*256

  121.     With tBitInfoXOR.bmiHeader
  122.         .biWidth = bm.bmWidth
  123.         .biHeight = bm.bmHeight
  124.         .biBitCount = iBitsPixel
  125.         .biCompression = BI_RGB
  126.         .biPlanes = 1
  127.         .biSize = lBmiHeaderLen
  128.         If .biBitCount = 8 Then
  129.             lColorsLen = 256 * 4
  130.         ElseIf .biBitCount = 4 Then
  131.             lColorsLen = 16 * 4
  132.         ElseIf .biBitCount = 1 Then
  133.             lColorsLen = 2 * 4
  134.         End If
  135.         ReDim bytDataXOR(((.biWidth * .biBitCount / 8 + 3) \ 4) * 4 * .biHeight - 1) As Byte        ' 設(shè)置數(shù)組大小與位圖數(shù)據(jù)一致
  136.     End With
  137.    
  138.     hMemDC = CreateCompatibleDC(0)                                                           ' 創(chuàng)建內(nèi)存設(shè)備場景
  139.     GetDIBits hMemDC, hBMColor, 0, bm.bmHeight, bytDataXOR(0), tBitInfoXOR, DIB_RGB_COLORS    ' 獲得位圖數(shù)據(jù)
  140.    
  141.     ' 獲取AND位圖數(shù)據(jù)
  142.     If hbmMask = 0 Then
  143.         tBitInfoAND.bmiHeader.biSizeImage = ((bm.bmWidth * 1 / 8 + 3) \ 4) * 4 * bm.bmHeight
  144.         ReDim bytDataAND(tBitInfoAND.bmiHeader.biSizeImage - 1) As Byte                         ' 設(shè)置數(shù)組大小與位圖數(shù)據(jù)一致
  145.     Else
  146.         GetObject hbmMask, Len(bm), bm
  147.         With tBitInfoAND.bmiHeader
  148.             .biWidth = bm.bmWidth
  149.             .biHeight = bm.bmHeight
  150.             .biBitCount = 1
  151.             .biCompression = BI_RGB
  152.             .biPlanes = 1
  153.             .biSize = lBmiHeaderLen
  154.         End With
  155.         ReDim bytDataAND(((bm.bmWidth * 1 / 8 + 3) \ 4) * 4 * bm.bmHeight - 1) As Byte        ' 設(shè)置數(shù)組大小與位圖數(shù)據(jù)一致
  156.         GetDIBits hMemDC, hbmMask, 0, bm.bmHeight, bytDataAND(0), tBitInfoAND, DIB_RGB_COLORS    ' 獲得位圖數(shù)據(jù)
  157.     End If

  159.     DeleteDC hMemDC

  161.     '處理圖標(biāo)目錄
  162.     ReDim tIconDir.identries(0)
  163.     tIconDir.idreserved = 0                             ' 保留字，必須為0
  164.     tIconDir.idtype = 1                             ' 1為圖標(biāo)，0為光標(biāo)
  165.     tIconDir.idcount = 1                             ' 圖像個(gè)數(shù)
  166.     With tIconDir.identries(0)
  167.         .bwidth = tBitInfoXOR.bmiHeader.biWidth
  168.         .bheight = tBitInfoXOR.bmiHeader.biHeight
  169.         .bcolorcount = 0
  170.         .breserved = 0
  171.         .wplanes = 1                                                              ' 不設(shè)也沒有影響
  172.         .wbitcount = tBitInfoXOR.bmiHeader.biBitCount                             ' 每個(gè)像素的位數(shù)，不設(shè)也沒有影響
  173.         .dwbytesinres = lBmiHeaderLen + lColorsLen + _
  174.             tBitInfoXOR.bmiHeader.biSizeImage + tBitInfoAND.bmiHeader.biSizeImage '
  175.         .dwimageoffset = 22                                                       ' 圖像數(shù)據(jù)偏移起點(diǎn)，第1個(gè)圖像是22
  176.     End With
  177.    
  178.     'XOR位圖信息頭兩個(gè)成員須要調(diào)整
  179.     With tBitInfoXOR.bmiHeader
  180.         .biSizeImage = .biSizeImage + tBitInfoAND.bmiHeader.biSizeImage
  181.         .biHeight = .biHeight * 2
  182.     End With

  184.     '創(chuàng)建文件 寫入圖標(biāo)數(shù)據(jù)
  185.     iFileNum = FreeFile
  186.     Open sFileName For Output As #iFileNum
  187.     Close #iFileNum
  188.     Open sFileName For Binary As #iFileNum
  189.     Put #iFileNum, , tIconDir.idreserved
  190.     Put #iFileNum, , tIconDir.idtype
  191.     Put #iFileNum, , tIconDir.idcount
  192.     Put #iFileNum, , tIconDir.identries(0)                             ' icondirentry 圖標(biāo)目錄
  193.     Put #iFileNum, , tBitInfoXOR.bmiHeader                             ' XOR位圖頭
  194.     If lColorsLen > 0 Then Put #iFileNum, , tBitInfoXOR.bmiColors      ' XOR位圖顏色表
  195.     Put #iFileNum, , bytDataXOR                                        ' XOR位圖數(shù)據(jù)
  196.     Put #iFileNum, , bytDataAND                                        ' AND位圖數(shù)據(jù)
  197.     Close #iFileNum
  198.     IcoToFile = True
  199.    
  200. Err_Handler:
  201.     Exit Function
  202. End Function
復(fù)制代碼
在窗體上添加一個(gè)ImageList控件，插入一些圖標(biāo)和位圖，添加一個(gè)命令按鈕，窗體模塊中添加以下代碼：
  1. Private Sub Command1_Click()

  3.     Dim pic As IPictureDisp
  4.     Dim i As Integer
  5.    
  6.     For i = 1 To Me.ImageList0.ListImages.Count
  7.         '.ListImages(i).ExtractIcon：返回的總是圖標(biāo) '.Overlay(i,i)：返回的總是位圖
  8.         Set pic = Me.ImageList0.ListImages(i).Picture
  9.         
  10.         ' 3是圖標(biāo)，1是位圖
  11.         If pic.Type = 3 Then
  12.             '這里圖標(biāo)的色深是當(dāng)前屏幕色深，不是原始圖標(biāo)的色深，所以在最后一個(gè)參數(shù)指定色深。用LoadPicture加載的圖片可以取得原始色深。
  13.             IcoToFile pic.handle, "C:\ImageList" & i & ".ico", 24
  14.         Else
  15.             SavePicture pic, "C:\ImageList" & i & ".bmp"
  16.         End If
  17.         Set pic = Nothing
  18.     Next
  19.     MsgBox "已導(dǎo)出到c盤根目錄。"
  20.    
  21. End Sub
復(fù)制代碼

示例如下：
游客，如果您要查看本帖隱藏內(nèi)容請回復(fù)


本帖子中包含更多資源

您需要 登錄 才可以下載或查看，沒有帳號？注冊

x

評分

參與人數(shù) 2經(jīng)驗(yàn) +20 收起 理由
roych + 10 很給力!
魚兒游游 + 10 很給力!

查看全部評分

本帖被以下淘專輯推薦:

分享到:  QQ好友和群QQ好友和群 QQ空間QQ空間 騰訊微博騰訊微博 騰訊朋友騰訊朋友
收藏收藏 分享分享 分享淘帖1 訂閱訂閱

點(diǎn)擊這里給我發(fā)消息
2#
發(fā)表于 2013-7-16 17:13:14 | 只看該作者
好貼, 用小寶的工具解決了我的圖片的導(dǎo)出問題. 且圖片不失真.
小寶對圖片的處理 的確很到位
3#
發(fā)表于 2013-7-16 17:32:33 | 只看該作者
seesee
回復(fù)

使用道具 舉報(bào)

點(diǎn)擊這里給我發(fā)消息
4#
發(fā)表于 2013-7-16 18:01:51 | 只看該作者
{:soso_e163:}感謝分享!!

點(diǎn)擊這里給我發(fā)消息
5#
發(fā)表于 2013-7-16 18:41:28 | 只看該作者
頂一個(gè)！
回復(fù)

使用道具 舉報(bào)

6#
發(fā)表于 2013-7-16 20:59:26 | 只看該作者
謝謝分享
回復(fù)

使用道具 舉報(bào)

點(diǎn)擊這里給我發(fā)消息
7#
 樓主| 發(fā)表于 2013-7-16 21:17:08 | 只看該作者
模塊代碼中有些變量聲明忘記刪了{(lán):soso_e101:}
8#
發(fā)表于 2013-7-18 06:43:25 | 只看該作者
感謝分享!!
回復(fù)

使用道具 舉報(bào)

9#
發(fā)表于 2013-7-18 10:03:22 | 只看該作者
感謝分享！
回復(fù)

使用道具 舉報(bào)

10#
發(fā)表于 2013-7-18 11:15:52 | 只看該作者
學(xué)習(xí)一下
回復(fù)

使用道具 舉報(bào)

您需要登錄后才可以回帖 登錄 | 注冊

本版積分規(guī)則

QQ|站長郵箱|小黑屋|手機(jī)版|Office中國/Access中國 ( 粵ICP備10043721號-1 )  

GMT+8, 2025-7-13 05:25 , Processed in 0.103614 second(s), 38 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

快速回復(fù) 返回頂部 返回列表