ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 19893|回复: 27

[手绘组] 用excel作画,其实很简单

[复制链接]

TA的精华主题

TA的得分主题

发表于 2009-11-11 16:10 | 显示全部楼层 |阅读模式
画的风荷携香,缩小版,用2010做的,至少2007才能打开

可以画个女朋友的肖像,告诉她自己一点一点弄的,感动ing……

用VBA可以实现,不过VBA不太懂

网上找到下面这段代码,不过我用这代码没实现,老出错,各位懂VBA的可以参考参考:
vbgood论坛转贴如下:

上次看到网上有文章介绍高人用Excel手工绘制魂斗罗人物,突然想用VB来干这活可能挺恰当的.所以做了这个好玩的程序,没什么技术性,纯粹好玩.程序还有些问题,一是图片一遮盖就会出错,二是颜色导入到Excel后好象变成了不256色.所以欢迎大家修改.
新建个窗体,把下面的代码复制过去就可以了.
Option Explicit
'提取像素点颜色
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
'获得操作对象句柄
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
'
'定义Excel对象
  Dim xlApp As Object, xlBook As Object, xlSheet As Object, xlSheetA As Object
  
'定义固有控件,一个标签和两个按钮控件,两个图片框
Dim WithEvents lblProgress     As VB.Label           '进度显示
Dim WithEvents cmdLoadPic      As VB.CommandButton   '加载图片
Dim WithEvents cmdPictoExcel   As VB.CommandButton   '绘至Excel
Dim WithEvents picBase         As VB.PictureBox      '底框
Dim WithEvents picMain         As VB.PictureBox      '图片
   
'附加控件,用VBControlExtender定义,一个CommonDialg控件
Dim WithEvents ctlDlgOpen      As VBControlExtender

Dim lngLeft                    As Long            '图片移动
Dim lngTop                     As Long            '图片移动
Dim lngCor                     As Long            '颜色值
Dim myhdc                      As Long            '句柄
Dim i                          As Integer
Dim j                          As Integer
Dim R                          As Integer         '颜色分量
Dim G                          As Integer
Dim B                          As Integer

Private Sub cmdLoadPic_Click()
'加载图片
  Dim strPicFile As String
  
  ctlDlgOpen.object.ShowOpen
  strPicFile = ctlDlgOpen.object.FileName
  If strPicFile = "" Then
     Exit Sub
  Else
     picMain.Picture = LoadPicture(strPicFile)
  End If
End Sub

Private Sub cmdPictoExcel_Click()
   '绘制图片
   Dim intL    As Integer       '图片取景区域
   Dim intT    As Integer
   Dim intW    As Integer
   Dim intH    As Integer
   
   On Error Resume Next
   '取图
   If picMain.Left < 0 Then
      intL = 0 - picMain.Left
      If picMain.Width + picMain.Left >= picBase.Width Then
         intW = picBase.Width
      Else
         intW = picMain.Width + picMain.Left
      End If
   Else
      intL = 0
      If picMain.Width + picMain.Left <= picBase.Width Then
         intW = picBase.Width
      Else
         intW = picBase.Width - picMain.Left
      End If
   End If
   
   If picMain.Top < 0 Then
      intT = 0 - picMain.Top
      If picMain.Height + picMain.Top >= picBase.Height Then
         intH = picBase.Height
      Else
         intH = picMain.Height + picMain.Top
      End If
   Else
      intT = 0
      If picMain.Height + picMain.Top <= picBase.Height Then
         intH = picBase.Height
      Else
         intH = picBase.Height - picMain.Top
      End If
   End If
    '换算成像素
   intL = intL \ 15
   intT = intT \ 15
   intW = intW \ 15
   intH = intH \ 15
   
  '获取对象
  myhdc = GetDC(picMain.hwnd)
  
  '累死了,终于正式开工了,呵呵
  Set xlApp = CreateObject("Excel.Application")
  Set xlBook = xlApp.workbooks.Add
       Set xlSheet = xlBook.Worksheets("Sheet1")
       With xlSheet
       '调整行列高宽
       For i = 1 To intH
          .Rows(i).RowHeight = 5
       Next
       For j = 1 To intW
          .Columns(j).ColumnWidth = 0.54
       Next
       For i = 1 To intH
       DoEvents
       lblProgress.Caption = "已完成" & i & "/" & intH
           
                For j = 1 To intW
                   lngCor = GetPixel(myhdc, intL + j - 1, intT + i - 1)
                   R = lngCor Mod 256
                   G = ((lngCor And &HFF00&) \ 256&) Mod 256&
                   B = (lngCor And &HFF0000) \ 65536
                   .Cells(i, j).Interior.Color = RGB(R, G, B)
                   '####### 可用此句代替 ########
                   '.Cells(i , j ).Interior.Color= GetPixel(myhdc, j, i)
                   '#############################
                Next
      Next
      End With
  '大功告成,香槟呢,拿香槟来呀
  xlApp.Visible = True
  
