Public Sub ShowSevenSegment(ByVal lInput As Long)
Dim sValue As String
Dim i As Long, j As Long
Dim aDigits(0 To 9) As Variant
Dim aRange() As String
Dim aRow(0 To 6) As Long, aCol(0 To 6) As Long
Dim rSeg As Range
Const lDISPCNT As Long = 4
Const lON As Long = vbBlack
Const lOFF As Long = vbWhite
'Hold the top left cell for each display
ReDim aRange(1 To lDISPCNT)
'Set the on/off for each digit. The order is top, left top,
'right top, middle, left bottom, right bottom, bottom
aDigits(0) = Array(lON, lON, lON, lOFF, lON, lON, lON)
aDigits(1) = Array(lOFF, lOFF, lON, lOFF, lOFF, lON, lOFF)
aDigits(2) = Array(lON, lOFF, lON, lON, lON, lOFF, lON)
aDigits(3) = Array(lON, lOFF, lON, lON, lOFF, lON, lON)
aDigits(4) = Array(lOFF, lON, lON, lON, lOFF, lON, lOFF)
aDigits(5) = Array(lON, lON, lOFF, lON, lOFF, lON, lON)
aDigits(6) = Array(lON, lON, lOFF, lON, lON, lON, lON)
aDigits(7) = Array(lON, lOFF, lON, lOFF, lOFF, lON, lOFF)
aDigits(8) = Array(lON, lON, lON, lON, lON, lON, lON)
aDigits(9) = Array(lON, lON, lON, lON, lOFF, lON, lON)
'Set the offset from the top left cell for each of the
'seven segments
aRow(0) = 0: aCol(0) = 1
aRow(1) = 1: aCol(1) = 0
aRow(2) = 1: aCol(2) = 2
aRow(3) = 2: aCol(3) = 1
aRow(4) = 3: aCol(4) = 0
aRow(5) = 3: aCol(5) = 2
aRow(6) = 4: aCol(6) = 1
'Set the top left cell for each display
For i = 1 To lDISPCNT
aRange(i) = Sheet1.Range("B2").Offset(0, (i - 1) * 4).Address
Next i
'Truncate and pad the value as necessary
If lInput > (10 ^ lDISPCNT) - 1 Then
sValue = Left$(lInput, lDISPCNT)
Else
sValue = Format(lInput, String(lDISPCNT, "0"))
End If
'Clear everything
Sheet1.Range(aRange(1)).Resize(5, 15).Interior.Color = lOFF
'Loop though the digits
For i = 1 To Len(sValue)
'Loop through the on/offs for that digit
For j = LBound(aDigits(CLng(Mid$(sValue, i, 1)))) To UBound(aDigits(CLng(Mid$(sValue, i, 1))))
'get the segment range and set the color
Set rSeg = Sheet1.Range(aRange(i)).Offset(aRow(j), aCol(j))
rSeg.Interior.Color = aDigits(CLng(Mid$(sValue, i, 1)))(j)
'color the corners
If aDigits(CLng(Mid$(sValue, i, 1)))(j) = lON Then
'for horizontal segments, fill left and right
If rSeg.Width > rSeg.Height Then
rSeg.Offset(0, -1).Interior.Color = lON
rSeg.Offset(0, 1).Interior.Color = lON
Else
'for vertical segments, fill up and down
rSeg.Offset(-1, 0).Interior.Color = lON
rSeg.Offset(1, 0).Interior.Color = lON
End If
End If
Next j
Next i
End Sub