Bulging Squares

Bulging CheckerboardI 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.

Sub Bulging_Squares()
   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

Posted in Uncategorized

3 thoughts on “Bulging Squares

  1. I like it.

    Here’s my effort. Interesting when you increase const cCenter, the effect still works.

    Sub test()
        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

  2. 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

  3. 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.

Leave a Reply

Your email address will not be published. Required fields are marked *