共享一个excel下的图片转像素画的代码

welkin007

不错！如果能将白色替换成无色，然后就可以用黑白画制作像素图游戏了。

02761752696

谢谢     分享

lukeluckc

分享另外一种方法，仅支持BMP位图

1. Sub BMP2excelPixel()
   
2.     Dim Filename As Variant
   
3.     MsgBox "仅支持BMP格式图片,因Excel格式限制，建议像素控制在400*400以内。"
   
4.     Filename = Application.GetOpenFilename("BMP图片,*.bmp", , "请选择BMP图片", , 0)
   
5.    
   
6.     If Filename = False Then
   
7.         Exit Sub
   
8.     End If
   
9. 
   
10.     Dim bmpFilePath As String
    
11.     bmpFilePath = CStr(Filename)
    
12.     Dim arrByte() As Byte
    
13.     Dim PixelCol As LongPtr, PixelRow As LongPtr
    
14.     Dim CellCol As LongPtr, CellRow As LongPtr
    
15.     Dim i As Long, j As Long
    
16.     Dim lngPos As LongPtr, Zeroize As LongPtr
    
17.    
    
18.     '获取BMP图片信息并放入二进制数组，BMP文件格式存放像素的方法：一个像素由3个字节来完成：从下到上，从左到右，BGRBGR的顺序
    
19.     Open bmpFilePath For Binary As #1
    
20.         ReDim arrByte(LOF(1) - 1)
    
21.         'ReDim arrByte(2 ^ 31 - 1)
    
22.         Get #1, , arrByte
    
23.     Close #1
    
24.    
    
25.     '获取图片的像素高和宽。BMP文件格式第18-21位为256进制像素宽度，22-25位为256进制像素高度，因Windows系统一个扫描行所占的字节数必须是4的倍数，宽度不是4的倍数时需补零
    
26.     For i = 0 To 3
    
27.         PixelCol = PixelCol + arrByte(i + 18) * 256 ^ i
    
28.     Next
    
29.     For i = 0 To 3
    
30.         PixelRow = PixelRow + arrByte(i + 22) * 256 ^ i
    
31.     Next
    
32.     If PixelCol Mod 4 <> 0 Then Zeroize = PixelCol Mod 4
    
33.    
    
34.     Cells.Clear
    
35.     Range(Cells(1, 1), Cells(PixelRow, PixelCol)).Select
    
36.     Selection.RowHeight = 3
    
37.     Selection.ColumnWidth = 0.31
    
38.    
    
39.     'BMP文件格式存放像素的方法：一个像素由3个字节来完成：从下到上，从左到右，BGRBGR的顺序
    
40.     For i = PixelRow To 1 Step -1
    
41.         CellRow = CellRow + 1
    
42.         CellCol = 0
    
43.         For j = 1 To PixelCol * 3 Step 3
    
44.             CellCol = CellCol + 1
    
45.             lngPos = 53 + j + (i - 1) * (PixelCol * 3 + Zeroize)
    
46.             Cells(CellRow, CellCol).Interior.Color = RGB(arrByte(lngPos + 2), arrByte(lngPos + 1), arrByte(lngPos))
    
47.         Next
    
48.     Next
    
49.     ActiveWindow.Zoom = True
    
50. End Sub

复制代码

yangyangjz

64位系统下不可用

Marvin123456

lukeluckc 发表于 2019-1-24 16:51
分享另外一种方法，仅支持BMP位图

厉害。。。。。。。。。。。。