VBS读取图片像素 WIA 组件

wuxue107

在浏览自己系统里带有的COM组件时，看到了WIA.ImageFile.1 这个网上查了下，了解到这个组件可以对图片做些处理。具体能做些图片格式转换，像素处理，剪切之类的工作。这个组件Win7应该是自带的。

我用他写了个宏，将图片转换为Excel单元格拼接的马赛克图片。下面是代码。图片最好256色的。

1. 
   
2. Public Const scrHeight = 435
   
3. Public Const scrWidth = 124
   
4. Public Const RC = 8
   
5. Public objBMPData, objScreen, Screen
   
6. Public bitRowCount, bitColCount, allLine
   
7. Public bits()
   
8. 
   
9. Sub LoadingPicture()
   
10. '' 初始化显示屏幕
    
11. Call ReadBMPData
    
12. Call SetConfig
    
13. Call ClearScreen
    
14. Call RefreshScreen
    
15. End Sub
    
16. 
    
17. 
    
18. Sub ReadBMPData()
    
19.     Dim file
    
20.     Set dlgOpen = Application.FileDialog(3)
    
21.     If dlgOpen.Show = -1 Then
    
22.         file = dlgOpen.SelectedItems(1)
    
23.     Else
    
24.         End
    
25.     End If
    
26.    
    
27.     Set pic = CreateObject("WIA.ImageFile.1")
    
28.     pic.LoadFile file
    
29.     bitColCount = pic.Width
    
30.     bitRowCount = pic.Height
    
31.     bitDepth = pic.PixelDepth
    
32.     Set cl = pic.ARGBData
    
33.     ReDim bits(bitRowCount, bitColCount)
    
34.     Index = 1
    
35.     For i = 0 To bitRowCount - 1
    
36.         For j = 0 To bitColCount - 1
    
37.             bits(i, j) = cl.Item(Index)
    
38.             Index = Index + 1
    
39.         Next
    
40.     Next
    
41. End Sub
    
42. 
    
43. Sub SetConfig()
    
44.     Set Screen = Sheets("屏幕")
    
45.     Set objScreen = Screen.Range("A2").Resize(bitRowCount, bitColCount)
    
46.     Screen.Cells.ColumnWidth = scrWidth / bitColCount
    
47.     Screen.Range("2:50000").RowHeight = scrWidth * RC / bitColCount
    
48. End Sub
    
49. 
    
50. Sub RefreshScreen()
    
51.     Application.ScreenUpdating = False
    
52.     For i = 0 To bitRowCount - 1
    
53.         For j = 0 To bitColCount - 1
    
54.             objScreen.Cells(i + 1, j + 1).Interior.Color = bits(i, j)
    
55.         Next
    
56.     Next
    
57.     Application.ScreenUpdating = True
    
58. End Sub
    
59. 
    
60. Sub ClearScreen()
    
61.     Screen.Cells.Clear
    
62. End Sub
    

复制代码

lsekfe

支持下~