在Excel单元格里绘图-WIA库的绘图功能

jaxxcyh · 发表于 2024-8-11 02:31

Excel的单元格也能绘图？没错！
利用WIA库提供的Vector向量数组，获取图片所有像素的ARGB数据，取出其中的RGB信息，就可以在Excel单元格里兴风作浪了。

Sub ExcelDrawpic()
Cells.Interior.Color = xlNone
Dim myImg As Object '定义MIA.Image对象
Set myImg = CreateObject("WIA.ImageFile") '对象实例化
' 打开图片文件，可更换成自己的图片，建议分辨率不要超过300*300，否则处理速度无法忍受
myImg.LoadFile "h:\girl2.jpg"
Dim width As Long
Dim height As Long
width = myImg.width '图片宽度
height = myImg.height '图片高度
Dim myVct As Object '定义MIA.Vector向量对象
Set myVct = CreateObject("WIA.Vector") '创建Vector对象实例
Set myVct = myImg.ARGBData '获取图片全部像素数据，存入向量
Dim colorARGB As String
Dim redVal As Byte, greenVal As Byte, blueVal As Byte
' 关闭屏幕更新,为了提高绘图速度
Application.ScreenUpdating = False
Dim Row As Long, col As Long
For Row = 1 To height
For col = 1 To width
'从Vector向量里获取每个像素的ARGB值，A是指Alpha透明度，绘图时可不用，RGB数据才有用。
colorARGB = Hex(myVct((Row - 1) * width + col))
redVal = CInt("&H" & Mid(colorARGB, 3, 2)) '获取红色值
greenVal = CInt("&H" & Mid(colorARGB, 5, 2)) '绿色
blueVal = CInt("&H" & Mid(colorARGB, 7, 2)) '蓝色
' 确保行和列在 Excel 工作表的范围内绘图
If Row <= Rows.Count And col <= Columns.Count Then
Cells(Row, col).Interior.Color = RGB(redVal, greenVal, blueVal) '根据像素颜色设置对应的单元格颜色
End If
Next col
Next Row
' 恢复屏幕更新
Application.ScreenUpdating = True
' 清理对象
Set myImg = Nothing
Set myVct = Nothing
End Sub

复制代码

jaxxcyh · 发表于 2024-8-11 07:31

WIA库需要引用后才能保证程序正常运行。引用WIA库可在VBE窗口菜单里点击“工具”-“引用”，找到 "Microsoft Windows Image Acquisition Library V2.0" 勾选即可。

饮冰e士 · 发表于 2024-8-11 11:22

学习了，很有趣的用法。

jaxxcyh · 发表于 2024-8-12 00:17

再来个蒙版绘图

