' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Private Const projectClassName = "copyXLRemoveFormulas"
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 copyXLRemoveFormulas_test()
Dim file$, dest$, sheets
sheets = Array("sheet3", "sheet4", "sheet5", "sheet6")
file = ThisWorkbook.FullName
dest = ThisWorkbook.Path & "\folder ThuNghiem\"
MsgBox IIf(copyXLRemoveFormulas(file, sheets, dest), "Thanh Cong!", "Ko thanh Cong!")
End Sub
Private Sub copyXLRemoveFormulas2_test()
Dim file$, dest$, sheets
sheets = Array("sheet3", "sheet4", "sheet5", "sheet6")
file = ThisWorkbook.FullName
dest = ThisWorkbook.Path & "\folder ThuNghiem\"
MsgBox IIf(copyXLRemoveFormulas2(file, sheets, dest), "Thanh Cong!", "Ko thanh Cong!")
End Sub
Private Function copyXLRemoveFormulas2(filename$, sheets, Optional ByVal destDirectories$) As Boolean
On Error Resume Next
Dim file$, file2$
Dim s$, oFile As Object, b As Boolean, y As Boolean
Dim oSh, ms, ms2, FSO As Object, fn$, sh, nsh, app As Object
Dim it, ext$, xl_type&
Set FSO = glbFSO
'-----------------------------------------------
file = filename
Select Case True
Case file Like "*.xla": xl_type = 18: ext = ".xla"
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"
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
fn = Replace(fn, ext, ".xlsx", , , 1): ext = ".xlsx"
If destDirectories = "" Then destDirectories = oFile.ParentFolder.Path & "\": fn = "(RemoveFxs) " & fn
CreateFolder destDirectories, FSO
file2 = destDirectories & fn
.GetFile(file2).Delete
Set app = CreateObject("Excel.Application")
With app
.EnableEvents = False
.DisplayAlerts = False
.Calculation = -4135
With .Workbooks.Open(filename:=file, UpdateLinks:=False, ReadOnly:=True)
.SaveAs file2, 51: .Close False
End With
End With
err.Clear: DoEvents:
Set ms = app.Workbooks.Open(file2)
For Each sh In ms.Worksheets
If IsArray(sheets) Then
For Each nsh In sheets: If nsh = sh.CodeName Then y = True
Next
Else
y = True
End If
If y Then
DoEvents: sh.UsedRange.value = sh.UsedRange.value
Else
DoEvents: sh.Delete
End If
Next
DoEvents: ms.save: ms.Close True
err.Clear
copyXLRemoveFormulas2 = err = 0
app.Quit: Set app = Nothing
E:
End With
End Function
Private Function copyXLRemoveFormulas(filename$, sheets, Optional ByVal destDirectories$, Optional overwrite As Boolean = True, Optional saveToXLSX As Boolean = True) As Boolean
On Error Resume Next
Dim file$, file2$
Dim s$, re, re2, oFile As Object, oFile2 As Object, oFolder As Object, b As Boolean, y As Boolean, yy As Boolean
Dim oSh, ms, ms2, FSO As Object, tPath, tPath2, fn$, sh, app As Object
Dim it, m, FileName_Path, ZipFile, k&, extFile, ext$, fl%, shfXML$, xl_type&
Set re = glbRegex
Set re2 = glbRegex
Set FSO = glbFSO
Set oSh = glbShellA
'-----------------------------------------------
file = filename: b = saveToXLSX
Select Case True
Case file Like "*.xla": xl_type = 18: ext = ".xla"
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"
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, ".xlsx", , , 1): ext = ".xlsx"
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
Set app = CreateObject("Excel.Application")
With app
.EnableEvents = False
.DisplayAlerts = False
.Calculation = -4135
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 & "xl\", FSO
err.Clear: DoEvents:
oSh.Namespace(CVar(tPath & "xl\")).movehere oSh.Namespace(CVar(ZipFile & "\xl\")).items, 4 Or 16
.GetFile(tPath & "xl\vbaProject.bin").Delete
.GetFile(tPath & "xl\calcChain.xml").Delete
'oSh.Namespace(CVar(tPath)).movehere oSh.Namespace(CVar(ZipFile & "\xl\")).items.Item(CVar("vbaProject.bin")), 4 Or 16
'oSh.Namespace(CVar(tPath)).movehere oSh.Namespace(CVar(ZipFile & "\xl\")).items.Item(CVar("calcChain.xml")), 4 Or 16
Dim wbxml$, wbrels$, pwbxml$, pwbrels$, mmm
pwbxml = tPath & "xl\workbook.xml"
pwbrels = tPath & "xl\_rels\workbook.xml.rels"
Set oFolder = .GetFolder(tPath & "xl\worksheets\")
re.Pattern = "<f[^>\/]*>.+?</f>|<f[^>\/]*\/>" '"<!--(.*?)-->|\r?\n\s*\B"
For Each oFile2 In oFolder.Files
fn = oFile2.Name: tPath2 = oFile2.ParentFolder.Path
DoEvents: y = False
With .OpenTextFile(oFile2.Path, 1, True, -2): s = .ReadAll(): Call .Close: End With
'spans="2:6"
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 = Replace(s, " spans=""2:6""", " spans=""2:4""", , , 1)
s = re.Replace(s, "") '<f t=""shared"" si=""0""/>
With .OpenTextFile(oFile2.Path, 2, True, -2): Call .Write(s): Call .Close: End With
Else
If Not yy Then
With .OpenTextFile(pwbxml, 1, True, -2): wbxml = .ReadAll(): Call .Close: End With
With .OpenTextFile(pwbrels, 1, True, -2): wbrels = .ReadAll(): Call .Close: End With
End If
re2.Pattern = "<Relationship [^<>]*Id=""([^""]+)"" [^<>]*Target=""worksheets\/" & fn & """\/>"
Set mmm = re2.Execute(wbrels): If mmm.Count Then wbrels = re2.Replace(wbrels, ""):
re2.Pattern = "<sheet [^<>]*name=""((?:""""|[^""])+)"" [^<>]*sheetId=""([^""]+)"" [^<>]*r:id=""" & mmm(0).submatches(0) & """/>"
wbxml = re2.Replace(wbxml, "")
yy = True:
.GetFile(tPath2 & "\_rels\" & fn & ".rels").Delete
DoEvents: oFile2.Delete:
End If
Next
If yy Then
re2.Pattern = "<definedNames>.+?</definedNames>"
wbxml = re2.Replace(wbxml, "")
With .OpenTextFile(pwbxml, 2, True, -2): Call .Write(wbxml): Call .Close: End With
With .OpenTextFile(pwbrels, 2, True, -2): Call .Write(wbrels): Call .Close: End With
End If
err.Clear
Dim ccc&:
oSh.Namespace(CVar(ZipFile)).copyhere oSh.Namespace(CVar(tPath & "xl\")), 4 Or 16
k = 0
Do While oSh.Namespace(ZipFile & "\xl\") Is Nothing
DoEvents: Sleep 20
k = k + 1: If k > 20 Then Exit Do
Loop: k = 0
err.Clear
DoEvents: Sleep 200
DoEvents: .MoveFile ZipFile, file2
copyXLRemoveFormulas = err = 0
.GetFolder(tPath).Delete
If Not app Is Nothing Then app.Quit: Set app = Nothing
E:
End With
End Function
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
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
Function glbFSO() As Object
Set glbFSO = CreateObject("Scripting.FileSystemObject")
End Function
Function glbShellA() As Object
Set glbShellA = CreateObject("Shell.Application")
End Function
Function StandardPath(ByVal Path As String) As String
StandardPath = Path & IIf(Right(Path, 1) <> "\", "\", "")
End Function
Function ThisPath(Optional ByVal filename As String) As String
ThisPath = ThisWorkbook.Path & "\" & filename
End Function
