' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Option Explicit
Option Compare Text
Private Const projectUDFName = "LockCells"
Private Const projectUDFFileName = "LockCells"
Private Const projectUDFVersion = "1.0"
#If VBA7 = 0 Then
Public Enum LongLong:[_]:End Enum
Public 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 LongLong, 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 Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) 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
Public Enum ValueLockSettings
VDSLockRange = 1
End Enum
Public Type TypeArguments
Action As Long
direction As Long
timer As Single
ThisCell As Object
Fx As String
Target As Range
address As String
value As Variant
SheetPW As String
End Type
Private Const n_ = vbNullString
Private Works() As TypeArguments
Function LockCells_(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
LockCells_ = ""
End Function
Function LockCells(ByVal cells As Range, Optional ByVal sheetPassword$, Optional ByVal DelaySeconds&)
LockCells = ""
Call LockValueCommand(VDSLockRange, cells, sheetPassword, DelaySeconds)
End Function
Private Function LockValueCommand(direction&, ParamArray arguments())
On Error Resume Next
Dim r As Object
Set r = Application.ThisCell: If r Is Nothing Then Exit Function
Dim k%, i%, j%, adr$, f$, w As TypeArguments, n As Boolean
f = r.formula
adr = r.address(0, 0,,1)
k = UBound(Works): k = k + 1: ReDim Preserve Works(1 To k)
adr:
With Works(k): .Action = 1: Set .ThisCell = r: .address = adr: .Fx = f
.direction = direction: .timer = timer
Select Case direction
Case VDSLockRange:: Set .Target = arguments(0): .SheetPW = arguments(1)
End Select
Call LockValue_Timer(arguments(2) * 1000)
End With
End Function
Private Sub LockValue_Timer(Optional ByVal timer&)
If timer < 0 Then timer = 0
Call SetTimer(Application.hwnd, 444110, timer, AddressOf LockValue_callback)
End Sub
Private Sub LockValue_callback(ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
On Error Resume Next
Call KillTimer(hwnd, idEvent)
LockValue_working
End Sub
Private Sub LockValue_working()
On Error Resume Next
Dim aa, UA%, i%, Sh As Object, w, lr&, rg, rg2 As Object
Dim a As Object, b As TypeArguments, su As Boolean, ac As Boolean, ee As Boolean
UA = UBound(Works)
If UA = 0 Then Exit Sub
For i = 1 To UA
b = Works(i)
With Works(i)
Select Case .Action
Case 1
.Action = 2
'GoSub a
Set Sh = .Target.Parent
If Sh.ProtectContents Then
Err.Clear: Sh.Unprotect password:=.SheetPW: If Err Then GoTo n
End If
.ThisCell.FormulaHidden = True
.ThisCell.Locked = True
Select Case .direction
Case VDSLockRange:
.Target.FormulaHidden = True
.Target.Locked = True
Err.Clear: Set rg2 = .Target.SpecialCells(xlCellTypeBlanks)
If Not rg2 Is Nothing And Err = 0 Then rg2.Locked = False: rg2.FormulaHidden = False
End Select
s:
If Not Sh.ProtectContents Then Sh.Protect password:=.SheetPW
End Select
End With
n:
Next
E:
Erase Works
If Not a Is Nothing Then
If su And a.ScreenUpdating <> su Then a.ScreenUpdating = su
If ac And a.Calculation <> xlCalculationAutomatic Then a.Calculation = xlCalculationAutomatic
If ee And a.EnableEvents <> ee Then a.EnableEvents = ee
End If
Exit Sub
a:
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
Return
End Sub
(. Mình dò mãi mà chưa tìm được nguyên nhân. Nhờ bạn xem giúp mình với. đây là đoạn code bạn ktra dùm mình xem nó bị gì.Mình cảm ơn
