' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Option Explicit
Option Compare Text
Private Const ProjectUDFName = "FormatHandleXL"
Private Const ProjectUDFFileName = "FormatHandle"
Private Const projectUDFVersion = "1.0"
Private Enum UDFCommandDirection
UCDFormatCustom
End Enum
Private Type TypeArguments
OnUndo As Boolean
timer As Single
Action As Long
Direction As Long
Target As Variant
address As String
caller As Range
formula As String
format As String
End Type
#If 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 Works() As TypeArguments
'-------------------------------------------------------------------------------------------------------
Function FMCustom(Optional ByVal Cells, Optional formatString$ = vbNullChar) As Variant
FMCustom = "[Format]"
Call AddArgumentsFilter(UCDFormatCustom, Cells, formatString)
End Function
Private Function AddArgumentsFilter(Direction&, ParamArray arguments())
On Error Resume Next
Dim k%, i%, j%, r As Object, s$, f$
Set r = Application.ThisCell: If r Is Nothing Then Exit Function
f = r.formula
s = r.address(0, 0, , 1)
k = UBound(Works):
k = k + 1
ReDim Preserve Works(1 To k)
With Works(k): .Action = 1: .OnUndo = True: .Direction = 0: Set .caller = r: .address = s: .formula = f
End With
s:
With Works(k)
.Direction = Direction
Select Case Direction
Case UCDFormatCustom:
Select Case TypeName(arguments(0))
Case "Range": Set .Target = arguments(0): .format = arguments(1):
Case "Error": .format = vbNullChar
Case Else: .format = arguments(0)
End Select
.Action = 2: .timer = timer:
Call createProcTimer(True)
End Select
End With
End Function
''///////////////////////////////////////////////////////
Private Sub createProcTimer(first As Boolean)
Call SetTimer(Application.Hwnd, 541112 + first, 100, AddressOf S_FormatCustom_callback)
End Sub
#If VBA7 And Win64 Then
Private Sub S_FormatCustom_callback(ByVal Hwnd^, ByVal uMsg&, ByVal nIDEvent&, ByVal dwTimer&)
#Else
Private Sub S_FormatCustom_callback(ByVal Hwnd&, ByVal uMsg&, ByVal nIDEvent&, ByVal dwTimer&)
#End If
On Error Resume Next
Call KillTimer(Hwnd, nIDEvent)
Select Case nIDEvent
Case 541111: S_FormatCustom_working True
Case 541112: S_FormatCustom_working False
End Select
End Sub
Private Sub S_FormatCustom_working(first As Boolean)
On Error Resume Next
Dim ub%, a As Object, b As TypeArguments, o, sh, f$, i&, cfl%, su As Boolean, ac As Boolean, ee As Boolean, rg As Range
ub = UBound(Works)
Debug.Print "S_FormatCustom_working", timer
For i = 1 To ub
b = Works(i)
If a Is Nothing Then
Set a = Application
'su = a.ScreenUpdating: If su Then a.ScreenUpdating = False
'ee = a.EnableEvents: If ee Then a.EnableEvents = False
'ac = a.Calculation = xlCalculationAutomatic: If ac Then a.Calculation = xlCalculationManual
End If
Select Case b.Action
Case 2: Works(i).Action = 3
Set rg = b.Target
Err.Clear
If rg Is Nothing Then Set rg = Selection
If Err = 0 Then
Set Works(i).Target = rg
Select Case b.Direction
Case UCDFormatCustom: SendKeys "^z", False: GoTo E
End Select
End If
Case 3:
Set rg = b.Target
If Not rg Is Nothing Then
Select Case b.Direction
Case UCDFormatCustom:
rg.NumberFormat = IIf(b.format = vbNullChar, "General", b.format): GoTo E
End Select
End If
End Select
n:
Next
E:
If first Then
createProcTimer False
Else
Erase Works
End If
If Not a Is Nothing Then
'If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
'If ee And a.EnableEvents <> ee Then a.EnableEvents = ee
'If ac And xlCalculationAutomatic <> a.Calculation Then a.Calculation = ac
End If
End Sub
