Opening Paint files in XL

The Great Wave of Kanagawa
Specifically, MacPaint files. Why MacPaint? 1. With a maximum size of 576 pixels wide by 720 pixels tall, MacPaint images fit on a modern spreadsheet when using cells as pixels, and 2. MacPaint prototyped the lossless PackBits compression algorithm, which is the default compression scheme for TIFF.

PackBits is a signed-byte file structure with flag-counter bytes interspersed with data bytes. If the flagbyte is negative, the next byte (always a data byte) is repeated, zero-based, the two’s-complement of the flagbyte times. If the flagbyte is a positive number, the next number of bytes are copied directly. Each data byte represents the status of eight pixels, with 1 indicating a black pixel and 0 representing a white pixel, as shown below.

The PackBits algorithm is defined here. The following code, cross-posted to Wikipedia, handles Apple’s demonstration case.

Sub UnpackBitsDemo()

   Dim File    As Variant
   Dim MyOutput As String
   Dim Count   As Long
   Dim i As Long, j As Long
 
   File = “FE AA 02 80 00 2A FD AA 03 80 00 2A 22 F7 AA”
   File = Split(File, ” “)
   
   For i = LBound(File) To UBound(File)
      Count = Application.WorksheetFunction.Hex2Dec(File(i))
      Select Case Count
      Case Is >= 128
         Count = 256 – Count ‘Two’s Complement
         For j = 0 To Count ‘zero-based
            MyOutput = MyOutput & File(i + 1) & ” “
         Next j
         i = i + 1 ‘Adjust the pointer
      Case Else
         For j = 0 To Count ‘zero-based
            MyOutput = MyOutput & File(i + j + 1) & ” “
         Next j
         i = i + j ‘Adjust the pointer
      End Select
   Next i
   Debug.Print MyOutput
   ‘AA AA AA 80 00 2A AA AA AA AA 80 00 2A 22 AA AA AA AA AA AA AA AA AA AA’
End Sub

It works out then that a PackBits stream is a flagbyte followed by data bytes followed by a flagbyte followed by data bytes… Each flagbyte indirectly points to the location of the next flagbyte.
 
Excel’s VBA does not have signed bytes, but if we look at the flagbyte’s value, and “Select Case” all flagbytes greater or equal to 128 (b10000000) we have a test that handles negative flag bytes. The two’s complement of a number N is 2B-N, where B is the word size, in our case, 8. In other words, the two’s-complement of the negative flagbyte is 256 minus the value of the flagbyte.
 
The MacPaint file has a 512-byte header that we can ignore. It also can have, as data bytes, internal bytes that would otherwise be read as end-of-file. We handle that by reading the file in for binary access.
 
The basic approach is to read in the file similarly to a text file. Turn the flagbytes characters into ascii, with the ascii as the count to copy or to take the two’s complement of. Byte(513) has to be a flagbyte. The data bytes are input as characters, turned to ascii, then turned to byte-strings. The cells are turned black or white by looping through the byte-string. After 576 1’s and 0’s (or 72 data bytes) a new row is started. The file structure does not reveal the length of the data, but we can infer that from the file’s length.