Sub test()
Cells.Interior.Color = xlNone '清除画布
Application.ScreenUpdating = False '关闭屏幕显示
Dim arrRGB(), brrRGB() '定义图片与蒙版的RGB数组
Dim fpath1 As String, fpath2 As String
fpath1 = ThisWorkbook.Path & "\girl2.jpg" '图片文件路径
fpath2 = ThisWorkbook.Path & "\huazi.png" '蒙版文件路径
'蒙版以白色作背景，非白色区为图片展示区，
'蒙版宽和高均不大于所展示图片的宽和高
arrRGB = getArrRGB(fpath1) '获取图片RGB数据
brrRGB = getArrRGB(fpath2) '获取蒙版的RGB数据
Dim width As Integer, height As Integer
width = UBound(brrRGB, 2) '获取蒙版的宽
height = UBound(brrRGB, 1) '获取蒙版的高
For i = 1 To UBound(brrRGB, 1)
For j = 1 To UBound(brrRGB, 2)
maskR = brrRGB(i, j)(0) '获取蒙版像素R值
maskG = brrRGB(i, j)(1) '获取蒙版像素G值
maskB = brrRGB(i, j)(2) '获取蒙版像素B值
picR = arrRGB(i, j)(0) '获取图片像素R值
picG = arrRGB(i, j)(1) '获取图片像素G值
picB = arrRGB(i, j)(2) '获取图片像素B值
'在蒙版蓝色区域(B值>=250)填充对应的图片颜色
'其它区域填充蒙版颜色
'当然也可以更改为别的什么规则
If maskR < 255 And maskG < 255 And maskB >= 250 Then
Cells(i, j).Interior.Color = RGB(picR, picG, picB)
Else
Cells(i, j).Interior.Color = RGB(maskR, maskG, maskB)
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Function getArrRGB(fpath As String) As Variant
'此函数输入参数为完整的文件路径，将返回一个二维数组，
'数组的行数为图片的高(单位：像素)
'数组的列数为图片的宽(单位：像素)
'数组的每一项代表一个像素点的RGB数据，
'是一个嵌套的小数组，包含3个元素，即R、G、B值。
Dim myImg As Object
Set myImg = CreateObject("WIA.ImageFile")
myImg.LoadFile fpath '载入图片文件
Dim width As Long
Dim height As Long
width = myImg.width
height = myImg.height
Dim myVct As Object
Set myVct = CreateObject("WIA.Vector")
Set myVct = myImg.ARGBData '载入图片像素ARGB数据
Dim colorARGB As String
Dim redVal As Long, greenVal As Long, blueVal As Long
Dim Row As Long, col As Long
Dim arrRGB()
ReDim arrRGB(1 To height, 1 To width)
For Row = 1 To height
For col = 1 To width
colorARGB = Hex(myVct((Row - 1) * width + col))
redVal = CInt("&H" & Mid(colorARGB, 3, 2))
greenVal = CInt("&H" & Mid(colorARGB, 5, 2))
blueVal = CInt("&H" & Mid(colorARGB, 7, 2))
' 确保行和列在 Excel 工作表的范围内
If Row <= Rows.Count And col <= Columns.Count Then
arrRGB(Row, col) = Array(redVal, greenVal, blueVal)
End If
Next col
Next Row
Set myImg = Nothing
Set myVct = Nothing
getArrRGB = arrRGB() '返回RGB数据的数组
End Function

复制代码

大灰狼1976 · 发表于 2024-8-12 12:48

我也来助个兴

Private Declare PtrSafe Function GetObject Lib "gdi32" Alias "GetObjectW" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare PtrSafe Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
End Type
Dim PicInfo As BITMAPINFOHEADER
Function getBytes(Pic As IPictureDisp) As Byte()
GetObject Pic, LenB(PicInfo), PicInfo
ReDim picbits(PicInfo.biWidth * PicInfo.biHeight * 4 - 1) As Byte
GetBitmapBits Pic, UBound(picbits), picbits(0)
getBytes = picbits
End Function
Sub Pixel2Cell()
Dim IPic As IPictureDisp, arrPic() As Byte, i&, j&, r&, Clr&
Set IPic = LoadPicture("C:\Intel\LOGO.bmp")
arrPic = getBytes(IPic)
Application.ScreenUpdating = False
Cells.Interior.Color = xlNone
For i = 1 To PicInfo.biHeight
For j = 1 To PicInfo.biWidth
Clr = RGB(arrPic(r + 2), arrPic(r + 1), arrPic(r))
Cells(i, j).Interior.Color = Clr
r = r + 3
Next j
Next i
Application.ScreenUpdating = True
Set IPic = Nothing
End Sub

复制代码

jaxxcyh · 发表于 2024-8-12 16:08

大灰狼1976 发表于 2024-8-12 12:48
我也来助个兴

这个牛，用gdi32库弄出来的好东西，正准备找点gdi这方面的资料看看呢。作者写点注释也好呀。感谢！

大灰狼1976 · 发表于 2024-8-12 16:24

jaxxcyh 发表于 2024-8-12 16:08
这个牛，用gdi32库弄出来的好东西，正准备找点gdi这方面的资料看看呢。作者写点注释也好呀。感谢！