End Sub

Private Sub Form_Load()

  Me.Caption = "用Excel绘图"
  Me.Move (Screen.Width - 5100) \ 2, (Screen.Height - 6000) \ 2, 5100, 6000
  
  '将对话框的许可证信息加入到许可证集合中
  Licenses.Add "MSComdlg.CommonDialog"
  '动态加入一个对话框控件
  Set ctlDlgOpen = Controls.Add("MSComdlg.CommonDialog", "myctl", Form1)
  '设置文件过滤
  ctlDlgOpen.object.Filter = "*.bmp|*.bmp|*.jpg|*.jpg"
  
  '加载显示进度标签
  Set lblProgress = Controls.Add("VB.label", "ctlLabel", Form1)
  lblProgress.Move 360, 4980, 1935, 255
  lblProgress.Caption = "等待绘制"
  lblProgress.Visible = True
  
  '加载图片按钮
  Set cmdLoadPic = Controls.Add("VB.CommandButton", "ctlCommand1", Form1)
  cmdLoadPic.Move 2400, 4920, 1095, 375
  cmdLoadPic.Caption = "加载图片"
  cmdLoadPic.Visible = True
   
  '加载绘至Excel按钮
  Set cmdPictoExcel = Controls.Add("VB.CommandButton", "ctlCommand2", Form1)
  cmdPictoExcel.Move 3720, 4920, 1095, 375
  cmdPictoExcel.Caption = "用Excel绘图"
  cmdPictoExcel.Visible = True
  
'加载一个图片框做底框,限制绘制的区域
  Set picBase = Controls.Add("VB.PictureBox", "ctlPicture1", Form1)
  picBase.Move 240, 240, 4500, 4500
  picBase.Visible = True
  
  '加载图片显示框,底框作为容器
  Set picMain = Controls.Add("VB.PictureBox", "ctlPicture2", picBase)
  picMain.Move 0, 0, 4500, 4500
  picMain.Appearance = 0
  picMain.BorderStyle = 0
  picMain.AutoRedraw = True
  picMain.AutoSize = True
  picMain.Visible = True
  picMain.MousePointer = 15
  
  lngLeft = -1
End Sub

Private Sub picMain_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
   '保存位置
   lngLeft = x: lngTop = y
End Sub

Private Sub picMain_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
' 移动图片
  If lngLeft <> -1 Then
     picMain.Move picMain.Left + (x - lngLeft), picMain.Top + (y - lngTop)
  End If
End Sub

Private Sub picMain_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  '保证图片有可见区域
   lngLeft = -1
   If picMain.Left < (225 - picMain.Width) Then
      picMain.Left = 225 - picMain.Width
   End If
   If (picBase.Width - picMain.Left) < 225 Then
      picMain.Left = picBase.Width - 200
   End If
   If picMain.Top < (225 - picMain.Height) Then
      picMain.Top = 225 - picMain.Height
   End If
   If (picBase.Height - picMain.Top) < 225 Then
      picMain.Top = picBase.Height - 200
   End If
End Sub

[ 本帖最后由 shooterf 于 2009-11-11 16:13 编辑 ]

Book1.rar

132.78 KB, 下载次数: 1768

TA的精华主题

TA的得分主题

发表于 2009-11-11 16:23 | 显示全部楼层
这个应该叫“用Excel导入图片其实很简单”,^_^

TA的精华主题

TA的得分主题

发表于 2009-11-11 17:09 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
使用程序导入图片到文本或Excel的应用很早就有了,呵呵,所以此次比赛才强调必须“手绘”,而且要有绘制过程展示!

TA的精华主题

TA的得分主题

 楼主| 发表于 2009-11-11 17:26 | 显示全部楼层
原帖由 alzeng 于 2009-11-11 16:23 发表
这个应该叫“用Excel导入图片其实很简单”,^_^

呵呵,来丢人了
您那个工笔画真的是,绝了

听总版主这么一说,真的受教了

[ 本帖最后由 shooterf 于 2009-11-11 17:30 编辑 ]

TA的精华主题

TA的得分主题

发表于 2009-11-12 09:10 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

学习中

对我来说还是非常的难!

TA的精华主题

TA的得分主题

发表于 2009-11-14 21:27 | 显示全部楼层
是啊 偶也是行人一个 对俺来说真的是
太难了

TA的精华主题

TA的得分主题

发表于 2009-11-15 16:15 | 显示全部楼层
楼主这个文件打开有点慢,不过学习了一个方法,谢谢了。

TA的精华主题

TA的得分主题

发表于 2009-11-23 21:58 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
头晕,高手的东东

TA的精华主题

TA的得分主题

发表于 2009-11-24 14:31 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2009-12-28 11:43 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-21 19:35 , Processed in 0.051225 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表