' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Private Const projectClassName = "EditorFormulas"
Private Const projectClassVersion = "1.03"
Option Compare Text
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Private Sub RemoveFXs_test()
Dim file$, dest$, FXs, sheets, ix%
' Vi tri
FXs = Array("ROUND", 1, 1, "ROUNDUP", 1, 1, "ROUNDDOWN", 1, 1)
' Hoac mang
FXs = Array("ROUND", [{1,3,5}], 1, "ROUNDUP", [{1,3,5}], 1, "ROUNDDOWN", [{1,3,5}], 1)
'
sheets = Array("Sheet1", "Sheet2", "Sheet3")
file = ThisWorkbook.Path & "\Test huy ROUND.xlsm"
dest = ""
MsgBox IIf(RemoveFXs(FXs, sheets, file, dest), "Thanh Cong!", "Ko thanh Cong!")
End Sub
Private Sub EditorFXInFXs_test2()
On Error Resume Next
Dim t!: t = timer
Dim s, rg0, rg, Cell, r0&, c0&, r&, c&, a As Range, b As Boolean, y As Boolean, f$, arr, FXs
' Vi tri
FXs = Array("ROUND", 1, 1, "ROUNDUP", 1, 1, "ROUNDDOWN", 1, 1)
' Hoac mang
FXs = Array("ROUND", [{1,3,5}], 1, "ROUNDUP", [{1,3,5}], 1, "ROUNDDOWN", [{1,3,5}], 1)
'
Set rg0 = ActiveSheet.UsedRange
Set rg = rg0.SpecialCells(-4123)
If rg Is Nothing Then Exit Sub
y = rg(1, 1).Formula2 <> ""
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
arr = rg0.Formula: r0 = rg0.Row - 1: c0 = rg0.column - 1
For Each Cell In rg
r = Cell.Row - r0: c = Cell.column - r0
arr(r, c) = EditorFXInFXs(arr(r, c), FXs)
Next
With rg0
If y Then .Formula2 = arr Else .Formula = arr
End With
Application.Calculation = xlCalculationAutomatic
ActiveSheet.Calculate
Debug.Print timer - t
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Function RemoveFXs(FXs, sheets, filename$, Optional ByVal destDirectories$, Optional overwrite As Boolean = True) As Boolean
On Error Resume Next
Dim file$, file2$, ix%, ex$
Dim s$, re As Object, oFile As Object, oFile2 As Object, oFolder As Object, b As Boolean, y As Boolean
Dim oSh, ms, ms2, FSO As Object, tPath, tPath2, fn$, p1$, p2$, p3$, sp$, sh
Dim it, m, FileName_Path, ZipFile, k&, extFile, ext$, fl%, shfXML$, xl_type&
Set re = glbRegex
Set FSO = glbFSO
Set oSh = glbShellA
'-----------------------------------------------
file = filename
Select Case True
Case file Like "*.xla": xl_type = 18: ext = ".xla": b = True
Case file Like "*.xlsb": xl_type = 50: ext = ".xlsb": b = True
Case file Like "*.xlsx": xl_type = 51: ext = ".xlsx"
Case file Like "*.xlsm": xl_type = 52: ext = ".xlsm"
Case file Like "*.xlam": xl_type = 55: ext = ".xlam"
Case file Like "*.xls": xl_type = 56: ext = ".xls": b = True
Case Else: Exit Function
End Select
If Not destDirectories Like "*[\/]" And destDirectories <> "" Then destDirectories = destDirectories & "\"
With FSO
Set oFile = .GetFile(file)
If oFile Is Nothing Then Exit Function
fn = oFile.Name
If b Then fn = Replace(fn, ext, ".xlsm", , , 1): ext = ".xlsm"
If destDirectories = "" Then destDirectories = oFile.ParentFolder.Path & "\": fn = "(RemoveFxs) " & fn
CreateFolder destDirectories, FSO
ZipFile = destDirectories & fn & ".zip"
file2 = destDirectories & fn
If overwrite Then .GetFile(file2).Delete
If b Then
With CreateObject("Excel.Application")
.EnableEvents = False
.DisplayAlerts = False
With .Workbooks.Open(filename:=file, UpdateLinks:=False, ReadOnly:=True)
.SaveAs ZipFile, 51: .Close False
End With
.Quit
End With
Else
.copyFile file, ZipFile, True
End If
tPath = Environ$("temp") & "\VBE\CopyAndModify\"
CreateFolder tPath & "worksheets\", FSO
err.Clear: DoEvents:
oSh.Namespace(CVar(tPath & "worksheets\")).movehere oSh.Namespace(CVar(ZipFile & "\xl\worksheets\")).items, 4 Or 16
re.Pattern = "<f>(.+?)</f>"
Set oFolder = .GetFolder(tPath & "worksheets\")
For Each oFile2 In oFolder.Files
DoEvents: y = False
With .OpenTextFile(oFile2.Path, 1, True, -2): s = .ReadAll(): Call .Close: End With
If IsArray(sheets) Then
For Each sh In sheets
If InStr(1, s, " codeName=""" & sh & """", 1) Then y = True
Next
Else
y = True
End If
If y Then
s = EditorFXsInFile(s, FXs, re)
With .OpenTextFile(oFile2.Path, 2, True, -2): Call .Write(s): Call .Close: End With
End If
Next
err.Clear
Dim ccc&: ccc = oSh.Namespace(CVar(tPath & "worksheets\")).items.Count
oSh.Namespace(CVar(ZipFile & "\xl")).copyhere oSh.Namespace(CVar(tPath & "worksheets\")), 4 Or 16
k = 0
Do While oSh.Namespace(ZipFile & "\xl\worksheets\") Is Nothing
DoEvents: Sleep 20
k = k + 1: If k > 20 Then Exit Do
Loop: k = 0
Do While oSh.Namespace(ZipFile & "\xl\worksheets\").items.Count = ccc
DoEvents: Sleep 20
k = k + 1: If k > 20 Then Exit Do
Loop
err.Clear
DoEvents: Sleep 200
.MoveFile ZipFile, file2
RemoveFXs = err = 0
.GetFolder(tPath).Delete
End With
E:
End Function
Sub removeAndDeleteFormulas()
Dim s$, FXs, re As Object
FXs = Array("ROUND", 1, 1, "ROUNDDOWN", 1, 1)
s = "a<f>=@ROUND(1,2)</f>b<f>=@ROUNDDOWN(1,2)</f>c"
Set re = glbRegex
Debug.Print EditorFXsInFile(s, FXs, re)
End Sub
Private Function EditorFXsInFile(ByVal xml$, FXs, Optional ByVal RegExp As Object) As String
Dim t$, s$, ms, m, f&, l&, fl&, z$
With RegExp
Set ms = .Execute(xml):
For Each m In ms
s = m.submatches(0): f = m.FirstIndex: l = m.Length
If z = "" Then
If f > 0 Then z = Left$(xml, f)
Else
If f >= fl Then z = z & Mid$(xml, fl, f - fl + 1)
End If
z = z & "<f>" & EditorFXInFXs(s, FXs, True) & "</f>"
fl = f + l + 1
Next m
z = z & Mid$(xml, fl)
End With
EditorFXsInFile = z
End Function
Function EditorFXInFXs(ByVal expression$, FXs, Optional byFile As Boolean, Optional floor% = 10) As String
'Version 1.02
Static re As Object, p4$, p5$, sp$, fl%
Dim s$, pp, p1$, p2$, numberParam%, keepParam%, i%, j%, n%, m%, k%, cl, b As Boolean, z$
Set cl = CreateObject("Scripting.Dictionary"): cl.CompareMode = 1
If re Is Nothing Or floor <> fl Then
Dim t$, p$, p3$, ms
Set re = glbRegex()
s = expression
With Application
sp = IIf(IIf(.UseSystemSeparators, .International(3), .DecimalSeparator) = ".", ",", ";")
End With
p = "(?:""(?:""""|[^""])*""|[^\(\)\{\}\[\]'])"
p1 = "(?:""(?:""""|[^""])*""|[^\(\)\{\}\[\]'" & sp & "])"
p2 = "(?:'(?:''|'""|'\[|'\]|[^'])+')"
p3 = "\{" & p & "+\}"
p2 = "(?:" & p2 & "|" & p3 & "|" & p1 & ")"
p4 = p2
For i = 1 To 3: p4 = "(?:\[" & Replace(p4, p1, p) & "+\]|" & p2 & ")": Next
p5 = p4 & "*"
For i = 1 To floor: p5 = "(?:\(" & Replace(p5, p1, p) & "\)|" & p4 & ")*": Next
p1 = "": p2 = ""
floor = fl
End If
For m = LBound(FXs) To UBound(FXs) Step 3
If FXs(m) <> Empty Then
p1 = "": j = FXs(m + 2): z = "": b = j = 0
If IsArray(FXs(m + 1)) Then
s = " " & Join(FXs(m + 1), " ") & " ": p2 = "(?:" & FXs(m) & ")": GoSub r: RecursionRemoveFXInFXs expression, re, s, z: expression = z
Else
s = FXs(m + 1)
If s <= 0 Then
p1 = "0_" & j
If cl.Exists(p1) Then cl(p1) = cl(p1) & "|" & FXs(m) Else cl(p1) = FXs(m)
Else
s = " " & s & " ": p2 = "(?:" & FXs(m) & ")": GoSub r: RecursionRemoveFXInFXs expression, re, s, z: expression = z
End If
End If
End If
Next
With re
For Each pp In cl.keys()
s = "": p1 = "": p2 = "(?:" & cl(pp) & ")": j = CInt(Split(pp, "_")(1)): b = j = 0: GoSub r
While .test(expression): expression = .Replace(expression, IIf(b, "", "$1$4")): Wend
Next
If Not byFile Then
.Pattern = "(?:- *- *)+((?:- *){1,2})"
While .test(expression): expression = .Replace(expression, "$1"): Wend
End If
End With
Set cl = Nothing
EditorFXInFXs = expression
Exit Function
r:
For i = 1 To j
If i = j Then
p1 = p1 & IIf(i = 1, "", sp) & IIf(b, "", ")") & "(" & p5 & ")"
Else
p1 = p1 & "(?:" & IIf(p1 = "" Or i = 1, "", sp) & p5 & ")"
End If
Next
If b Then
p1 = p1 & "(?:" & p5 & ")(?:" & sp & p5 & ")*"
Else
p1 = "(" & p1 & "((?:" & sp & p5 & ")*)"
End If
If byFile Then
'> (?:>) < (?:<) & (?:&)
If b Then
p1 = "(?:(?:>=|<=|<>|&|>|<|[\+\*\/\=^" & sp & " -]*|^)(?:@?" & p2 & ")\(" & p1 & "\))"
Else
p1 = "([\*\+\/\(=\^\" & sp & "- ]|&|>|<|^)(@?" & p2 & "\()" & p1 & "\)"
End If
Else
If b Then
p1 = "(?:(?:>=|<=|<>|[\+\*&\/\\=<>^ " & sp & "-]*|^)(?:@?" & p2 & ")\(" & p1 & "\))"
Else
p1 = "([\*\+\/\(&\^\=<> " & sp & "-]|^)(@?" & p2 & "\()" & p1 & "\)"
End If
End If
re.Pattern = p1
Return
End Function
Private Sub RecursionRemoveFXInFXs(ByVal text$, ByVal RegExp As Object, indexs$, Optional z$, Optional x%)
Dim t1$, t2$, t3$, s$, s1$, s2$, s3$, s4$, s0$, ms, m, o, f&, l&, fl&, x2%, b As Boolean
With RegExp
Set ms = .Execute(text):
For Each m In ms
s = m: x = x + 1: x2 = x: f = m.FirstIndex: l = m.Length: b = InStr(indexs, " " & x2 & " ") > 0
If z = "" Then
If f > 0 Then z = Left$(text, f)
Else
If f >= fl Then z = z & Mid$(text, fl, f - fl + 1)
End If
Set o = m.submatches: s0 = o(0): s1 = o(1): s2 = o(2): s3 = o(3): s4 = o(4)
If .test(s2) Then t1 = "": RecursionRemoveFXInFXs s2, RegExp, indexs, t1, x Else t1 = s2
If .test(s3) Then t2 = "": RecursionRemoveFXInFXs s3, RegExp, indexs, t2, x Else t2 = s3
If .test(s4) Then t3 = "": RecursionRemoveFXInFXs s4, RegExp, indexs, t3, x Else t3 = s4
If b Then z = z & s0 & t2 Else z = z & s0 & s1 & t1 & t2 & t3 & ")"
fl = f + l + 1
Next m
End With
If ms.Count Then z = z & Mid$(text, fl) Else z = text
End Sub
Private Function CreateFolder(ByVal FolderPath As String, Optional ByRef FileSystem As Object) As Boolean
Dim FolderArray, tmp$, i As Integer, UB As Integer, tFolder$
tFolder = FolderPath
If Right(tFolder, 1) = "\" Then tFolder = Left(tFolder, Len(tFolder) - 1)
If tFolder Like "\\*\*" Then tFolder = Strings.Replace(tFolder, "\", "@", 1, 3)
FolderArray = Split(tFolder, "\")
If FileSystem Is Nothing Then Set FileSystem = glbFSO
On Error GoTo Ends
FolderArray(0) = Strings.Replace(FolderArray(0), "@", "\", 1, 3)
UB = UBound(FolderArray)
With FileSystem
For i = 0 To UB
tmp = tmp & FolderArray(i) & "\"
If Not .FolderExists(tmp) Then DoEvents: .CreateFolder (tmp)
CreateFolder = (i = UB) And Len(FolderArray(i)) > 0 And FolderArray(i) <> " "
Next
End With
Ends:
End Function
Private Function glbRegex(Optional bglobal = True, Optional IgnoreCase = True, Optional MultiLine = True) As Object
Set glbRegex = CreateObject("VBScript.RegExp")
With glbRegex: .Global = bglobal: .IgnoreCase = IgnoreCase: .MultiLine = MultiLine: End With
End Function
Private Function glbFSO() As Object
Set glbFSO = CreateObject("Scripting.FileSystemObject")
End Function
Private Function glbShellA() As Object
Set glbShellA = CreateObject("Shell.Application")
End Function
Private Function StandardPath(ByVal Path As String) As String
StandardPath = Path & IIf(Right(Path, 1) <> "\", "\", "")
End Function
Private Function ThisPath(Optional ByVal filename As String) As String
ThisPath = ThisWorkbook.Path & "\" & filename
End Function
