COVID-19: Choose between our familiar (but now socially distanced) classroom training courses and our excellent new live online courses.
How to have fun pixellating and reconstructing images in VBA
You can have great fun taking your favourite image (a picture of your loved one?) and pixellating it in VBA. The results are stored as RGB numbers in a workbook - what you do with them then is up to you!

Posted by Andy Brown on 25 August 2020

You need a minimum screen resolution of about 700 pixels width to see our blogs. This is because they contain diagrams and tables which would not be viewable easily on a mobile phone or small laptop. Please use a larger tablet, notebook or desktop computer, or change your screen resolution settings.

Pixellation in Excel VBA - storing your pictures cell by cell

To help me create the competition for our latest newsletter I've had to learn a bit about pixellation in VBA (picking out individual pixels from pictures).  It was such fun that I thought I'd share it!

A star is born

Let's see what we can do with this iconic moment from the superb 2018 film "A Star is Born".

One thing to watch out for: VBA doesn't support modern formats like PNG, so you're best off sticking to GIF or JPG.

Two warnings before we begin

This macro finds where a picture is on screen, and loops over its pixels one by one.  If you change your screen while the macro is running, you'll get effects like this:

Striped effect

You can see that I kept leaving this screen and going back to it while the macro was running.

 

Also, you're unlikely to get much out of this blog if you don't already know some VBA.  And with all those horrid warnings out of the way, let's get started!

Getting started - adding a blank image

The first thing to do is to add your image as an ActiveX control, and to do that you need a Developer tab on your ribbon.

Developer tab

If you have already got this tab, you can skip the next couple of instructions.

To get the Developer tab visible, right-click anywhere on the ribbon and choose to customise it:

Customising your ribbon

Right-click anywhere on your Excel ribbon to customise it.

 

Tick this box:

Tick Developer

The tab was there all the time - you just couldn't see it!

 

The Developer tab allows you to write macros in VBA - and also to insert ActiveX controls, which are just little widgets like pictures and dropdowns which you can add to a spreadsheet.

Now choose to add an ActiveX image:

Adding an image

Choose this icon to add an image from the Insert menu on the Developer tab.

 

Draw where you want your image to go:

Drawing an image

Draw the outline for your image.

 

Now to associate the image with a picture:

Blank image

The image is a bit ... blank.

 

Attaching a picture to your image

Press Alt + F11 to toggle to VBA (you can use the same short-cut key to toggle back again), and make sure you can see the Properties window:

Properties window

It'll probably already be visible, but just in case press F4 to check.

 

Go back into Excel and select your image control:

Select your image

Make sure you've selected the image you just added.

 

Now go back into VBA and you'll be looking at the properties of the image.  Go to the Picture property, and click on the ... symbol:

Change the Picture property

We want to assign our picture to the image control.

 

VBA will now display (bitmap) next to the image:

Picture bitmap

The sign of success ...

 

More importantly, back in Excel you'll see your image:

The image

You could have changed the image name property in VBA too, but we're sticking with Image1.

 

Creating and naming worksheets

 

Now create worksheets in your workbook to hold the red, green and blue part of your pixels, and to hold your pixellated picture:

Four worksheets

The Sheet1 worksheet is the one containing your image.

Back in VBA, make sure these are named as follows:

Naming your sheets

You can use the Name property of a worksheet to give it an internal VBA name, making your macro easier to code.

 

The macro itself

Here's the code itself.  I've added comments to the bits I understand fully!

Option Explicit

'internal Windows calls

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

Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

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

'the on-screen rectangle for the image

Private Type ImageBox

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

'the current context

Dim IDC As Long

'where to start drawing

Dim OriginalRow As Integer

Dim OriginalColumn As Integer

Sub ScanImage()

'the macro to scan an image!

Dim RC As ImageBox

Dim ScanX As Single

Dim ScanY As Single

Dim ImX As Single

Dim ImY As Single

Dim PixCol As Single

'get the rectangle for the image on screen

Call GetImageRect(RC)

ImX = RC.Left

ImY = RC.Top

'get a context (although I'm not sure what this is or why you need it)

IDC = GetDC(0)

'clear any old numbers/pixels

Red.Cells.Clear

Blue.Cells.Clear

Green.Cells.Clear

Sheet1.Cells.Clear

Dim i As Integer

Dim j As Integer

OriginalRow = InputBox("Which row would you like to start drawing on?")

OriginalColumn = 1

j = OriginalRow

i = OriginalColumn

'make picture mesh fine (draws much quicker for some reason)

Sheet1.Select

Cells.EntireColumn.ColumnWidth = 0.63

Cells.EntireRow.RowHeight = 6

'zoom in (draws quicker)

ActiveWindow.Zoom = 40

'scan image left to right ...

For ScanX = RC.Left To RC.Right

'... and top to bottom

For ScanY = RC.Top To RC.Bottom

'get a number representing this pixel colour

PixCol = GetPixel(IDC, ScanX, ScanY)