Sub OpenMacPaint()
   Dim TotalBytes As Long
   Dim Buffer As String
   Dim File    As Variant
   Dim Char  As String * 1
   Dim NextChar As String * 1
   Dim NextInt As Integer
   Dim NextByte As String * 8
   Dim Count   As Long
   Dim i As Long, j As Long, r As Long, c As Long, b As Long
   Dim Rng As Range
   
   File = Application.InputBox(“Enter the full path to the MacPaint file.”, “Path to the MacPaint file…”, _
      “Macintosh HD:Users:User:Downloads:GREAT WAVE.mac”, , , 2) ‘ Your path here
   If File = False Then Exit Sub

   Open File For Binary Access Read As #1
   TotalBytes = FileLen(File)
   Buffer = Input(TotalBytes, #1)
   Close #1
   If TotalBytes = 0 Then
      MsgBox “Exiting!”, vbCritical + vbOKOnly, “File not found!”
      Exit Sub
   End If
   
   c = 1
   r = 1
   Application.ScreenUpdating = False
   For i = 513 To TotalBytes ‘skip the header
      Char = VBA.Mid$(Buffer, i, 1)
      Count = Asc(Char)
      Select Case Count
         Case Is >= 128
            Count = 256 – Count ‘Two’s Complement
            NextChar = VBA.Mid$(Buffer, i + 1, 1)
            NextInt = Asc(NextChar)
            NextByte = Application.WorksheetFunction.Dec2Bin(NextInt, 8)
            For j = 0 To Count ‘zero-based repeat of the next byte
                For b = 1 To 8
                    If VBA.Mid$(NextByte, b, 1) = “1” Then
                        Worksheets(“Sheet4”).Cells(r, c).Interior.ColorIndex = 1 ‘Black
                    Else
                        Worksheets(“Sheet4”).Cells(r, c).Interior.ColorIndex = 2 ‘White
                    End If
                    c = c + 1
                    If c > 576 Then ‘a new row
                        c = 1
                        r = r + 1
                    End If
                Next b
            Next j
            i = i + 1 ‘adjust the counter
         Case Else
            For j = 0 To Count ‘zero-based copy of Count bytes
                NextChar = VBA.Mid$(Buffer, i + j + 1, 1)
                NextInt = Asc(NextChar)
                NextByte = Application.WorksheetFunction.Dec2Bin(NextInt, 8)
                For b = 1 To 8
                    If VBA.Mid$(NextByte, b, 1) = “1” Then
                        Worksheets(“Sheet4”).Cells(r, c).Interior.ColorIndex = 1
                    Else
                        Worksheets(“Sheet4”).Cells(r, c).Interior.ColorIndex = 2
                    End If
                    c = c + 1
                    If c > 576 Then ‘a new row
                         c = 1
                         r = r + 1
                    End If
                Next b
            Next j
            i = i + j ‘adjust the counter
         End Select
   Next i
   
   Set Rng = Worksheets(“Sheet4”).Range(“A1:VE720”)
   Rng.ColumnWidth = 1
   Rng.RowHeight = 12
   ActiveWindow.Zoom = 10
   Application.ScreenUpdating = True
Exit Sub

What I don’t like about the code is that for the case of Count>=128, the repetitive bytes, I’m parsing it Count times. Rather I should parse it once and copy it Count times. I just don’t see how. I know somebody out there does.
 
If you want the MacPaint copy of Hokusai’s The Great Wave off Kanagawa shown above, it’s here. A nice thing about the Excel code is that you can change the color indices to suit. An appropriate blue might be color index 32, RBG(0,0,255).

To show why PackBits is still used, the lossless JPEG used above for HTML purposes is 211 Kbytes. The lossless Mac counterpart is 17 Kbytes. While a MacPaint file can define 576*720 pixels (0.4 megapixels), its maximum size is 512 + (72*90) bytes, or just over 51 Kbytes.

 
…mrt

Change Case… ala’ Microsoft Word

Mac VersionLast week, more absent-minded than usual, I forgot the software I was in. I looked for the Change Case … format dialog in Excel. It’s not there, of course. It’s in Word. It’s in PowerPoint. It’s not in Excel. So I took a morning and wrote one.

Word gives you five options to change case: Sentence case, lower case, UPPER CASE, Title Case, and tOGGLE cASE. Word’s “Title Case” is a misnomer. It’s really what we think of as PROPER() case–every word capitalized. So my version has six options, including a true Title Case in accordance with the government style manual for capitalization of short words, and a Proper Case that does exactly as MSWord does in its Title Case.

Considering The Grapes of Wrath as illustrative:

  • Sentence case returns: The grapes of wrath
  • lower case returns: the grapes of wrath
  • UPPER CASE returns: THE GRAPES OF WRATH
  • Title Case returns: The Grapes of Wrath
  • tOGGLE cASE returns: tHE gRAPES OF wRATH
  • Proper Case returns: The Grapes Of Wrath. Note the captialized of.

PC verisonLower case, upper case, and proper case were easy. They are just applications of LCase(), UCase(), or Application.Worksheetfunction.Proper() to the selection contents.

Title case starts with capitalizing every word and then swapping in the lower case versions of the one, two, and three letter words, when found between two spaces. Two spaces protects against an inappropriate changeout of a leading article.

Sentence case is a recursive search for full-stop punctuation (periods, exclamation points, question marks, and colons) reading left to right. The exit condition is when there nothing more found to the right.

Toggle case adds or subtracts 32 to the ascii-code of each letter to change its case. Upper to lower, add 32. Lower to upper, subtract 32. Non-letters are unchanged. The Like operator is used to for the comparisons in both the sentence and toggle cases.

The macro module code is a one-liner. All the execution is in the form’s code.

Sub Change_Case()
   frmChangeCase.Show
End Sub

Code for the form:

Private CaseChange As Long
Option Explicit

Private Sub CommandButton1_Click()   ‘Cancel
   Unload Me
   End
End Sub

Private Sub CommandButton2_Click()   ‘OK
   Me.Hide
   Change_Case_1
End Sub

Private Sub OptionButton1_Click()   ‘Sentence case
   CaseChange = 1
End Sub

Private Sub OptionButton2_Click()   ‘lower case
   CaseChange = 2
End Sub

Private Sub OptionButton3_Click()   ‘UPPER CASE
   CaseChange = 3
End Sub

Private Sub OptionButton4_Click()   ‘Title Case
   CaseChange = 4
End Sub

Private Sub OptionButton5_Click()   ‘tOGGLE cASE
   CaseChange = 5
End Sub

Private Sub OptionButton6_Click()   ‘Proper Case
   CaseChange = 6
End Sub

Private Sub UserForm_Initialize()
   OptionButton4 = True
   CaseChange = 4
End Sub

Private Sub Change_Case_1()
‘http://www.writers.com/tips_titles.html
‘Capitalize all words in titles of publications and documents, except
‘a, an, the, at, by, for, in, of, on, to, up, and, as, but, it, or, and nor.
   Dim Cell    As Range
   Dim i       As Long
   Dim Replacement As String
   Dim SubOut  As Variant
   Dim SubIn   As Variant

   SubIn = Split(“a an the at by for in of on to up and as but it or nor”)
   SubOut = Split(“A An The At By For In Of On To Up And As But It Or Nor”)
   
   For i = LBound(SubIn) To UBound(SubIn)
      SubIn(i) = VBA.Chr$(32) & SubIn(i) & VBA.Chr$(32)
      SubOut(i) = VBA.Chr$(32) & SubOut(i) & VBA.Chr$(32)
   Next i

   For Each Cell In Selection
      If Application.WorksheetFunction.IsText(Cell.Value) Then
         Select Case CaseChange
            Case 1   ‘The grapes of wrath
               For i = 1 To Len(Cell.Text)
                  If Mid$(Cell.Text, i, 1) Like “[A-Za-z0-9]” Then
                     Replacement = UCase(Left$(Cell.Text, i)) & SentenceCase(Right$(Cell.Text, Len(Cell.Text) – i))
                     ‘ Recursive
                     Exit For
                  End If
               Next i
               Cell.Value = Replacement
            Case 2   ‘the grapes of wrath
               Cell.Value = VBA.LCase(Cell.Value)
            Case 3   ‘THE GRAPES OF WRATH
               Cell.Value = VBA.UCase(Cell.Value)
            Case 4   ‘The Grapes of Wrath
               Replacement = Application.WorksheetFunction.Proper(Cell.Value)
               For i = LBound(SubOut) To UBound(SubOut)
                  Replacement = VBA.Replace(Replacement, SubOut(i), SubIn(i), vbBinaryCompare)
               Next i
               Cell.Value = Replacement
            Case 5   ‘ tHE gRAPES oF wRATH
               Replacement = “”
               For i = 1 To Len(Cell.Text)
                  If VBA.Mid$(Cell.Text, i, 1) Like “[A-Z]” Then
                     Replacement = Replacement & VBA.Chr$(VBA.Asc(VBA.Mid$(Cell.Text, i, 1)) + 32)
                  ElseIf VBA.Mid$(Cell.Text, i, 1) Like “[a-z]” Then
                     Replacement = Replacement & VBA.Chr$(VBA.Asc(VBA.Mid$(Cell.Text, i, 1)) – 32)
                  Else
                     Replacement = Replacement & VBA.Mid$(Cell.Text, i, 1)
                  End If
               Next i
               Cell.Value = Replacement
            Case 6   ‘The Grapes Of Wrath
               Cell.Value = Application.WorksheetFunction.Proper(Cell.Value)
         End Select
      End If
   Next Cell
   Unload Me
End Sub

Private Function SentenceCase(Sentence As String) As String
   Dim i As Long, j As Long, n As Long
   Dim LeftSide As String, RightSide As String

   n = Len(Sentence)
   For i = 1 To n
      If Mid$(Sentence, i, 2) Like “[.!?:] ” Then
         LeftSide = Left$(Sentence, i + 1)
         RightSide = Right$(Sentence, n – i – 1)
         Exit For
      ElseIf i = n Then
         LeftSide = Sentence
         RightSide = vbNullString   ‘Exit condition
      End If
   Next i

   For j = 1 To Len(RightSide)
      If Mid$(RightSide, j, 1) Like “[A-Za-z0-9]” Then
         RightSide = UCase(Left$(RightSide, j)) & SentenceCase(Right$(RightSide, Len(RightSide) – j))
         ‘Recursive
         Exit For
      End If
   Next j

   SentenceCase = LeftSide & RightSide

End Function

I wanted to use the antique char|32 and char&32 to do the toggle-case change, but I couldn’t find the right syntax. Wiki says it’s not any faster these days, but readers may want to comment.

Tested on a PC and a Mac (using XL2011). The Mac does not appear to support tool-tips from the form. The Mac version looked better in Tahoma 12, the PC version in Tahoma 10. I compromised.

The form is available here.

…mrt

Decimal Degrees to Degrees-Mins-Secs

GPS tells you where you are in Decimal Degrees (DD), with positive degrees being north latitude or east longitude, and negative degrees being south latitude or west longitude. Most charts (I was a nautical type before I was an Excel type. Think maps if that’s not you) tell you position in degrees-arc minutes-arc seconds (DMS). While one can “eyeball” the conversion from DD to DMS, let’s get more specific. Thanks to Wikipedia, the US Capitol is at 38.889722°, -77.008889°. Ignoring what we might otherwise know, by the GPS sign conventions the Capitol has a north latitude and a west longitude. Making the conversion is about handling remainders. Walking through converting the Capitol’s longitude, the degrees are:

  • D = INT(ABS(-77.008889)) or 77

The remainder R is:

  • R = ABS(-77.008889) – D
  • R = 77.008889 – 77
  • R = 0.008889

To convert to arc-minutes:

  • M = R*60
  • M = 0.008889*60
  • M = 0.533340
  • M = INT(M) = INT(0.533340)
  • M = 0, but always formatted “00”

The remainder is:

  • R = 0.533340 – M*60
  • R = 0.533340 – 0*60
  • R = 0.533340

To convert to arc-seconds:

  • S = R*60
  • S = 0.533340*60
  • S = 32.000400
  • S = INT(S) = INT(32.000400)
  • S = 32

The Capitol is at 77 degrees, 00 minutes, 32 seconds, and remembering the minus sign, west. Or 77° 00′ 32? W. Alternatively, 77° 00′ 32″ W with ascii substitutions for prime and double prime.

Turning that into VBA, with an optional Boolean to specify if you want north/south or east/west, and another option for Ascii representation, the DD2DMS conversion looks like this:

Function DD2DMS(Degrees As Variant, Optional Lat As Boolean = True, _
   Optional Ascii As Boolean = True) As String
   Dim ArcMins As Variant
   Dim ArcSecs As Variant
   Dim NSEW    As String * 2
   Dim D_mark As String * 1, M_mark As String * 1, S_mark As String * 1

   If Lat Then
      NSEW = IIf(Degrees < 0, ” S”, ” N”)
   Else
      NSEW = IIf(Degrees < 0, ” W”, ” E”)
   End If
   
   D_mark = ChrW(176)
   If Ascii Then
      M_mark = ChrW(39): S_mark = ChrW(34)
   Else
      M_mark = ChrW(&H2032): S_mark = ChrW(&H2033)
   End If
   
   Degrees = Abs(Degrees)
   ArcMins = 60 * (Degrees – Int(Degrees))
   ArcSecs = 60 * (ArcMins – Int(ArcMins))
   Degrees = Int(Degrees) & D_mark & Chr(32)
   ArcMins = Format(Int(ArcMins), “00”) & M_mark & Chr(32)
   ArcSecs = Format(ArcSecs, “00”) & S_mark & NSEW
   
   DD2DMS = Degrees & ArcMins & ArcSecs
End Function

The degree character is ascii(176). That’s actually more concise than my explanation. ;-(

Can it be done in a spreadsheet formula? Of course, but it’s complicated, and that’s the reason for the somewhat tedious example above to walk through. Formulas do modular arithmetic differently than VBA. In a formula MOD(ABS(-77.008889),1) equals 0.008889. In VBA, ABS(-77.008889) Mod 1 equals zero. We’ll make use of this difference to find our remainders. Assuming the Capitol’s decimal longitude is in H8, then in four parts:

D = INT(ABS(H8))&CHAR(176)

Arc-minutes:

M = TEXT(INT(MOD(ABS(H8),1)*60),” 00″)&CHAR(39)

Arc-seconds:

S = TEXT(MOD(MOD(ABS(H8),1)*60,1)*60,” 00″)&CHAR(34)

Note the nested MOD(,1)’s to get the second remainder. Lastly for east/west:

EW = IF(H8 < 0,” W”,” E”)

The longitude is the concatenation of all of these:

=INT(ABS(H8))&CHAR(176)&TEXT(INT(MOD(ABS(H8),1)*60),” 00″)&CHAR(39)
&TEXT(MOD(MOD(ABS(H8),1)*60,1)*60,” 00″)&CHAR(34)&IF(H8 < 0,” W”,” E”)

Complicated. Can it be done as a number format? Since we are talking minutes and seconds suggests yes. However Excel doesn’t process negative times, so the answer will be completely right only for that quarter of the world that is in the northern latitudes and eastern longitudes. Assuming again H8 holds the longitude, than in another cell, =ABS(H8/24). Custom format that cell as

  • [h]° mm’ ss”

You enter the degree symbol by holding down the alt-key and keying 0176 on the keypad. How to get the north/south or east/west right will require another cell.

There’s two and a quarter ways to make the DD2DMS conversion. A second of angle on the surface of the earth is about 30 meters or 100 feet. … Degrees, given to three decimal places (1/1000 of a degree), have about 1/4 the precision as degrees-minutes-seconds (1/3600 of a degree), and so identify locations within about 120 meters or 400 feet. That’s not true as you add decimal places, of course, and the decimal to sexagesimal (Base10 to Base60) conversion becomes inexact.

More in this in the next post: How to go DMS2DD.

Unicode and VBA’s ChrW() and AscW() functions

Spreadsheets have their CHAR() function, and VBA has its Chr() function. Both return the text character for the specified numerical input, 0 to 255. And spreadsheets have their CODE() function, and VBA has its Asc() function. Both of those return the ASCII code for the leading character of a text string. All well-worn stuff.

But what if you want or need to work with Unicode values? All four functions fail you. As an example, assume you want the true prime character (‘, Unicode 2032) in a string. The prime character, technically, is not an italicized apostrophe (), a right single curly quote (‘), or an acute accent (‘).

VBA provides the ChrW() function that does that. ChrW() expects a long as input, but also accepts hexadecimal. Unicode is in hex numbering, so there are two choices: Change U2032 to decimal, or tell ChrW() that the input is in Hex. Since HEX2DEC(2032) is 8242, these two are equivalent:

  • ChrW(8242)
  • ChrW(&H2032)

Both will put ‘ into a string. If ChrW() repeated the same functionality of Chr() below 256, things would be simple. However, the Windows character set deviates from the Unicode character set for ASCII(128) to ASCII(159). In that range, Chr(CharCode) and ChrW(CharCode) produce different results. As WikiPedia says, Windows “coincides with ISO-8859-1 for all codes except the range 128 to 159 (hex 80 to 9F), where the little-used C1 controls are replaced with additional characters.” Not sure what C1 controls (probably a printer), but if we want to get Unicode to the spreadsheet, do we want it to give the functionality of CHAR()/Chr(), or that of ChrW() which is ISO-8859-1 compliant? Or, optionally both. The function CHARW() takes the optional route. If you set Exact_functionality to TRUE, you can put those C1 controls in your spreadsheet. The default is to do otherwise.

Function CHARW(CharCode As Variant, Optional Exact_functionality As Boolean = False) As String
‘Use a Leading “U” or “u” to indicate Unicode values
‘Exact_functionality returns the Unicode characters for Ascii(128) to Ascii(159) rather than
‘the Windows characters

   If UCase(Left$(CharCode, 1)) = “U” Then CharCode = Replace(CharCode, “U”, “&H”, 1, 1, vbTextCompare)
   CharCode = CLng(CharCode)

   If CharCode < 256 Then
      If Exact_functionality Then
         CHARW = ChrW(CharCode)
      Else
         CHARW = Chr(CharCode)
      End If
   Else
      CHARW = ChrW(CharCode)
   End If
End Function

One very nice thing is that you can feed Clng() a hex value, and it will do the HEX2DEC conversion for you.

The VBA function AscW() goes the other way, and has the same ISO problems. It will tell you the decimal code of the first character in a Unicode string, with no regard to the Windows character set. We can make another UDF CODEW() that can optionally specify either the decimal or hex value for the first character is returned, and whether or not to be ISO compliant. The default is to return the HEX unicode (as Uxxxx) and not to comply.

Function CODEW(Character As String, Optional Unicode_value As Boolean = True, _
               Optional Exact_functionality As Boolean = False) As Variant
‘ Exact Functionality returns exact Unicode for characters as AscW() does
‘ rather than Windows characters as Asc() does
  Dim Characters As String
   Dim i       As Long

   If Exact_functionality Then
      CODEW = AscW(Character)
      If Unicode_value Then CODEW = “U” & Hex(CODEW)
      Exit Function
   End If

   For i = 128 To 159 ‘where non-compliant
     Characters = Characters & Chr(i)
   Next i

   If InStr(1, Characters, Left$(Character, 1), vbBinaryCompare) Then
      CODEW = Asc(Character)
   Else
      CODEW = AscW(Character)
   End If
   If Unicode_value Then CODEW = “U” & Hex(CODEW)
End Function

The default will return U2032 when the first character is ‘, and 8242 when Unicode_value is set FALSE. For another example, € is CHAR(128), Chr(128), ChrW(8354), CHARW(128), CHARW(“U80”), CHARW(“U20AC”,TRUE) and CHARW(8364,TRUE).

CODEW(“€”) is “U80”, CODEW(“€”,FALSE) is 128, CODEW(“€”,,TRUE) is “U20AC”, and CODEW(“€”,FALSE,TRUE) is 8354.

To see Unicode characters, the cell’s font has to be set to a Unicode font.

…mrt

A Favorite Utility – Chip Pearson’s Cell View

I’ve been using Chip Pearson’s Cell View for years. It does just one major thing, but it does it extremely well: It shows you the ascii or hex codes for every character in a cell, and if there are hidden or trailing (or leading) characters, it flags them. A common example would be the non-breaking space, ascii(160). If you’re wondering why your FIND(” “,A1) isn’t working, Cell View will show you if it’s ascii(32) or ascii(160) that you have at hand. Here’s Chip’s example with tab character ascii(9) in the middle. Note the red caret indicating the special character.

If ascii isn’t what you want, you can optionally display the codes in hexadecimal. It does this magic by adding a “View Cell Contents” item at the bottom of the View Menu, just where you’d want it to be. Chip gives this utility away, and even provides the password with an invitation to change it. With the temerity gathered from hanging around here, I altered some minor things to suit my preferences a bit more.

The first two of these changes are in the frmShowChars code (right-click on the form frmShowChars and View Code). Chip allows you to select a starting position by counting by one’s. I made a mod to make it count by ten’s. Change the With statement in Sub UserForm_Activate() as so:

Private Sub UserForm_Activate()
   Dim N       As Long
   With Me.cbxStart
      .Clear
      .AddItem Format(1, “##0”)   ‘Added
      For N = 10 To Len(ActiveCell.Text) Step 10   ‘Changed
        .AddItem Format(N, “##0”)
      Next N
      If .ListCount > 0 Then
         .ListIndex = 0
      End If
   End With
   Me.lblVarType.Caption = vbNullString
   DoIt
End Sub

Counting by one’s seemed like overkill when coupled with a desire for the caption to tell me the cell’s total length. I changed the very top lines of code in Sub DoIt() as follows:

   If Me.chkHex.Value Then
      Me.lblCode.Caption = “Hex”
   Else
      Me.lblCode.Caption = “Ascii”   ‘Changed
   End If

   N = VBA.Len(ActiveCell.Text)   ‘Added
   C = IIf(N <> 1, ” characters.”, ” character.”)   ‘Added

   Me.Caption = “Character Codes For Cell: “ & ActiveCell.Address(False, False) _
                & “.  This cell” & Chr(146) & “s length is “ & N & C   ‘Added with underscore

 
With these changes, Cell View looks like this, showing special character acsii(160):

“View Cell Contents” is enabled even when no worksheet is visible or when no workbook is open. If you call it then, it throws an error. A fix was to edit the Sub ShowTheForm() found in the regular module modMain by calling Chip’s splash screen and then exiting:

Sub ShowTheForm()
  If ActiveCell Is Nothing Then   ‘Added
    frmAbout.Show   ‘Added
    Exit Sub   ‘ Added
  End If   ‘Added
  #If VBA6 Then
    frmShowChars.Show vbModeless
  #Else
    frmShowChars.Show
  #End If
End Sub

 

For Mac users, this version of Cell View does not work. A previous version called HexChars.xla does. The bad news is that you need a PC to unlock the code. Maybe it’ll be fixed in Excel 2011. It’s on my birthday list.

Cell View is a .xla file (CellView.xla). Put it in your add-ins folder and load it via Tools/Add-Ins…

…mrt

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

Off topic: Facebook Social Engineering?

I’m not a member of Facebook. I was recently invited to join by email from a man I don’t know. His subject for the email was “Check out my photos on Facebook.” The stranger included inside his email pictures of eight individuals and one couple. Of the 10 people, 2 are college classmates, one was a member of a class I taught, one is a relation of my late wife’s, one was her best friend, one is a local vendor, and the couple are neighbors. Two I didn’t recognize.

The common link appears to be me (probably my home email account), but I don’t know the sender, and neither did my college classmates nor my wife’s cousin. Appealing to the collective DDoE wisdom, how might the connection have been made? And how concerned need I be about this social engineering?

And though I’ve otherwise thought about it, I’ve not joined up.

…mrt

33 Miners

The CNN banner said “21st Miner Rescued.” To be on topic, I wondered how Excel might automate that. You need a simple algorithm that checks the count mod 10 and the count mod 100. If i mod 10 = 1 and i mod 100 <> 11 then the appropriate suffix for i is “st”. Similar analyses work for i mod 10 = 2 and i mod 10 = 3. For all other cases (4, 11, 12, 13, 14, etc) the suffix is “th.” If you take control of the status bar, it looks like this.

Sub Miners()
   Dim i As Long
   Dim suffix As String
   
   Application.DisplayStatusBar = True
   For i = 1 To 33
      If i Mod 10 = 1 And i Mod 100 <> 11 Then
         suffix = “st “
      ElseIf i Mod 10 = 2 And i Mod 100 <> 12 Then
         suffix = “nd “
      ElseIf i Mod 10 = 3 And i Mod 100 <> 13 Then
         suffix = “rd “
      Else
         suffix = “th “
      End If
      Application.StatusBar = i & suffix & “miner rescued!”
      Wait (0.8)
   Next i
End Sub

Sub Wait(t As Single)
   Dim sTime As Single
   sTime = Timer + t
   Do While Timer < sTime
   Loop
End Sub

 
That’s enough on topic. Here’s a loud cheer for the NASA system engineers the spec’d out the capsule, and another one for the Chilean navy that built it.

 
…mrt