有感于Excel手工作画之VBA自动绘画

/pig流云

       最近看到一篇文章讲述了一个日本老人（链接：日本69岁老者用Excel作画 一幅画完成要1到3天 _ 游民星空 GamerSky.com）使用Excel来作画，在佩服老人的毅力，同时也思考了如果直接用VBA来作画呢。

        从网络上检索了一些信息，有用的信息并不算太多，静心思考后决定直接从文件格式来下手，就是直接解析BMP文件格式。
        BMP文件格式，又称为Bitmap（位图）或是DIB(Device-Independent Device，设备无关位图)，是Windows系统中广泛使用的图像文件格式。文件中详细的记录了每个像素的RGB值，这样只要能获取到这个信息，那就万事大吉了。
        BMP文件的头部共54个字节，分成两部分即文件头信息和位图信息头。另外的两部分就是调色盘信息及数据部分。具体可以百度，此处不再赘述。下面就跟着我一步步来学习如何绘画。
        一、定义结构类型

1. '位图文件头包含有关于文件类型、文件大小、存放位置等信息
   
2. Type BITMAPFILEHEADER
   
3.     bfType As Integer
   
4.     bfSize As Long
   
5.     bfReserved1 As Integer
   
6.     bfReserved2 As Integer
   
7.     bfOffBits As Long
   
8. End Type
   
9. 
   
10. '调色盘信息
    
11. Type RGBQUAD
    
12.     rgbBlue As Byte
    
13.     rgbGreen As Byte
    
14.     rgbRed As Byte
    
15.     rgbReserved As Byte
    
16. End Type
    
17. 
    
18. '位图内容结构信息记录文件高、宽、位、调色盘大小等信息
    
19. Type BITMAPINFOHEADER '40 bytes
    
20.     biSize As Long
    
21.     biWidth As Long
    
22.     biHeight As Long
    
23.     biPlanes As Integer
    
24.     biBitCount As Integer
    
25.     biCompression As Long
    
26.     biSizeImage As Long
    
27.     biXPelsPerMeter As Long
    
28.     biYPelsPerMeter As Long
    
29.     biClrUsed As Long
    
30.     biClrImportant As Long
    
31. End Type
    
32. 
    
33. '像素点分量
    
34. Type RGBTRIPLE
    
35.     rgbtBlue As Byte
    
36.     rgbtGreen As Byte
    
37.     rgbtRed As Byte
    
38. End Type
    

复制代码

       二、读取位图的信息及数据的函数

1. 
   
2. Sub readBmp()
   
3.     On Error GoTo errClose
   
4.     Dim filePath As String
   
5.     Dim bmpHeaer As BITMAPFILEHEADER
   
6.     Dim bmpBi As BITMAPINFOHEADER
   
7.     Dim rgb As RGBTRIPLE, bit8 As Byte, bit16 As Integer, bit16RGB As Integer
   
8.     Dim i As Long, j As Long
   
9.     Dim OK As Boolean
   
10.     filePath = [E21]
    
11.     OK = False
    
12.     'Open filePath For Binary Access Write As #1
    
13.     Open filePath For Binary As #1
    
14.     'Debug.Print (Seek(1) - 1)
    
15.     Seek 1, 1 '设置读入点为起始
    
16.     '读取头文件
    
17.     Get #1, , bmpHeaer    '读取BMP文件头
    
18. 
    
19.     [b2] = "'" & Hex(bmpHeaer.bfType)     'bfType:
    
20.     [b3] = "'" & Hex(bmpHeaer.bfSize)       'bfSize:
    
21.     [b4] = "'" & Hex(bmpHeaer.bfReserved1)       'bfReserved1:
    
22.     [b5] = "'" & Hex(bmpHeaer.bfReserved2)       'bfReserved2:
    
23.     [b6] = "'" & Hex(bmpHeaer.bfOffBits)      'bfOffBits:
    
24.    
    
25.     [c2] = "'" & (bmpHeaer.bfType)     'bfType:
    
26.     [c3] = "'" & (bmpHeaer.bfSize)       'bfSize:
    
27.     [c4] = "'" & (bmpHeaer.bfReserved1)       'bfReserved1:
    
28.     [c5] = "'" & (bmpHeaer.bfReserved2)       'bfReserved2:
    
29.     [c6] = "'" & (bmpHeaer.bfOffBits)      'bfOffBits:
    
30.    
    
31.     '读取位图信息
    
32.     Get #1, , bmpBi
    
33.    
    
34.     [B8] = Hex(bmpBi.biSize)
    
