[VBA Excel] Drawing on Cells in MS-Excel 2007 Application

You must know that a bitmap image consists of a collection of dots or pixels. From that concept then I think of how to create images on a worksheet in MS-Excel application from a group of cells.

Of course I had to paint each cell with a specific color to form an image that I want. I can not imagine how I had to paint so many cells. By using macros in MS-Excel application, I tried to make the job easier.

Previously I've tried making it using ms-excel application in 2003, but the depth of color in office in 2003 was low, perhaps 16 colors or 256 colors, but with the presence of ms-excel 2007, the problems with these colors can be improved.

The picture above is an example of colored cells in ms-excel workbook

How The Tools Work?

A picture is placed on the image control and the size can be adjusted with combobox control, such as the size of 32x32, 64x64, 128x128, 256x256 or whatever you want. This image size settings will affect the output image, the greater the size the higher the resolution of the resulting output, consequently was the process of cell staining became longer.

The samples color of image pixel taken in accordance with the coordinates, then the color information and the coordinates are applied to an appropriate cell coordinates (range) and a specific color.

To give a good display output, worksheet properties need to be changed, such as gridlines to be removed, the cell shape made as square and minimized. This is necessary because these cells will act as color pixels making up the picture.

Controls and Properties

Userform

Properties: Back color = white, adjust the size of the need

Image

Properties: Back color = white, dimensions: width = 256 height = 256 (can be adjusted with the control combobox), 3-pictureSizeMode = frmPictureSizeModeZoom, pictureAlignment = 0-FRM pictureAlignmentTopLeft

CommandButton

Command key button is 3: Browse Picture, Start, Close and 1 additional (About) for application information.

Combobox

Filled with value = 32,64,128,256 default value is set 128

A Command Button on the worksheet

Allows you to call the main application (Userform)

Project Components

1. Userform

2. Module

THE CODES

• CommandButton pada worksheet

Private Sub CommandButton1_Click()
Sheets(2).Select
UserForm1.Show
End Sub

• UserForm

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'!!     xCELL Art                                   !!
'!!     Dibuat oleh SUSANTO aka Xantov              !!
'!!     xantov@gmail.com                            !!
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Private Sub Pilih_Gambar_Click()
Dim objDialog, boolResult

Set objDialog = CreateObject("UserAccounts.CommonDialog")

objDialog.Filter = "Files Gambar(*.jpg;*.jpeg;*.bmp;*.gif)|*.jpg;*.jpeg;*.bmp;*.gif"

boolResult = objDialog.ShowOpen
If boolResult = True Then
Image1.Picture = LoadPicture(objDialog.Filename)
End If

End Sub

Private Sub Start_Click()
'On Error Resume Next
Dim X, Y, Z As Long
Dim hwnd, hdc As Long
Dim Px, Py As Long

UserForm1.Caption = "xCell-Art | Proses dimulai, Jangan diinterupsi!"

ActiveWindow.DisplayGridlines = False
Cells.Interior.Pattern = xlNone
Cells.ColumnWidth = 0.35
Cells.RowHeight = 3.35

UserForm1.Left = 0
UserForm1.Top = 0

Px = UserForm1.Left + 5
Py = UserForm1.Top + 5

hwnd = WindowFromPoint(Px, Py)
hdc = GetDC(hwnd)
  
For X = 1 To Round(1.4 * Image1.Width, 0)
    For Y = 1 To Round(1.3 * Image1.Height, 0)
    Z = GetPixel(hdc, X, Y)
    If Z = 16777215 Then 'skip warna putih (background), lumayan untuk mempercepat proses :P
    Z = 0
    End If
  
    If Z > 0 Then
        Cells(Y, X).Interior.Color = Z
        Application.StatusBar = "Proses mewarnai sel | Koordinat = " & "x:" & X & " - y:" & -Y
    End If
    Z = 0
    Next Y
 Next X

UserForm1.Caption = "xCell-Art | Selesai"
Application.StatusBar = "xCell-Art 2009"
hwnd = 0
hdc = 0
X = 0
Y = 0
Z = 0
Px = 0
Py = 0
End Sub

Private Sub Tentang_Click()
Dim pesan As String
pesan = "xCell-Art 2009 by XANTOV" & vbCrLf & "email: xantov@gmail.com" & _
 vbCrLf & vbCrLf & "xCell-Art adalah program yang dibuat dengan VBA MS-Excel(TM) untuk membuat gambar dalam sel-sel pada Work Sheet dari sebuah gambar bitmap."
MsgBox pesan, vbInformation, "xCell-Art 2009"
End Sub


Private Sub Tutup_Click()
End

End Sub

Private Sub UserForm_Activate()
Dim n
For n = 5 To 8
ComboBox1.AddItem 2 ^ n
Next
ComboBox1.Text = 128

End Sub

Private Sub ComboBox1_Change()
With Image1
.Width = ComboBox1.Text: .Height = ComboBox1.Text
End With

If ComboBox1.Value > 256 Then
MsgBox "Resolusi maksimum output 256 Cells!", vbCritical, "xCell-Resolusi"
ComboBox1.Text = 256
End If

End Sub

• Modul

Option Explicit

Public Declare Function GetPixel Lib "gdi32" _
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long

Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Public Declare Function FindWindow32 Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, _
ByVal yPoint As Long) As Long

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Download 
xCell-Art2009.10.zip
Password: !@#$%^&*()1234567890