ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > 我的酷贴 > Excel VBA > 利用VBA创建0-9的数字BMP图片

利用VBA创建0-9的数字BMP图片

作者：绿色风 分类： 时间：2022-08-18 浏览：106
楼主
amulee		 研究了一段时间的BMP文件，今天尝试创建数字BMP图片成功。
利用点阵法创建数字的图形，其中ArrNumber数组记录了各个数字的点阵情形。
Header数组记录了BMP文件的头信息，其中包括像素、文件大小等。
参考代码如下：
  1. Sub Create24Bit()
  2.     Dim FS As Integer
  3.     Dim Header(1 To 54) As Byte
  4.     Dim FName As String
  5.     Dim ArrColor(2) As Byte
  6.     Dim ArrNumber(9) As String
  7.     Dim i%, j%, k%
  8.     '定义数字数组
  9.     ArrNumber(0) = "111111111111111100001111111011110111111011110111111011110111111011110111111011110111111011110111111011110111111011110111111100001111111111111111"
  10.     ArrNumber(1) = "111111111111111110111111111000111111111110111111111110111111111110111111111110111111111110111111111110111111111110111111111000001111111111111111"
  11.     ArrNumber(2) = "111111111111111100001111111011110111111011110111111111110111111111101111111111011111111110111111111101111111111011110111111000000111111111111111"
  12.     ArrNumber(3) = "111111111111111100001111111011110111111011110111111111101111111110011111111111101111111111110111111011110111111011110111111100001111111111111111"
  13.     ArrNumber(4) = "111111111111111111011111111111011111111110011111111101011111111011011111111011011111111000000111111111011111111111011111111110000111111111111111"
  14.     ArrNumber(5) = "111111111111111000000111111011111111111011111111111010001111111001110111111111110111111111110111111011110111111011110111111100001111111111111111"
  15.     ArrNumber(6) = "1111111111111111100011111111011101111110111111111110111111111110100011111110011101111110111101111110111101111110111101111111000011111111111111111"
  16.     ArrNumber(7) = "111111111111111000000111111011101111111011101111111111011111111111011111111110111111111110111111111110111111111110111111111110111111111111111111"
  17.     ArrNumber(8) = "111111111111111100001111111011110111111011110111111011110111111100001111111101101111111011110111111011110111111011110111111100001111111111111111"
  18.     ArrNumber(9) = "111111111111111100011111111011101111111011110111111011110111111011100111111100010111111111110111111111110111111011101111111100011111111111111111"
  19.     '文件头
  20.     Header(1) = 66
  21.     Header(2) = 77
  22.     Header(3) = 230
  23.     Header(4) = 1
  24.     Header(11) = 54
  25.     Header(15) = 40
  26.     Header(19) = 12
  27.     Header(23) = 12
  28.     Header(27) = 1
  29.     Header(29) = 24
  30.     Header(39) = 18
  31.     Header(40) = 11
  32.     Header(43) = 18
  33.     Header(44) = 11
  34.     '开始生成文件
  35.     For k = 0 To 9
  36.         FName = ThisWorkbook.Path & "\" & k & ".bmp"
  37.         FS = FreeFile
  38.         Open FName For Binary Access Write As #FS
  39.         '写文件头
  40.         Put #FS, , Header
  41.         '写颜色
  42.         Pos = 55
  43.         For i = 11 To 0 Step -1 '行
  44.             For j = 1 To 12
  45.                 If Mid(ArrNumber(k), i * 12 + j, 1) = "1" Then
  46.                     ArrColor(0) = 0
  47.                     ArrColor(1) = 0
  48.                     ArrColor(2) = 0
  49.                 Else
  50.                     ArrColor(0) = 254
  51.                     ArrColor(1) = 254
  52.                     ArrColor(2) = 254
  53.                 End If
  54.                 Put #FS, Pos, ArrColor
  55.                 Pos = Pos + 3
  56.             Next j
  57.         Next i
  58.         Close #FS
  59.     Next k
  60. End Sub
附件：
BMP_Number_Creator 0-9.rar


图片效果如下，因社区不允许上传BMP，故转成了PNG。

 
 
 
 
 
 
 
 
 
 
