Excel单元格绘图工具

2012-04-09

作者: chrisfang | 分类: ExcelVBA程序 | 阅读: 1,319,675 次浏览 | Tags: Excel、GetPixel、VBA、画图、程序

声明: 本站文章均属原创，转载时请标明出处

以前发在EHblog的老博文，现在关闭了，准备陆陆续续搬迁一点过来。时间久了，有些文章也不一定保值了。

————————————————以下原文发表于2010-3-17——————————————

前日在网上闲逛时凑巧看到一个名为ExcelArt的软件介绍（http://www.cnbeta.com/articles/105787.htm），此软件可以将图片转换为Excel单元格图像，在Excel单元格中画图变得不再那么复杂，可以轻松按键搞定。去下载了试用了一下，非注册版有诸多限制，而且转换还以失败告终。去他们的主页看了一下，专业版竟然售价10欧元，企业版50欧元！

看来还是自己动手做一个比较方便！
用VBA制作的思路其实很简单，应该已经有先人实践过，只是没有见过成熟产品，所以发上来和大家一起分享一下。
软件界面：

生成效果如下：

附件如下：请使用2007以上版本打开。

微盘下载：http://vdisk.weibo.com/s/3Wdeh

本地下载：单元格画图V2.1(96DPI) (2771)

上述附件中的程序假定分辨率为96DPI，如需适用于其他的分辨率条件下，可以使用下面的附件程序，其中的坐标转换部分代码参考Winland大侠的代码。

微盘下载：http://vdisk.weibo.com/s/3Wdla

本地下载：单元格画图V2.0 (2312)

主要部分代码如下：

'以下代码位于用户窗体UesrForm1之中：
'撰写:chrisfang
'网址:http://Club.ExcelHome.net
'日期:2010-3-16 17:29:39
Private Declare Function GetPixel Lib "gdi32" ( _
                                  ByVal hDC As Long, _
                                  ByVal x As Long, _
                                  ByVal y As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
                                    ByVal lpClassName As String, _
                                    ByVal lpWindowName As String) As Long
Private Declare Function GetWindowDC Lib "user32" ( _
                                     ByVal hwnd As Long) As Long
Public maxx, maxy
 
'--------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
Dim hwnd, hDC As Long
If maxx = 0 Then
MsgBox "请先选择尺寸规格！"
Exit Sub
End If
hwnd = FindWindow(vbNullString, Me.Caption)
hDC = GetWindowDC(hwnd)
ThisWorkbook.Sheets(1).Range("A1:OJ300").Interior.Color = -1
winx = (Me.Width - Me.InsideWidth) / 2
winy = Me.Height - Me.InsideHeight - winx
mx = (winx + Me.Image1.Left) * 4 / 3
my = (winy + Me.Image1.Top) * 4 / 3
'Application.ScreenUpdating = False
For x = 1 To maxx
For y = 1 To maxy
iColor = GetPixel(hDC, mx + x * 4 / 3, my + y * 4 / 3)
ThisWorkbook.Sheets(1).Cells(y, x).Interior.Color = iColor
Next y
Next x
'Application.ScreenUpdating = True
MsgBox "绘制完成！"
End Sub
'--------------------------------------------------------------------------------
Private Sub CommandButton2_Click()
filestoOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Image Files (*.jpg;*.jpeg; *.bmp), *.jpg;*.jpeg; *.bmp", _
MultiSelect:=False, Title:="选择图片文件")
If TypeName(filestoOpen) = "Boolean" Then
MsgBox "没有选择文件"
GoTo ExitHandler
Else
Me.Image1.Picture = LoadPicture(filestoOpen)
End If
ExitHandler:
End Sub
'--------------------------------------------------------------------------------
Private Sub OptionButton1_Click()
If Me.OptionButton1.Value = True Then
maxx = 200
maxy = 150
Call disparea(maxx, maxy)
End If
End Sub
'--------------------------------------------------------------------------------
Private Sub OptionButton2_Click()
If Me.OptionButton2.Value = True Then
maxx = 300
maxy = 225
Call disparea(maxx, maxy)
End If
End Sub
'--------------------------------------------------------------------------------
Private Sub OptionButton3_Click()
If Me.OptionButton3.Value = True Then
maxx = 400
maxy = 300
Call disparea(maxx, maxy)
End If
End Sub
'--------------------------------------------------------------------------------
Private Sub disparea(ByVal maxx As Integer , ByVal maxy As Integer )
Application.ScreenUpdating = False
Range (Cells(1, 1), Cells(1, maxx)).ColumnWidth = 0.54
Range (Cells(1, 1), Cells(maxy, 1)).RowHeight = 5
Range (Cells(1, 1), Cells(1, maxx)).EntireColumn.Hidden = False
Range (Cells(1, 1), Cells(maxy, 1)).EntireRow.Hidden = False
Range (Cells(1, maxx + 1), Cells(1, 16384)).EntireColumn.Hidden = True
Range (Cells(maxy + 1, 1), Cells(1048576, 1)).EntireRow.Hidden = True
Me.Image1.Left = Me.Image1.Left + (Me.Image1.Width - maxx) / 2
Me.Image1.Top = Me.Image1.Top + (Me.Image1.Height - maxy) / 2
Me.Image1.Width = maxx
Me.Image1.Height = maxy
Application.ScreenUpdating = True
End Sub

————————————————以下更新于2012年5月29日——————————————

微博上最近有一个有关招聘的段子很火爆，说是办公室文员招聘，面试的题目竟然是用Excel画一幅超级玛丽！

呵呵，其实这是老段子啦，不过这次的情况貌似特别欢乐，有很多网友热烈响应，纷纷在Excel上亲手效仿练习起来。

这些闲的可爱的宅男宅女们啊！我知道，有这样现成一个程序可以自动实现单元格绘图对他们来说其实毫无意义，乐趣其实就在于玩弄格子的过程中，甚至可以洗却平日里被格子玩弄的种种不快。

不过这也不影响我在上面程序基础上修改了一个更简单的版本，不为别的，独乐不如众乐，就让这欢乐来的更蛋疼些吧。

程序原理其实很简单，甚至不值得一提：就是在图片上按XY坐标依次提取像素点的色彩值（根据精细程度，可能会忽略一部分像素点），填充到相应位置的Excel单元格中即可。

由于Excel 2003版本中行列数比较少（只有256列），可用像素点就比较少，而且可用颜色也不丰富，因此这个单元格绘图的功能一般还是在Excel 2007以上的版本中来实现的。如果对清晰度要求不高，就好比像“超级玛丽”这种早期8位机上的马赛克图形画面，就只要很少的格子就可以实现了。这种马赛克级别的像素图绘制程序，也可以拿来作为十字绣的图稿定制。