I found this Bulging Square illusion on my iPad, and then I found that Excel Hero had already done it as The Bulging Checkerboard. But Daniel did it as a chart, no VBA. Here is my interpretation with VBA, no chart.
The first step was to make the cells square. Cell dimensions are based on the font used. Column width is based on the width of the zero character of the font, and Row height is based on the size of the font. Setting the font to Arial 6pt, a height of 8.25 and a width of 0.92 makes square cells. The other dimensions, roughly 1/6th of the ones just mentioned, function as the checkerboard square’s borders. The big square is nine square cells, with a border on all four sides and all four corners.
The board is built from the upper left to the lower right based on a user-inputted color index. The default value is a random integer between 3 and 56 inclusive, these being the non-black and non-white indices of the default Excel color palette. With given upper and lower bounds the formula Int((upperbound – lowerbound + 1) * Rnd + lowerbound) to produce random numbers in the range 3 to 56 becomes Int((56 – 3 + 1) * Rnd + 3) or Int(54 * Rnd + 3).
Then interior corner cells are turned color to complete the illusion of smaller squares inside the larger ones, warping the lines.
Lastly, a button is added to allow the illusion to be renewed in a different color.
Dim R As Long, C As Long
Dim i As Long, j As Long, k As Long
Dim Index As Variant, Start As Long
Dim Rng As Range
Dim Title As String
Application.WindowState = xlMaximized
Worksheets(“Sheet3”).Activate
With ActiveWindow
.DisplayHeadings = False
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
.DisplayGridlines = False
End With
Set Rng = Worksheets(“Sheet3”).Range(“A1:BY77”)
Index = 2
If ActiveSheet.Buttons.Count = 0 Then
Start = 18
Else
Start = Int((54 * Rnd) + 3)
End If
Title = “Bulging Squares”
While Index < 3
Index = Application.InputBox(“Please pick a number between 3 and 56.” _
& vbNewLine & “Entering a zero will Cancel.”, _
Title, Start, , , , , 1)
If Index = False Then Exit Sub
If Index = 0 Then Exit Sub
If Index > 56 Then Index = 2
If Index < 3 Then
Title = “Please pick again!”
Start = Int((54 * Rnd) + 3)
End If
Wend
Application.ScreenUpdating = False
Rng.Font.Name = “Arial”
Rng.Font.size = 6
For R = 1 To 77
Select Case R
Case 2, 6, 7, 11, 12, 16, 17, 21, 22, 26, 27, _
31, 32, 36, 37, 41, 42, 46, 47, 51, 52, 56, _
57, 61, 62, 66, 67, 71, 72, 76
Rng.Columns(R).ColumnWidth = 0.15
Rng.Rows(R).RowHeight = 1.5
Case Else
Rng.Columns(R).ColumnWidth = 0.92
Rng.Rows(R).RowHeight = 8.25
End Select
Next R
Application.ScreenUpdating = True
k = 7
For j = 2 To 72 Step 5
If j Mod 10 = 7 Then k = k – 1
For R = j To j + 4
For C = j To j + 4
For i = 0 To k
Rng.Cells(R, C).Offset(0, i * 10).Interior.ColorIndex = Index
Rng.Cells(R, C).Offset(i * 10, 0).Interior.ColorIndex = Index
Next i
Next C
Next R
Next j
For i = 0 To 20 Step 10
For R = i + 8 To 33 Step 5
C = 43 + i – R
Rng.Cells(R, C).Interior.ColorIndex = Index
Rng.Cells(R + 2, C – 2).Interior.ColorIndex = Index
C = 35 – i + R
Rng.Cells(R, C).Interior.ColorIndex = Index
Rng.Cells(R + 2, C + 2).Interior.ColorIndex = Index
Next R
Next i
For i = 0 To 20 Step 10
For R = 45 To 70 – i Step 5
C = R – 35 + i
Rng.Cells(R, C).Interior.ColorIndex = Index
Rng.Cells(R – 2, C – 2).Interior.ColorIndex = Index
C = 113 – i – R
Rng.Cells(R, C).Interior.ColorIndex = Index
Rng.Cells(R – 2, C + 2).Interior.ColorIndex = Index
Next R
Next i
For R = 13 To 23 Step 5
C = 38 – R
Rng.Cells(R, C).Interior.ColorIndex = 2
Rng.Cells(R + 2, C – 2).Interior.ColorIndex = 2
C = 40 + R
Rng.Cells(R, C).Interior.ColorIndex = 2
Rng.Cells(R + 2, C + 2).Interior.ColorIndex = 2
Next R
For i = 0 To 20 Step 10
For R = i + 13 To 33 Step 5
C = 48 + i – R
Rng.Cells(R, C).Interior.ColorIndex = 2
Rng.Cells(R + 2, C – 2).Interior.ColorIndex = 2
C = 30 – i + R
Rng.Cells(R, C).Interior.ColorIndex = 2
Rng.Cells(R + 2, C + 2).Interior.ColorIndex = 2
Next R
Next i
For i = 0 To 20 Step 10
For R = 45 To 65 – i Step 5
C = R – 30 + i
Rng.Cells(R, C).Interior.ColorIndex = 2
Rng.Cells(R – 2, C – 2).Interior.ColorIndex = 2
C = 108 – i – R
Rng.Cells(R, C).Interior.ColorIndex = 2
Rng.Cells(R – 2, C + 2).Interior.ColorIndex = 2
Next R
Next i
For R = 55 To 65 Step 5
C = R – 40
Rng.Cells(R, C).Interior.ColorIndex = 2
Rng.Cells(R – 2, C – 2).Interior.ColorIndex = 2
C = 118 – R
Rng.Cells(R, C).Interior.ColorIndex = 2
Rng.Cells(R – 2, C + 2).Interior.ColorIndex = 2
Next R
For R = 10 To 30 Step 10
C = 38
Rng.Cells(R, C).Interior.ColorIndex = 2
Rng.Cells(R, C + 2).Interior.ColorIndex = 2
Rng.Cells(C, R).Interior.ColorIndex = 2
Rng.Cells(C + 2, R).Interior.ColorIndex = 2
Next R
For C = 48 To 68 Step 10
R = 38
Rng.Cells(R, C).Interior.ColorIndex = 2
Rng.Cells(R + 2, C).Interior.ColorIndex = 2
Rng.Cells(C, R).Interior.ColorIndex = 2
Rng.Cells(C, R + 2).Interior.ColorIndex = 2
Next C
For R = 15 To 35 Step 10
C = 38
Rng.Cells(R, C).Interior.ColorIndex = Index
Rng.Cells(R, C + 2).Interior.ColorIndex = Index
Rng.Cells(C, R).Interior.ColorIndex = Index
Rng.Cells(C + 2, R).Interior.ColorIndex = Index
Next R
For C = 43 To 63 Step 10
R = 38
Rng.Cells(R, C).Interior.ColorIndex = Index
Rng.Cells(R + 2, C).Interior.ColorIndex = Index
Rng.Cells(C, R).Interior.ColorIndex = Index
Rng.Cells(C, R + 2).Interior.ColorIndex = Index
Next C
If ActiveSheet.Buttons.Count = 0 Then
ActiveSheet.Buttons.Add(493.5, 120, 81.75, 31.5).Select
Selection.OnAction = “Bulging_Squares”
Selection.Characters.Text = “Renew Illusion”
With Selection.Characters(Start:=1, Length:=14).Font
.Name = “Verdana”
.FontStyle = “Regular”
.size = 10
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End If
Range(“A1”).Select
End Sub
Last week, with great perspicacity, Dick beat down my problem with HTML tags. No more substitutions required!
…mrt
I like it.
Here’s my effort. Interesting when you increase const cCenter, the effect still works.
Const cCenter = 7, cRadius = cCenter * cCenter * 0.8
Const cBlkW = 0.92, cBlkH = 8.25, cGapW = cBlkW / 6, cGapH = cBlkH / 6
Const cFore = 2, cBack = 1
Dim i As Long, j As Long, bln As Boolean, rng As Range
Dim rngR As Range, lngF As Long, lngB As Long
Application.ScreenUpdating = False
ActiveWindow.DisplayGridlines = False
With Cells
.Interior.ColorIndex = xlNone
.ColumnWidth = cBlkW
.RowHeight = cBlkH
End With
Set rngR = Cells(cCenter * 5 + 1, cCenter * 5 + 1)
For i = 0 To cCenter * 2
Columns(i * 5 + 1).ColumnWidth = cGapW
Columns(i * 5 + 5).ColumnWidth = cGapW
Rows(i * 5 + 1).RowHeight = cGapH
Rows(i * 5 + 5).RowHeight = cGapH
Next
For i = -cCenter To cCenter
For j = -cCenter To cCenter
bln = i And 1 Xor j And 1: lngF = IIf(bln, cBack, cFore): lngB = IIf(bln, cFore, cBack)
Set rng = rngR.Offset(j * 5, i * 5)
rng.Resize(5, 5).Interior.ColorIndex = lngB
If i * i + j * j <= cRadius Then
If i <= 0 And j > 0 Or i > 0 And j <= 0 Then rng(2, 2).Interior.ColorIndex = lngF
If i < 0 And j <= 0 Or i >= 0 And j > 0 Then rng(2, 4).Interior.ColorIndex = lngF
If i <= 0 And j < 0 Or i > 0 And j >= 0 Then rng(4, 2).Interior.ColorIndex = lngF
If i >= 0 And j < 0 Or i < 0 And j >= 0 Then rng(4, 4).Interior.ColorIndex = lngF
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Rob –
Wow. Very nice. Very concise. Very fast.
I knew from the visual symmetry that there was an elegant loop that did it all. I just couldn’t find it. I settled for a handful of smaller symmetries. Nice code.
…mrt
I’m annoyed that I went
i And 1 Xor j And 1 instead of(i Xor j) And 1. It's not often I get to use Xor, so that really bugged me haha.