|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
画的风荷携香,缩小版，用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 编辑 ] |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-11-11 16:10
发表于 2009-11-11 17:09
楼主
是啊 偶也是行人一个 对俺来说真的是
