|
Sunday, October 18, 2009 - 1:00 PM
Excel and programming aren't all about crunching numbers and making money (for your company). Sometimes the best way to learn is to try something amusing. Paste this code into the ThisWorkbook object of a blank workbook, save and close the workbook, and then re-open it or send it to someone else. You can also make it your own by changing the behavior. For example, try changing the way colors are assigned, or try a normally distributed scalar in place of the rnd() function, or make the code reveal an underlying image instead of creating an image directly.
Option Explicit
Option Base 1
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Cells.ClearFormats
End Sub
Private Sub Workbook_Open()
FunColors
End Sub
'similar algo that does (groups of) rows/columns, with transparency 'try to constrain colors in ways that create good combinations
'more global randomization so each painting is unique
Private Sub FunColors()
Dim i&, j&, k&, x As Byte, y As Byte, n As Byte, r&, c&, Rp&, Cp&, maxC&, maxR&, Scalar As Double: r = 2: c = 2
Dim MaxColor&(3), MinColor&(3), cRGB(2, 3) As Byte, BSLen&, Radius As Byte, Dev As Byte, tempInt&
On Error Resume Next
With ActiveWindow
.Zoom = 40: .DisplayGridlines = False: .DisplayWorkbookTabs = False
.DisplayHorizontalScrollBar = False: .DisplayVerticalScrollBar = False
Scalar = 5.25: maxR = .UsableHeight / Scalar: maxC = .UsableWidth / Scalar
End With
With Cells
.ClearFormats: .ColumnWidth = 1.71: .RowHeight = 12.75
End With
With Application
For i = Sheets.Count To 2 Step -1 'it's not important to delete the extra sheets since sheet tabs are hidden, but why not
.DisplayAlerts = False: Sheets(i).Delete: .DisplayAlerts = True
Next
Rows(1).Hidden = True: Columns(1).Hidden = True
.Goto Cells(1, 1), True
MsgBox ("Hit the Escape key and click End to stop code execution.")
.ScreenUpdating = False
Randomize 'Rnd() won't really be random without this
For i = 1 To 1000
For k = 1 To 3
MaxColor(k) = Int(256 * Rnd())
MinColor(k) = Int(256 * Rnd())
If (Abs(MinColor(k) - MaxColor(k)) = 0) Then
MinColor(k) = .Max(MinColor(k) - 10, 0): MinColor(k) = .Min(MaxColor(k) + 10, 256)
ElseIf (MinColor(k) > MaxColor(k)) Then
tempInt = MinColor(k): MinColor(k) = MaxColor(k): MaxColor(k) = tempInt
End If
Next
BSLen = Int(500 * Rnd()) + 50
Radius = Int(15 * Rnd()) + 2
' Dev = 2 * (10 * Rnd()) \ 1
r = Int(maxR * Rnd())
c = Int(maxC * Rnd())
For j = 1 To BSLen
' r = .Min(.Max(r + ((Dev * Rnd()) \ 1) - Dev / 2, 2), maxR)
' c = .Min(.Max(c + ((Dev * Rnd()) \ 1) - Dev / 2, 2), maxC)
r = .Min(.Max(r + ((4 * Rnd()) \ 1) - 2, 2), maxR)
c = .Min(.Max(c + ((4 * Rnd()) \ 1) - 2, 2), maxC)
' r = .Min(.Max(r + (Dev / 2) \ 1, 2), maxR)
' c = .Min(.Max(c + (Dev / 2) \ 1, 2), maxC)
For n = 1 To 3
cRGB(1, n) = CByte(Rnd() * (MaxColor(n) - MinColor(n) + 1)) + MinColor(n)
Next
For x = 1 To Radius + 1
Rp = r + Int(Radius * Rnd()): Cp = c + Int(Radius * Rnd())
tempInt = Cells(Rp, Cp).Interior.Color
For n = 1 To 3
cRGB(2, n) = Dither(cRGB(1, n), tempInt, n, x)
Next
Cells(Rp, Cp).Interior.Color = RGB(cRGB(2, 1), cRGB(2, 2), cRGB(2, 3))
Next
.ScreenUpdating = True: .ScreenUpdating = False
Next
Next
End With
End Sub
Private Function GetRGB(Color&, Channel As Byte) As Byte
Dim r&, g&, b&
Select Case Channel
Case 1
GetRGB = &HFF& And Color
Case 2
GetRGB = (&HFF00& And Color) \ 256
Case 3
GetRGB = (&HFF0000 And Color) \ 65536
End Select
End Function
Private Function Dither&(cRGB As Byte, Color&, Channel As Byte, Weight As Byte)
'(x * GetRGB(tempInt, n) + cRGB(1, n)) / (x + 1)
Dither = GetRGB(Color, Channel)
Dim tempInt&, i As Byte
'loop is to prevent overflow error
For i = 1 To Weight
tempInt = tempInt + Dither
Next
Dither = (tempInt + cRGB) / (Weight + 1)
End Function
'an older, much faster version: Private Sub FunColors1()
Dim i&, j&, k&, r&, c&, x&, maxC&, maxR&, Scalar As Double: r = 2: c = 2
Dim MaxColor&(3), MinColor&(3), cRGB(3) As Byte, BSLen&, tempInt&
With ActiveWindow
.Zoom = 40: .DisplayGridlines = False: .DisplayWorkbookTabs = False
.DisplayHorizontalScrollBar = False: .DisplayVerticalScrollBar = False
Scalar = 5.25: maxR = .UsableHeight / Scalar: maxC = .UsableWidth / Scalar
End With
With Cells
.ClearFormats: .ColumnWidth = 1.71: .RowHeight = 12.75
End With
For i = Sheets.Count To 2 Step -1
Sheets(i).Delete 'it's not important to delete the extra sheets since sheet tabs are hidden, but why not
Next
Rows(1).Hidden = True: Columns(1).Hidden = True
With Application
.Goto Cells(1, 1), True
MsgBox ("Hit the Escape key and click End to stop code execution.")
Randomize 'Rnd() won't really be random without this
r = Int(maxR * Rnd())
c = Int(maxC * Rnd())
For i = 1 To 1000
For k = 1 To 3
MaxColor(k) = Int(256 * Rnd())
MinColor(k) = Int(256 * Rnd())
If (Abs(MinColor(k) - MaxColor(k)) = 0) Then
MinColor(k) = .Max(MinColor(k) - 10, 0): MinColor(k) = .Min(MaxColor(k) + 10, 256)
ElseIf (MinColor(k) > MaxColor(k)) Then
tempInt = MinColor(k): MinColor(k) = MaxColor(k): MinColor(k) = tempInt
End If
Next
BSLen = Int((2500 - 500 + 1) * Rnd()) + 500
For j = 1 To BSLen
r = .Min(.Max(r + (2 * Rnd() \ 1) - 1, 2), maxR)
c = .Min(.Max(c + (2 * Rnd() \ 1) - 1, 2), maxC)
cRGB(1) = Int((MaxColor(1) - MinColor(1) + 1) * Rnd()) + MinColor(1)
cRGB(2) = Int((MaxColor(2) - MinColor(2) + 1) * Rnd()) + MinColor(2)
cRGB(3) = Int((MaxColor(3) - MinColor(3) + 1) * Rnd()) + MinColor(3)
Cells(r, c).Interior.Color = RGB(cRGB(1), cRGB(2), cRGB(3))
x = Timer
While (Timer - x < 0.01)
Wend
Next
Next
End With
End Sub
|