Code wanted!

**mvidas** · 12-22-2005, 10:33 AM

Thanks to PatrickAB who posted this question at EE, I thought I might share the same idea here

Similar code to this is posted at that thread, but I purposely didn't finish part of it as a joke. I thought I might post my finished product here as a holiday treat for everyone, and to get everyone else's versions as well! If you're sitting at work and dont feel like actually working for a little while (as many people are at this time), its a great way to spend time and hone your excel skills as well

Anywho, heres my version, I look forward to seeing more!

Option Explicit
Public Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal _
 nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal _
 nIDEvent As Long) As Long
Public TimerColl As Collection
Public Colrs As Collection
Public PowerOn As Boolean
Public Settings() As Boolean

Sub PatrickChristmas()
 Dim i As Long, j As Long, TreeColl As Collection
 Dim SG3 As String, SG1 As String, SG2 As String, StarColl As Collection
 Dim Tree As String, Pot As String, Trunk As String, Garland As String
 Dim SG4 As String, CLL As Range, Star As String, Rng
 Application.ScreenUpdating = False
 i = Application.SheetsInNewWorkbook
 Application.SheetsInNewWorkbook = 1
 Workbooks.Add
 Application.SheetsInNewWorkbook = i
 With ActiveWindow
  .DisplayGridlines = False
  .DisplayHeadings = False
  .DisplayHorizontalScrollBar = False
  .DisplayVerticalScrollBar = False
  .DisplayWorkbookTabs = False
 End With
 ReDim Settings(2)
 Settings(0) = Application.DisplayFormulaBar
 Settings(1) = Application.DisplayStatusBar
 Settings(2) = Application.DisplayFullScreen
 Application.DisplayFullScreen = True
 Application.DisplayFormulaBar = False
 Application.DisplayStatusBar = False
 Set TreeColl = New Collection
 Set TimerColl = New Collection
 Set StarColl = New Collection
 Set Colrs = New Collection
 Columns.ColumnWidth = 0.5
 Cells.Interior.ColorIndex = 3
 Trunk = "AC31:AE33"
 Pot = "Y34:AI34,Z35:AH35,AA36:AG36"
 Star = "AC3:AE3,Z4:AH4,AB5:AF5,AA6:AB6,AD6,AF6:AG6"
 Tree = "AC7:AE7,AB8:AF8,AA9:AG9,Z10:AH10,Y11:AI11,X12:AJ12,W13:AK13," & _
  "V14:AL14,U15:AM15,T16:AN16,S17:AO17,R18:AP18,Q19:AQ19,P20:AR20,O21" & _
  ":AS21,N22:AT22,M23:AU23,L24:AV24,K25:AW25,J26:AX26,I27:AY27,H28:AZ" & _
  "28,G29:BA29,F30:BB30"
 SG1 = "AS6:BD6,BG6:BR6,BW6:CD6,CI6:CT6,CW6:DH6,DK6:DN6,EC6:EN6,DN7:D" & _
  "O7,DY6:DZ7,BV7:BW8,CD7:CE8,DO8:DP8,DU6:DV8,EC7:ED8,AS7:AT9,AU9:BD9" & _
  ",BG7:BH9,BI9:BR9,BU9:CF9,CI7:CJ9,CK9:CT9,CW7:CX9,DG7:DH9,DK7:DL9,D" & _
  "P9:DQ9,DU9"
 SG2 = "DV9,EC9:EN9,DQ10:DR10,BC10:BD11,CS10:CT11,DG10:DH11,DR11:DS11" & _
  ",DU10:DV11,EM10:EN11,AS12:BD12,BG10:BH12,BI12:BR12,BU10:BV12,CE10:" & _
  "CF12,CI12:CT12,CW10:CX12,CY12:DH12,DK10:DL12,DS12:DV12,EC12:EN12,A" & _
  "W15:BH15,BK15:BT15,BY15:CJ15,CM15:CX15,DA15:DL15,DO15"
 SG3 = "DP15,DS15:DV15,EG15:ER15,EU15:FF15,BT16:BU16,DV16:DW16,BS17:B" & _
  "T17,DW17:DX17,AW16:AX18,BB18:BH18,BK16:BL18,BM18:BS18,BY16:BZ18,CA" & _
  "18:CJ18,CM16:CN18,CO18:CX18,DF16:DG18,DO16:DP18,DS16:DT18,DX18:DY1" & _
  "8,EC15:ED18,EG16:EH18,EL18:ER18,EU16:EV18,EW18:FF18,AW19"
 SG4 = "AX19,BS19:BT19,DY19:DZ19,BG19:BH20,BT20:BU20,DZ20:EA20,EC19:E" & _
  "D20,EQ19:ER20,FE19:FF20,AW20:AX21,AY21:BH21,BK19:BL21,BU21:BV21,BY" & _
  "19:BZ21,CA21:CJ21,CM19:CN21,CO21:CX21,DF19:DG21,DO19:DP21,DS19:DT2" & _
  "1,EA21:ED21,EG19:EH21,EI21:ER21,EU21:FF21"
 Garland = "AE9:AG9,AB10:AE10,Y11:AB11,AI13:AK13,AD14:AI14,Y15:AD15,T" & _
  "16:Y16,AL18:AP18,AF19:AL19,X20:AF20,O21:X21,AL23:AU23,AB24:AL24,R2" & _
  "5:AB25,J26:R26,AO28:AZ28,AG29:AO29,AB30:AG30"
 For Each CLL In Range(Tree).Cells
  TreeColl.Add CLL.Address
 Next
 ColorACell Trunk, 12
 ColorACell Pot, 51
 Range(Pot).BorderAround 1, 4, 1
 ColorACell Star, 27
 ColorACell Tree, 10
 ColorACell SG1, 50
 ColorACell SG2, 50
 ColorACell SG3, 50
 ColorACell SG4, 50
 For i = 1 To TreeColl.Count * 2
  Randomize Rnd() * 1389245743
  j = Int(Rnd() * TreeColl.Count + 1)
  ColorACell TreeColl(j), 4
 Next
 ColorACell Garland, 28
 With Range(Garland).Interior
  .Pattern = xlCrissCross
  .PatternColorIndex = 48
 End With
 For Each CLL In Range(Star).Cells
  StarColl.Add CLL.Address
 Next
 For Each Rng In Array(Trunk, Pot, Star, Tree, SG1, SG2)
  For Each CLL In Range(Rng).Cells
   Colrs.Add CLL.Interior.ColorIndex, CLL.Address
  Next
 Next
 Application.ScreenUpdating = True
 SetTimer 0&, 0&, 1&, AddressOf StartBlinking
 With ActiveSheet.Buttons.Add(310.5, 353.25, 133.5, 41.25)
  .OnAction = ThisWorkbook.Name & "!StartTheBlinking"
  .Characters.Text = "Plug In Lights"
 End With
 With ActiveSheet.Buttons.Add(465, 353.25, 133.5, 41.25)
  .OnAction = ThisWorkbook.Name & "!StopTheBlinking"
  .Characters.Text = "Unplug lights"
 End With