35.     [B9] = Hex(bmpBi.biWidth)
    
36.     [B10] = Hex(bmpBi.biHeight)
    
37.     [B11] = Hex(bmpBi.biPlanes)
    
38.     [B12] = Hex(bmpBi.biBitCount)
    
39.     [B13] = Hex(bmpBi.biCompression)
    
40.     [B14] = Hex(bmpBi.biSizeImage)
    
41.     [B15] = Hex(bmpBi.biXPelsPerMeter)
    
42.     [B16] = Hex(bmpBi.biYPelsPerMeter)
    
43.     [B17] = Hex(bmpBi.biClrUsed)
    
44.     [B18] = Hex(bmpBi.biClrImportant)
    
45.    
    
46.    
    
47.     [C8] = (bmpBi.biSize)
    
48.     [C9] = (bmpBi.biWidth)
    
49.     [C10] = (bmpBi.biHeight)
    
50.     [C11] = (bmpBi.biPlanes)
    
51.     [C12] = (bmpBi.biBitCount)
    
52.     [C13] = (bmpBi.biCompression)
    
53.     [C14] = (bmpBi.biSizeImage)
    
54.     [C15] = (bmpBi.biXPelsPerMeter)
    
55.     [C16] = (bmpBi.biYPelsPerMeter)
    
56.     [C17] = (bmpBi.biClrUsed)
    
57.     [C18] = (bmpBi.biClrImportant)
    
58.    
    
59.    
    
60.     '清除历史数据
    
61.     Sheet2.Cells.Clear
    
62.     Application.ScreenUpdating = False
    
63.     Select Case bmpBi.biBitCount
    
64.         Case 8 '处理8位位图
    
65.             Dim RGBQUADS() As RGBQUAD
    
66.             ReDim RGBQUADS(bmpBi.biClrUsed)
    
67.             For i = LBound(RGBQUADS) To UBound(RGBQUADS)
    
68.                 Get #1, , RGBQUADS(i)  '读取所有调色盘预定义值
    
69.             Next
    
70.             Seek 1, bmpHeaer.bfOffBits + 1 '跳转到数据区
    
71.             For i = 1 To bmpBi.biHeight
    
72.                 For j = 1 To bmpBi.biWidth
    
73.                     Get #1, , bit8  '读取RGB数据，8位用一个字节表示，对应0-255值，RGB值由调色盘预定义
    
74.                     Sheet2.Cells(bmpBi.biHeight - i + 1, j).Interior.Color = VBA.rgb(RGBQUADS(bit8).rgbRed, RGBQUADS(bit8).rgbGreen, RGBQUADS(bit8).rgbBlue)
    
75.                 Next
    
76.                 DoEvents
    
77.                 Application.StatusBar = "进度" & Int(i / bmpBi.biHeight * 100) & "%"
    
78.             Next
    
79.         Case 16 '处理16位位图
    
80.             Seek 1, bmpHeaer.bfOffBits + 1
    
81.             For i = 1 To bmpBi.biHeight
    
82.                 For j = 1 To bmpBi.biWidth
    
83.                     Get #1, , bit16 '读取RGB信息，16位位图RGB信息由2个字节16位构成
    
84.                     '低5位表示Blue分量；中5为表示Green分量；高5位表示Red分量,最高位无用
    
85.                     Sheet2.Cells(bmpBi.biHeight - i + 1, j).Interior.Color = Conv16BitRGB(bit16)
    
86.                 Next
    
87.                 DoEvents
    
88.                 Application.StatusBar = "进度" & Int(i / bmpBi.biHeight * 100) & "%"
    
89.             Next
    
90.         Case 24 '处理24位位图
    
91.             Seek 1, bmpHeaer.bfOffBits + 1
    
92.             For i = 1 To bmpBi.biHeight
    
93.                 For j = 1 To bmpBi.biWidth
    
94.                     Get #1, , rgb '24位位图处理是最简单的，因为是真彩图，所以直接就是3个字节记录了RGB信息
    
95.                     Sheet2.Cells(bmpBi.biHeight - i + 1, j).Interior.Color = VBA.rgb(rgb.rgbtRed, rgb.rgbtGreen, rgb.rgbtBlue)
    
96.                 Next
    
97.                 DoEvents
    
98.                 Application.StatusBar = "进度" & Int(i / bmpBi.biHeight * 100) & "%"
    
99.             Next
    
100.         Case Else
     
101.             Err.Raise 4000, "", "不支持" & bmpBi.biBitCount & "位的图片格式！"
     
102.     End Select
     
103.     Application.StatusBar = "就绪"
     
104.     OK = True
     
105. errClose:
     
106.     If Not OK Then
     
107.         MsgBox Err.Description
     
108.     Else
     
109.         MsgBox "完成！"
     
110.         Sheet2.Activate
     
111.         [a1].Select
     
112.     End If
     
113.     Application.ScreenUpdating = True
     
114.     Close #1
     
115. End Sub
     
116. 
     

复制代码

       三、8位位图的转换函数，因为8位位图处理起来比较麻烦，需要做转换，所以单独写了一个函数来处理

1. 
   
2. Function Conv16BitRGB(ByVal num As Long) As Long
   
3.     Dim bit16 As Long
   
4.     Dim r As Byte, g As Byte, b As Byte, r1 As Byte, g1 As Byte, b1 As Byte
   
5.     '低5位表示Blue分量；中5为表示Green分量；高5位表示Red分量
   
6.     '16位数据的组成例如以下
   
7.     '第一个字节: g5g4g3b7b6b5b4b3
   
8.     '第二个字节：0r7r6r5r4r3g7g6
   
9.     '当中第二个字节的左边第一位为填充位?我在实验中用0填充?
   
10.     '该16位bmp图像无调色板数据
    
11.     '该16位bmp图像在显示时。图片浏览软件（如windows绘图）会将rgb555自己主动转换为rgb888显示。详细的方法例如以下
    
12.     'b7b6b5b4b3->b7b6b5b4b3b7b6b5
    
13.     'r7r6r5r4r3->r7r6r5r4r7r6r5
    
14.     'g7g6g5g4g3->r7r6r5r4g7g6g5
    
15.     bit16 = num
    
16.     Call BitPlus.SHL(bit16, 17)
    
17.     Call BitPlus.SHR(bit16, 27)
    
18.     r = bit16
    
19.     r1 = bit16
    
20.     Call SHR(r1, 2)
    
21.     Call SHL(r, 3)
    
22.    
    
23.     r = r + r1
    
24.    
    
25.     bit16 = num
    
26.     Call BitPlus.SHL(bit16, 22)
    
27.     Call BitPlus.SHR(bit16, 27)
    
28.     g = bit16
    
29.     g1 = bit16
    
30.     Call SHR(g1, 2)
    
31.     Call SHL(g, 3)
    
32.     g = g + g1
    
33.    
    
34.     bit16 = num
    
35.     Call BitPlus.SHL(bit16, 27)
    
36.     Call BitPlus.SHR(bit16, 27)
    
37.     b = bit16
    
38.     b1 = bit16
    
39.     Call SHR(b1, 2)
    
40.     Call SHL(b, 3)
    
41.     b = b + b1
    
42.     'Debug.Print Bin(r), Bin(g), Bin(b)
    
43.     Conv16BitRGB = VBA.rgb(r, g, b)
    
44. End Function
    
45. 
    
46. 
    

复制代码

        至此代码部分就算完成了，下面展示一下效果图





完整的附件在此： vba提取bmp像素点图像信息并绘画.zip (922.86 KB, 下载次数: 98)

2022-6-2 08:34 上传

点击文件名下载附件

蓝桥玄霜

未见效果图和附件？

/pig流云

蓝桥玄霜 发表于 2022-6-1 18:10
未见效果图和附件？

明明传了啊！明天补上。

yzxfelix

大师啊，真正的大神在这里啊

lilyhcn1

这个不是绘图，这是提取像素点，没意思。

发挥表格的优势，画出失量图才有意义啊。
或者把表格作为数据输入器，调用别的程序来画图，那也好玩啊。

qlmgu

请问楼主，测试提示路径不对，反复拷贝路径了

/pig流云

lilyhcn1 发表于 2022-6-6 08:03
这个不是绘图，这是提取像素点，没意思。

发挥表格的优势，画出失量图才有意义啊。

你有认真看我写这个文章的意图吗，我也只是练练手而已。目的达到也练了手这就行了。

/pig流云

qlmgu 发表于 2022-6-6 12:39
请问楼主，测试提示路径不对，反复拷贝路径了

代码没有问题，反复测试过。

/pig流云

yzxfelix 发表于 2022-6-5 23:18
大师啊，真正的大神在这里啊

谢谢肯定，大神就不敢当了。

lilyhcn1

/pig流云 发表于 2022-6-6 14:43
你有认真看我写这个文章的意图吗，我也只是练练手而已。目的达到也练了手这就行了。

不打扰你研究了，愿你早日能达到老人的绘图水平。