mvidas
12-22-2005, 10:33 AM
Thanks to PatrickAB who posted this question at EE (http://www.experts-exchange.com/Applications/MS_Office/Excel/Q_21672197.html), I thought I might share the same idea here http://vbaexpress.com/forum/images/smilies/001.gif 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 http://vbaexpress.com/forum/images/smilies/001.gif
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
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