End Sub

Function StartBlinking(Optional ByVal uMsg As Long, Optional ByVal nIDEvent As Long, _
 Optional ByVal dwTimer As Long)
 EndATimer nIDEvent
 Dim TreeColl As Collection, StarColl As Collection, i As Long
 Dim Tree As String, Star As String, CLL As Range
 Star = "AC3:AE3,Z4:AH4,AB5:AF5,AA6:AB6,AD6,AF6:AG6"
 Tree = "AC7:AE7,AB8:AF8,AA9:AG9,Z10:AH10,Y11:AI11,X12:AJ12,W13:AK13," & _
  "V14:AL14,U15:AM15,T16:AN16,S17:AO17,R18:AP18,Q19:AQ19,P20:AR20,O21" & _
  ":AS21,N22:AT22,M23:AU23,L24:AV24,K25:AW25,J26:AX26,I27:AY27,H28:AZ" & _
  "28,G29:BA29,F30:BB30"
 Set TreeColl = New Collection
 Set StarColl = New Collection
 For Each CLL In Range(Tree).Cells
  TreeColl.Add CLL.Address
 Next
 For Each CLL In Range(Star).Cells
  StarColl.Add CLL.Address
 Next
 If Colrs Is Nothing Then
  Set Colrs = New Collection
  For Each CLL In Range(Tree).Cells
   Colrs.Add CLL.Interior.ColorIndex, CLL.Address
  Next
  For Each CLL In Range(Star).Cells
   Colrs.Add CLL.Interior.ColorIndex, CLL.Address
  Next
 End If
 PowerOn = True
 Do Until Not PowerOn
  Randomize Rnd() * 46783456
  i = Int(Rnd() * StarColl.Count + 1)
  BlinkACell StarColl(i), 36, 2
  i = Int(Rnd() * TreeColl.Count + 1)
  BlinkACell TreeColl(i), 2, 32, 53
  i = Int(Rnd() * StarColl.Count + 1)
  BlinkACell StarColl(i), 36, 2
  For i = 1 To 50
   DoEvents
  Next
 Loop
End Function

Function StopBlinking(Optional ByVal uMsg As Long, Optional ByVal nIDEvent As Long, _
 Optional ByVal dwTimer As Long)
 Dim i As Long
 EndATimer nIDEvent
 PowerOn = False
 On Error Resume Next
 Application.DisplayFormulaBar = Settings(0)
 Application.DisplayStatusBar = Settings(1)
 Application.DisplayFullScreen = Settings(2)
End Function

Function BlinkACell(ByVal CellAddr As String, ByVal FColor As Long, ByVal _
 SColor As Long, Optional ByVal TColor As Long) As Boolean
 Dim TimerID As Long
 If TColor = 0 Then TColor = FColor
 ColorACell CellAddr, FColor
 TimerID = SetTimer(0&, 0&, 500&, AddressOf mStep1)
 If TimerColl Is Nothing Then Set TimerColl = New Collection
 TimerColl.Add Array(CellAddr, SColor, TColor), CStr(TimerID)
End Function

Sub mStep1(ByVal HWnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, _
 ByVal dwTimer As Long)
 Dim TimerID As Long
 ColorACell TimerColl(CStr(nIDEvent))(0), TimerColl(CStr(nIDEvent))(1)
 TimerID = SetTimer(0&, 0&, 1000&, AddressOf mStep2)
 TimerColl.Add Array(TimerColl(CStr(nIDEvent))(0), TimerColl(CStr(nIDEvent) _
  )(2)), CStr(TimerID)
 EndATimer nIDEvent
End Sub

Sub mStep2(ByVal HWnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, _
 ByVal dwTimer As Long)
 Dim TimerID As Long
 ColorACell TimerColl(CStr(nIDEvent))(0), TimerColl(CStr(nIDEvent))(1)
 TimerID = SetTimer(0&, 0&, 500&, AddressOf mStep3)
 TimerColl.Add TimerColl(CStr(nIDEvent))(0), CStr(TimerID)
 EndATimer nIDEvent
End Sub

Sub mStep3(ByVal HWnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, _
 ByVal dwTimer As Long)
 Dim TimerID As Long
 ColorACell TimerColl(CStr(nIDEvent)), Colrs(TimerColl(CStr(nIDEvent)))
 EndATimer nIDEvent
End Sub

Function EndATimer(ByVal ATimerID As Long) As Boolean
 On Error Resume Next
 KillTimer 0&, ATimerID
 TimerColl.Remove CStr(ATimerID)
End Function
Function ColorACell(ByVal CellAddrs As String, ByVal TheIndex As Long) As Boolean
 On Error Resume Next
 Range(CellAddrs).Interior.ColorIndex = TheIndex
End Function

Sub StartTheBlinking()
 StartBlinking
End Sub

Sub StopTheBlinking()
 StopBlinking
End Sub

Warning: don't stop the macro once the bulbs or star are flashing! If you do, say goodbye to that excel instance!

Happy holidays everyone!
Matt

**lucas** · 12-22-2005, 12:34 PM

Thats pretty interesting Matt. I like it.

**lucas** · 12-22-2005, 12:44 PM

I'm workin on it.....but I'm old and slow

Thread: Code wanted!

Thread Tools

Display

Code wanted!

Posting Permissions