2楼
用你的眼睛看
3楼
amulee		 补充一个生成1bit位深的BMP
  1. Sub Create1Bit()
  2.     Dim FS As Integer
  3.     Dim Header(1 To 54) As Byte
  4.     Dim FName As String
  5.     Dim ArrNumber(9) As String
  6.     Dim StrNumber As String
  7.     Dim Temp As Byte
  8.     Dim i%, j%, k%
  9.     '定义数字数组
  10.     ArrNumber(0) = "111111111111111100001111111011110111111011110111111011110111111011110111111011110111111011110111111011110111111011110111111100001111111111111111"
  11.     ArrNumber(1) = "111111111111111110111111111000111111111110111111111110111111111110111111111110111111111110111111111110111111111110111111111000001111111111111111"
  12.     ArrNumber(2) = "111111111111111100001111111011110111111011110111111111110111111111101111111111011111111110111111111101111111111011110111111000000111111111111111"
  13.     ArrNumber(3) = "111111111111111100001111111011110111111011110111111111101111111110011111111111101111111111110111111011110111111011110111111100001111111111111111"
  14.     ArrNumber(4) = "111111111111111111011111111111011111111110011111111101011111111011011111111011011111111000000111111111011111111111011111111110000111111111111111"
  15.     ArrNumber(5) = "111111111111111000000111111011111111111011111111111010001111111001110111111111110111111111110111111011110111111011110111111100001111111111111111"
  16.     ArrNumber(6) = "1111111111111111100011111111011101111110111111111110111111111110100011111110011101111110111101111110111101111110111101111111000011111111111111111"
  17.     ArrNumber(7) = "111111111111111000000111111011101111111011101111111111011111111111011111111110111111111110111111111110111111111110111111111110111111111111111111"
  18.     ArrNumber(8) = "111111111111111100001111111011110111111011110111111011110111111100001111111101101111111011110111111011110111111011110111111100001111111111111111"
  19.     ArrNumber(9) = "111111111111111100011111111011101111111011110111111011110111111011100111111100010111111111110111111111110111111011101111111100011111111111111111"
  20.     '文件头
  21.     Header(1) = 66
  22.     Header(2) = 77
  23.     Header(3) = 110
  24.     Header(4) = 0
  25.     Header(11) = 62
  26.     Header(15) = 40
  27.     Header(19) = 12
  28.     Header(23) = 12
  29.     Header(27) = 1
  30.     Header(29) = 1
  31.     Header(39) = 18
  32.     Header(40) = 11
  33.     Header(43) = 18
  34.     Header(44) = 11
  35.     '先对数组进行补0
  36.     For k = 0 To 9
  37.         StrNumber = ""
  38.         For i = 1 To 12
  39.             StrNumber = StrNumber & Mid(ArrNumber(k), i * 12 - 11, 12) & String(20, "0")
  40.         Next i
  41.         ArrNumber(k) = StrNumber
  42.     Next k
  43.     '开始生成文件
  44.     For k = 0 To 9
  45.         FName = ThisWorkbook.Path & "\" & k & ".bmp"
  46.         FS = FreeFile
  47.         Open FName For Binary Access Write As #FS
  48.         '写文件头
  49.         Put #FS, , Header
  50.         Pos = 55
  51.         '写调色板
  52.         Put #FS, Pos, 255
  53.         Put #FS, Pos + 1, 255
  54.         Put #FS, Pos + 2, 255
  55.         Put #FS, Pos + 3, 0
  56.         Put #FS, Pos + 4, 0
  57.         Put #FS, Pos + 5, 0
  58.         Put #FS, Pos + 6, 0
  59.         Put #FS, Pos + 7, 0
  60.         Pos = Pos + 8
  61.         '写颜色，8个一取
  62.         For i = 11 To 0 Step -1
  63.             For j = 0 To 3
  64.                 Temp = WorksheetFunction.Bin2Dec(Val(Mid(ArrNumber(k), i * 32 + j * 8 + 1, 8)))
  65.                 Put #FS, Pos, Temp
  66.                 Pos = Pos + 1
  67.             Next j
  68.         Next i
  69.         Close #FS
  70.     Next k
  71. End Sub

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap