Option Explicit
Option Compare Text
#If VBA7 = 0 Then
Private Enum LongLong:[_]:End Enum
Private Enum LongPtr:[_]:End Enum
#End If
#If -VBA7 And -Win64 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
Private Type TypeArguments
Action As Long
Timer As Single
ThisCell As Object
addr As String
Fx As String
RSTarget As Range
color1 As Long
color2 As Long
delay As Single
Timer2 As Single
Timer3 As Single
FlickBackground As Boolean
BGNone As Boolean
DisplayColor1 As Long
DisplayColor2 As Long
NumberFormat As String
ColorFormat As String
FormatCondition As Object
End Type
Private Works() As TypeArguments, cltWorks As Collection
Private Sub FlickTest()
On Error Resume Next
Static b%: b = b + 1
Select Case b Mod 3
Case 0: [D2].Resize(3).value = 0
Case 1: [D2].Resize(3).value = -1
Case 2: [D2].Resize(3).value = 1
End Select
Cells.SpecialCells(xlCellTypeFormulas).Dirty
End Sub
Function Flick(value As Variant, Optional Color = vbRed, Optional times& = 5, Optional delaytime& = 250, Optional FlickBackground As Boolean)
Flick = value
On Error Resume Next
Dim r As Object, k%, j&, f$, s$, n As Boolean, vs&, a
Set r = Application.caller: f = r.Formula: s = r.Address(0, 0, , 1)
If r Is Nothing Then Exit Function
If cltWorks Is Nothing Then
Set cltWorks = New Collection: GoSub ne
Else
k = cltWorks(s): If k = 0 Then GoSub ne Else Exit Function
End If
times = IIf(times < 1, 1, IIf(times > 20, 20, times))
delaytime = IIf(delaytime < 200, 200, IIf(delaytime > 2000, 2000, delaytime))
With Works(k)
If FlickBackground Then .color1 = r.Interior.Color Else .color1 = r.Font.Color
.delay = delaytime / 1000
.Timer2 = Timer
.Timer3 = Timer + (times + 3) * .delay + 0.5
.FlickBackground = FlickBackground
Color = Localize_SetColor(Color)
.color2 = IIf(.color1 = Color, vbGreen, Color)
End With
SetTimer Application.hwnd, 55126126, 50, AddressOf Flick_Working
E:
Exit Function
ne:
k = UBound(Works): k = k + 1: ReDim Preserve Works(1 To k): cltWorks.Add k, s
With Works(k): .Action = 1: Set .ThisCell = r: .addr = s: .Fx = f: .Timer = Timer:
End With
Return
End Function
Private Function colorInNumberFormat(ByVal NumberFormat$, ByVal colorIndex%) As String
Dim a, i%, j%, k%, l%, s$, d%, v$
a = Array("[Black]", "[White]", "[Red]", "[Green]", "[Blue]", "[Yellow]", "[Cyan]", "[Magenta]")
For i = -7 To 56
If i <= 0 Then
s = a(i + 7): GoSub a
Else
s = "[Color " & i & "]": GoSub a
End If
Next
Exit Function
a:
k = InStr(1, NumberFormat, s, 1)
If k Then
If colorIndex = i Then
l = Len(NumberFormat)
For i = k + Len(s) To l
v = Mid$(NumberFormat, i, 1)
Select Case d
Case 0:
Select Case v
Case "[": d = 1
Case Else: d = 2: j = i: If i = l Then colorInNumberFormat = Mid$(NumberFormat, i): Exit Function
End Select
Case 1: If v = "]" Then d = 2: j = i + 1
Case 2:
If v = ";" Or i = l Then
l = IIf(v = ";", i - j, l - j + 1)
colorInNumberFormat = Mid$(NumberFormat, j, l): Exit Function
End If
End Select
Next
End If
End If
Return
End Function
Private Sub Flick_Working(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
On Error Resume Next
Dim i, k%, ash As Object, b As TypeArguments, n As Boolean, c&, r As Range, s$
Dim fm As FormatCondition
Set ash = Application.ActiveSheet
For Each i In cltWorks
With Works(i): b = Works(i)
Select Case .Action
Case 1, 2: n = True: Set r = .ThisCell
If .Action = 1 Then
.Action = 2
.BGNone = r.DisplayFormat.Interior.Pattern = xlNone
.DisplayColor1 = r.DisplayFormat.Font.Color
.DisplayColor2 = r.DisplayFormat.Interior.Color
s = r.NumberFormat: .NumberFormat = s:
If s Like "*[[]*]*" Then
s = colorInNumberFormat(s, r.DisplayFormat.Font.colorIndex)
If s <> "" Then .ColorFormat = s:
End If
If .ColorFormat = "" Then
For Each fm In r.FormatConditions
If .FlickBackground Then
Err.Clear: c = fm.Interior.Color
If Err = 0 Then If c = .DisplayColor2 Then Set .FormatCondition = fm: .color1 = c: Exit For
Else
Err.Clear: c = fm.Font.Color
If Err = 0 Then If c = .DisplayColor1 Then Set .FormatCondition = fm: .color1 = c: Exit For
End If
Next
If Not .FormatCondition Is Nothing Then .BGNone = .FormatCondition.Interior.Pattern = xlNone
End If
End If
DoEvents
If ash Is r.Parent Then
If Timer >= .Timer2 Then
.Timer2 = .Timer2 + .delay
If .ColorFormat <> "" And Not .FlickBackground Then
r.NumberFormat = IIf(r.NumberFormat = .ColorFormat, .NumberFormat, .ColorFormat)
Else
If .FormatCondition Is Nothing Then
If .FlickBackground Then
With r.Interior
.Color = IIf(.Color = b.color1, b.color2, b.color1)
End With
Else
With r.Font
.Color = IIf(.Color = b.color1, b.color2, b.color1)
End With
End If
Else
If .FlickBackground Then
With .FormatCondition.Interior
.Color = IIf(.Color = b.color1, b.color2, b.color1)
End With
Else
Err.Clear
With .FormatCondition.Font
.Color = IIf(.Color = b.color1, b.color2, b.color1)
End With
End If
End If
End If
End If
Else
GoTo r
End If
If Timer > .Timer3 Then
r:
.Action = 3:
If .ColorFormat <> "" And Not .FlickBackground Then
r.NumberFormat = .NumberFormat
Else
If .FormatCondition Is Nothing Then
If .FlickBackground Then
If .BGNone Then
r.Interior.Pattern = xlNone
Else
r.Interior.Color = b.color1
End If
Else
r.Font.Color = b.color1
End If
Else
If .FlickBackground Then
If .BGNone Then
.FormatCondition.Interior.Pattern = xlNone
Else
.FormatCondition.Interior.Color = b.color1
End If
Else
.FormatCondition.Font.Color = b.color1
End If
End If
End If
End If
End Select
End With
Next
E:
If Not n Then
Set cltWorks = Nothing
Erase Works
KillTimer hwnd, idEvent
End If
End Sub
Sub colors56()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim str0 As String, str As String
For i = 1 To 55
Cells(i, 1).Interior.colorIndex = i
Cells(i, 1).value = "[Color " & i & "]"
Cells(i, 2).Font.colorIndex = i
Cells(i, 2).value = "[Color " & i & "]"
str0 = Right("000000" & Hex(Cells(i, 1).Interior.Color), 6)
str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
Cells(i, 3) = "#" & str
Cells(i, 4).Formula = "=Hex2dec(""" & Right(str0, 2) & """)"
Cells(i, 5).Formula = "=Hex2dec(""" & Mid(str0, 3, 2) & """)"
Cells(i, 6).Formula = "=Hex2dec(""" & Left(str0, 2) & """)"
Cells(i, 7) = "[Color " & i & "]"
Next i
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Private Function Localize_SetColor(ByVal Color As String) As Long
Dim v As Long
Select Case Color
Case "yellow", "ye", "yl": v = vbYellow
Case "red", "re": v = vbRed
Case "blue": v = vbBlue
Case "green", "gr": v = vbGreen
Case "cyan", "cy": v = vbCyan
Case "magenta", "ma": v = vbMagenta
Case "white", "wh", "wi": v = vbWhite
Case "black", "bl", "bk": v = vbBlack
Case "orange", "or": v = &H71AFFF
Case "pink": v = &HE819E8
Case "purple", "pu": v = &HB44343
Case "silver", "si": v = &HCBCBCB
Case "violet", "vi": v = &HF5A2BF
Case "Brown", "br": v = &H3232AA
Case "Beige", "be": v = &HE819E8
Case Else
Select Case True
Case Color Like "*[a-fA-F]*"
If Color Like "[#]*" Then Color = Mid(Color, 2)
Color = Mid(Color, 5, 2) & Mid(Color, 3, 2) & Mid(Color, 1, 2)
v = CLng(IIf(Color Like "&H*", "", "&H") & Color)
Case IsNumeric(Color): v = CLng(Color)
Case Else: v = vbBlue
End Select
End Select
Localize_SetColor = v
End Function