抱歉啊，个人没有写注释的习惯，除非很复杂，有时间我会补一下注释重新发一下的。

jaxxcyh · 发表于 2024-8-12 16:40

图片反相显示，也就是胶卷底片的效果。逻辑很简单，就是每个像素RGB值取反。

Sub test()
Cells.Interior.Color = xlNone '清除画布
Application.ScreenUpdating = False '关闭屏幕显示
Dim fpath As String
fpath = ThisWorkbook.Path & "\girl2.jpg" '图片文件路径
Dim arrRGB() '定义图片RGB数组
arrRGB = getArrRGB(fpath) '获取图片RGB数据
Dim width As Integer, height As Integer
width = UBound(arrRGB, 2) '获取图片的宽
height = UBound(arrRGB, 1) '获取图片的高
Dim picR As Byte, picG As Byte, picB As Byte '定义RGB颜色变量
For i = 1 To UBound(arrRGB, 1)
For j = 1 To UBound(arrRGB, 2)
picR = arrRGB(i, j)(0) '获取图片像素R值
picG = arrRGB(i, j)(1) '获取图片像素G值
picB = arrRGB(i, j)(2) '获取图片像素B值
'反显(底片)效果，逻辑是每个像素点RGB值分别取反
Cells(i, j).Interior.Color = RGB(Not picR, Not picG, Not picB)
Next
Next
Application.ScreenUpdating = True
End Sub
Rem -----------图片转RGB值的函数---------------
Function getArrRGB(fpath As String) As Variant
'此函数输入参数为完整的文件路径，将返回一个二维数组，
'数组的行数为图片的高(单位：像素)
'数组的列数为图片的宽(单位：像素)
'数组的每一项代表一个像素点的RGB数据，
'是一个嵌套的小数组，包含3个元素，即R、G、B值。
Dim myImg As Object
Set myImg = CreateObject("WIA.ImageFile")
myImg.LoadFile fpath '载入图片文件
Dim width As Long
Dim height As Long
width = myImg.width
height = myImg.height
Dim myVct As Object
Set myVct = CreateObject("WIA.Vector")
Set myVct = myImg.ARGBData '载入图片像素ARGB数据
Dim colorARGB As String
Dim redVal As Byte, greenVal As Byte, blueVal As Byte
Dim Row As Long, col As Long
Dim arrRGB()
ReDim arrRGB(1 To height, 1 To width)
For Row = 1 To height
For col = 1 To width
colorARGB = Hex(myVct((Row - 1) * width + col))
redVal = CInt("&H" & Mid(colorARGB, 3, 2))
greenVal = CInt("&H" & Mid(colorARGB, 5, 2))
blueVal = CInt("&H" & Mid(colorARGB, 7, 2))
' 确保行和列在 Excel 工作表的范围内
If Row <= Rows.Count And col <= Columns.Count Then
arrRGB(Row, col) = Array(redVal, greenVal, blueVal)
End If
Next col
Next Row
Set myImg = Nothing
Set myVct = Nothing
getArrRGB = arrRGB() '返回RGB数据的数组
End Function

复制代码

大灰狼1976 · 发表于 2024-8-12 17:11

jaxxcyh 发表于 2024-8-12 16:08
这个牛，用gdi32库弄出来的好东西，正准备找点gdi这方面的资料看看呢。作者写点注释也好呀。感谢！

我另外一个帖子里面有一个比较完整的示例，工作表里有较详细的说明，但代码注释还是很少，供参考。

jaxxcyh · 发表于 2024-8-12 17:58

大灰狼1976 发表于 2024-8-12 17:11
我另外一个帖子里面有一个比较完整的示例，工作表里有较详细的说明，但代码注释还是很少，供参考。

谢谢.................

		自动登录	找回密码
密码			免费注册

[原创] 在Excel单元格里绘图-WIA库的绘图功能

评分

评分