楼主
chrisfang |
今天在网上闲逛时凑巧看到一个名为ExcelArt的软件介绍（
用VBA制作的思路其实很简单，应该已经有先人实践过，只是没有见过成熟产品，所以发上来和大家一起分享一下。[后来在网上搜索了一下，guanyp和andysky都有过类似作品：
http://club.excelhome.net/thread-296742-1-973.html]
软件界面：
生成效果：
附件如下：
 单元格画图V1.1(96DPI for ET).rar
工程密码：exceltip
上述附件中的程序假定分辨率为96DPI，如需适用于其他的分辨率条件下，可以使用下面的附件程序，其中的坐标转换部分代码参考Winland大侠的代码。
单元格画图V1.0 for ET.rar
第一个附件中的代码如下：
- '以下代码位于用户窗体UesrForm1中
- 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 Label1_Click()
- ActiveWorkbook.FollowHyperlink Address:="http://www.exceltip.net/?fromuid=38", NewWindow:=True
- 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
|