'store the RGB components, and colour the next cell

ColourCell Cells(j, i), PixCol

'go on to next column

j = j + 1

Next

'go on to next row

i = i + 1

'debug to stop every 5th row - remove when working

'If i Mod 5 = 0 Then Stop

j = OriginalRow

Next

'not sure why this is needed!

IDC = ReleaseDC(0, IDC)

MsgBox "The picture has been created!"

End Sub

Private Function ScreenDPI(bVert As Boolean) As Long

'get screen resolution (dots per inch), so can convert units to pixels

Static lDPI&(1), lDC&

If lDPI(0) = 0 Then

lDC = GetDC(0)

'horizontal

lDPI(0) = GetDeviceCaps(lDC, 88&)

'vertical

lDPI(1) = GetDeviceCaps(lDC, 90&)

lDC = ReleaseDC(0, lDC)

End If

ScreenDPI = lDPI(Abs(bVert))

End Function

Private Function PTtoPX(Points As Single, bVert As Boolean) As Long

'convert points to pixels

PTtoPX = Points * ScreenDPI(bVert) / 72

End Function

Sub GetImageRect(ByRef RC As ImageBox)

Dim RNG As Range

Set RNG = Sheet1.Range("A1")

Dim wnd As Window

Set wnd = RNG.Parent.Parent.Windows(1)

With Sheet1.Image1

RC.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) + wnd.PointsToScreenPixelsX(0)

RC.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) + wnd.PointsToScreenPixelsY(0)

RC.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) + RC.Left

RC.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) + RC.Top

End With

End Sub

Sub ColourCell(c As Range, ThisColour As Single)

'colour the passed in cell

Dim RedValue As Byte

Dim GreenValue As Byte

Dim BlueValue As Byte

RedValue = ThisColour And &HFF&

GreenValue = (ThisColour And &HFF00&) / 256

BlueValue = (ThisColour And &HFF0000) / 65535

c.Interior.Color = RGB(RedValue, GreenValue, BlueValue)

Dim r As Integer

Dim col As Integer

r = c.Row - OriginalRow + 1

col = c.Column - OriginalColumn + 1

Red.Cells(r, col).Value = RedValue

Green.Cells(r, col).Value = GreenValue

Blue.Cells(r, col).Value = BlueValue

End Sub

Running your macro

Before running your macro, it might be an idea to comment back in this line:

'debug to stop every 5th row - remove when working

If i Mod 5 = 0 Then Stop

Without this it can be a tedious wait for the macro to finish before you can solve any problems.

I'd also strongly recommend saving your changes before testing the macro out for the first time.

If you now click on Sheet1 and run your macro, you should see something like this:

Row number for start

Type in a big enough row number so that the drawn picture is separate from the initial one.

The macro should now start doing its stuff!

Drawing the picture

Resist the temptation to click away - doing so will ruin your drawing!

 

Eureka!

The final image

Time now to play around with it, perhaps?

 

Experimenting with the colour numbers

You should now be able to build your very own image processor in VBA.  Here's a macro which will take the RGB numbers and recombine them to recreate the picture on a new sheet:

Option Explicit

Sub Recreate()

Dim reds As Range

Dim blues As Range

Dim greens As Range

Const factor As Integer = 4

'get the blocks of numbers for RGB colours

Set reds = Red.Range("A1").CurrentRegion

Set blues = Blue.Range("A1").CurrentRegion

Set greens = Green.Range("A1").CurrentRegion

'add a new worksheet

Worksheets.Add

'keep aspect ratio, but make bigger

Cells.EntireColumn.ColumnWidth = 0.63 * 4

Cells.EntireRow.RowHeight = 6 * 4

'zoom in

ActiveWindow.Zoom = 40

Dim c As Range

For Each c In reds

'colour each cell ... correctly?

Cells(c.Row, c.Column).Interior.Color = RGB( _

c.Value, _

Green.Cells(c.Row, c.Column), _

blues.Cells(c.Row, c.Column))

Next c

End Sub

Here are some of my efforts!

Images processed

These are a bit shallow - see if you can do better.

If you get a "Too many cell formats" message, delete the extra worksheets that you've created, save and close your file then open it up again.

Experimenting with the image itself

So I had finished and published this blog, and then suddenly realised that you can start manipulating the image itself.  For example:

Sub MoveAbout()

Dim r As Range

Dim c As Range

Dim temp

Set r = Range("A30:CH119")

For Each c In r

'for every other cell in the picture ...

If c.Column Mod 2 = 1 Then

'.. swap its colours with the cell to its right

temp = c.Interior.ColorIndex

c.Interior.ColorIndex = c.Offset(0, 1).Interior.ColorIndex

c.Offset(0, 1).Interior.ColorIndex = temp

End If

Next c

End Sub

Here's what this produces:

Massaged picture

Ally is only just recognisable now.

 

You could white out every other row/column:

Checkerboard effect

A variation on the first macro.

 

I could spend days doing this! 

This blog has 0 threads Add post