Vọc chơi với những thuật toán nén và giải nén file

7 Responses

1. hands says:

   15/01/2023 at 2:47 pm

   Ý thầy ndu là đọc hiểu và xào nấu mớ rau muống sau rồi đưa vào code phải không ạ:

   PK-      ! q9+p                      [Content_Types].xmlPK-      ! µU0#ơ   L               |  _rels/.relsPK-      ! ̃    ư(  Ô               h  xl/_rels/workbook.xml.relsPK-      ! @97é_  q               ª  xl/workbook.xmlPK-      ! é¦%¸‚  S               6
     xl/theme/theme1.xmlPK-      ! G$î  º               é  xl/worksheets/sheet2.xmlPK-      ! G$î  º               6  xl/worksheets/sheet3.xmlPK-      ! ₫äŸ   º                ƒ  xl/sharedStrings.xmlPK-      ! ómóh–  M 
                T  xl/styles.xmlPK-      ! B;_  @                 xl/worksheets/sheet1.xmlPK-      ! Iđ@>  [               ª  docProps/core.xmlPK-      ! —€LÖŸ  V                 docProps/app.xmlPK        ô

   Tôi nhớ không lầm thì để làm ribbon người ta tạo ra file CustomUI.xml với cả đống lệnh trong đó. Vậy nên tôi có ý tưởng:
   – Dùng VBA tạo ra cái đống lệnh rồi Save thành file CustomUI.xml
   – Tiếp theo bằng phương pháp nén file (như chủ đề topic này) ta sẽ đưa CustomUI.xml vào bên trong file xlsm
   Quy trình là vậy nhưng để thực thi nó thì vẫn còn nhiều bước lắm. Từ từ chúng ta cùng nghiên cứu vậy!
   (Tôi ghét ribbon bởi luôn phải có công đoạn làm bằng tay. Nếu như toàn bộ đều bằng code thì.. chuyện ngon rồi).

   "Công trình" đầu tiên

   Đây là "công trình" đầu tiên của việc nén file:

   Private Function CreateNewZip(ByVal ZipFilePath As String) As String
    'Create an empty ZIP file
     Dim FSO, sBin As String
     On Error GoTo ErrHandler
     If UCase(Right(ZipFilePath, 4)) = ".ZIP" Then
       Set FSO = CreateObject("Scripting.FileSystemObject")
       sBin = "PK" & Chr(5) & Chr(6) & String(18, 0)
       With FSO.CreateTextFile(ZipFilePath, True)
         .Write sBin
         .Close
       End With
       If Err.Number = 0 Then CreateNewZip = ZipFilePath
       Exit Function
   ErrHandler:     MsgBox Err.Description
     End If
   End Function
   Function FileToZip(ByVal [COLOR=#ff0000]FilePath[/COLOR]) As Boolean
     'Microsoft Shell Controls And Automation
     Dim FSO As Object
     Dim [COLOR=#ff0000]ZipFilePath, sFolder, sName[/COLOR], sFile As String
     On Error GoTo ErrHandler
     Set FSO = CreateObject("Scripting.FileSystemObject")
     sFile = CStr(FilePath)
     If FSO.FileExists(sFile) Then
       sFolder = FSO.GetFile(sFile).ParentFolder.Path
       If Right$(sFolder, 1) <> "" Then sFolder = sFolder & ""
       sName = FSO.GetFile(sFile).Name
       If InStr(1, sName, ".") Then
         sName = Left$(sName, InStrRev(sName, "."))
         sName = sName & "zip"
         ZipFilePath = CreateNewZip(sFolder & sName)
         With CreateObject("Shell.Application")
           .Namespace([COLOR=#ff0000]ZipFilePath[/COLOR]).CopyHere .Namespace([COLOR=#ff0000]sFolder[/COLOR]).Items.Item([COLOR=#ff0000]FilePath[/COLOR])
         End With
         FileToZip = (Err.Number = 0)
         Exit Function
   ErrHandler:     MsgBox Err.Description
       End If
     End If
   End Function
   Sub TestZipFile()
     Dim bRet As Boolean
     Dim vFile
     vFile = Application.GetOpenFilename("All Files, *.*")
     If TypeName(vFile) = "String" Then
       bRet = FileToZip(vFile)
       If bRet Then MsgBox "Done!"
     End If
   End Sub

   Mời test thử và cùng hoàn thiện
   Lưu ý quan trọng(mất công các bạn tự làm bị lỗi mà không biết): Mấy cái biến màu đỏ tuy ta có thể dùng như chuỗi nhưng tuyệt đối không được khai báo nó dạng chuỗi (kiểu như Dim FilePath as String)… nếu không code lập tức báo lỗi. Các bạn có thể thay đổi 1 vài biến màu đỏ thành dạng As String và test thử
   ———————————-
   Tôi nghiên cứu tới đâu đăng bài tới đó chứ chưa có gì sẵn trong đầu cả (chỉ có ý tưởng)… vậy nên xin mời các bạn góp sức hoàn thiện (tôi tin chắc vẫn còn lỗi ở đâu đó)
   Cảm ơn

   Reply
2. hands says:

   15/01/2023 at 2:51 pm

   báo cáo thầy là dòng này không làm việc trên máy em

   .Namespace(ZipFilePath).CopyHere .Namespace(sFolder).Items.Item(FilePath)

   mà phải vầy nó mới chịu

   .Namespace(ZipFilePath).CopyHere FilePath

   Mình thật may mắn khi luôn có các bạn đồng hành! Cảm ơn
   —————————————————————–
   Tôi test thử trên Windows 7 (32bit) + Office 2010 (32bit) thì cả 2 cách trên đều được
   Vậy mời các bạn khác test thử, nếu thay đổi như anh Chim Hồng mà không máy nào báo lỗi thì ta sẽ thống nhất dùng code này
   (mục đích để máy nào cũng dùng được)

   em dùng cái này

   MsgBox TypeName(.Namespace(sFolder).Items.Item(FilePath))

   nó cho em cái chữ "Nothing"

   Trên máy tôi thì nó là tên cái file cần nén
   Ẹc… Ẹc… ứ biết cái gì trong trái ổi… Mò là chính, mò hoài không ra thì.. hết gân!

   Như vậy, Em nghĩ theo cách làm thủ công thì chúng ta sẽ dùng vba để tạo ribbon với các bước sau:
   1. Đổi tên file xlsx, xlsm… (ex 2007 trở lên) thành *.zip
   2. Giải nén file của bước 1. Nếu muốn làm việc với Ribbon thì lấy ra file CustomUI.xml để sử dụng.
   3. "Chế cháo" file CustomUI.xml và thay thế file customUI.xml gốc ban đầu
   4. Tạo 1 file zip rỗng
   5. Copy trở lại tất cả các file đã unzip ở bước 2 + file CustomUI.xml đã sửa đổi vào file zip rỗng ở bước 4
   6. Đổi tên lại file zip ở bước 5 thành file xlsx, xlsm… như ban đầu.

   Mình nghĩ từ bước 4 trở đi sẽ là:
   4> Mang file CustomUI.xml đưa vào trong file xlsx.zip hoặc xlsm.zip (thủ tục nén file)
   5> Đổi đuôi xlsx.zip hoặc xlsm.zip thành xlsx hoặc xlsm

   [URL='www.giaiphapexcel.com/diendan/goto/post?id=675766']ndu96081631 said:
   Mình thật may mắn khi luôn có các bạn đồng hành! Cảm ơn
   —————————————————————–
   Tôi test thử trên Windows 7 (32bit) + Office 2010 (32bit) thì cả 2 cách trên đều được
   Vậy mời các bạn khác test thử, nếu thay đổi như anh Chim Hồng mà không máy nào báo lỗi thì ta sẽ thống nhất dùng code này
   (mục đích để máy nào cũng dùng được)

   Máy em cả 2 đền được (Win7 64bit, Office 2007 32bit)
   Nhân tiện anh cho em hỏi các hàm có dấu $ (Left$, Right$, Mid$,… ) khác gì so với các hàm không có dấu này (Left, Right, Mid,… ). Em thử các hàm không có dấu $ thì kết quả vẫn không có gì khác.

   Cố tình muốn xử lý theo kiểu chuỗi đấy mà (tại vì biến ở trên ta khai báo Variant)
   Tại cái tật cẩn thận (muốn làm cái gì ra cái đó)
   Ẹc… Ẹc…

   thưa thầy . em không biết là các bạn bạn tham gia ở đây võ công cao đến đâu . nhưng mà cái việc chế ra file CUstomUI.xml là việc em nghĩ là không đơn giản . sao chúng ta không đi từng bước làm những cái đơn giản hơn trước . thí dụ như đọc dữ liệu từ các file sheet.xml , ghi ngược lại , vân vân để luyện kỹ năng làm việc với xml trước đã . rồi sau đó mới đủ vũ khí đi giết con đại bàng chứ .

   Thì tiêu chí từ đầu của tôi là… TỪ TỪ mà (đừng nóng vội sẽ hư bột hư sugar)… từ từ và chắc corn –=0
   Tôi chỉ nêu cái "viễn cảnh" gây "kích thích" thôi!

   Mình thật may mắn khi luôn có các bạn đồng hành! Cảm ơn
   —————————————————————–
   Tôi test thử trên Windows 7 (32bit) + Office 2010 (32bit) thì cả 2 cách trên đều được
   Vậy mời các bạn khác test thử, nếu thay đổi như anh Chim Hồng mà không máy nào báo lỗi thì ta sẽ thống nhất dùng code này
   (mục đích để máy nào cũng dùng được)

   Anh thử lại cách này thử có được không?

   .Namespace(ZipFilePath).CopyHere .Namespace(sFolder).Items.Item(FilePath)

   Lúc đầu máy em chạy được nhưng sau khi thử cách của bạn doveandrose bây giờ thử lại không được (File tạo ra bị lỗi). Chả hiểu.

   Vừa test lại xong, đổi qua lại giữa 2 code, tất cả đều bình thường Thắng à!
   Hết hồn (nhưng mọi thứ.. còn nguyên)
   —————————————-

   máy tôi hàm

   .Namespace(sFolder).Items.Item([B][SIZE=3][COLOR=#ff0000]sFile[/COLOR][/SIZE][/B])

   chỉ nhận kiểu Variant và là 1 file ShortName chứ hổng đươc fullName
   nên code của thầy NDU chỉ có thể viết lại vậy

   Function FileToZip(ByVal FilePath) As Boolean
     'Microsoft Shell Controls And Automation
     Dim FSO As Object
     Dim ZipFilePath, sFolder, sName, [COLOR=#b22222][SIZE=3][B]sFile[/B][/SIZE][/COLOR]
     On Error GoTo ErrHandler
     Set FSO = CreateObject("Scripting.FileSystemObject")
     sFile = CStr(FilePath)
     If FSO.FileExists(sFile) Then
       sFolder = FSO.GetFile(sFile).ParentFolder.Path
       If Right$(sFolder, 1) <> "" Then sFolder = sFolder & ""
       sName = FSO.GetFile(sFile).Name
   [COLOR=#ff0000][SIZE=3][B]    sFile = sName[/B][/SIZE][/COLOR]
       If InStr(1, sName, ".") Then
         sName = Left$(sName, InStrRev(sName, "."))
         sName = sName & "zip"
         ZipFilePath = CreateNewZip(sFolder & sName)
         With CreateObject("Shell.Application")
           .Namespace(ZipFilePath).CopyHere .Namespace(sFolder).Items.Item([COLOR=#ff0000][SIZE=3][B]sFile[/B][/SIZE][/COLOR])
         End With
         FileToZip = (Err.Number = 0)
         Exit Function
   ErrHandler:     MsgBox Err.Description
       End If
     End If
   End Function

   Chỗ này là mình sơ sót, ở trong Items.Item(…) phải là 1 name chứ không thể fullname
   Đã vậy thì bỏ luôn sFile cho rồi (hoặc bỏ sName chứ ai lại sFile = sName)

   tôi phải cố gắng làm sao cho hàm

   .Namespace(sFolder).Items.Item(sFile)

   phải chạy được vì tôi biết các bài tới sẽ phải dùng đến nó chứ không dùng cái dưới này được

   .Namespace(ZipFilePath).CopyHere FilePath

   OK!
   Vậy chúng ta cùng test theo hàm vừa sửa nhé:

   Function FileToZip(ByVal FilePath) As Boolean
     'Microsoft Shell Controls And Automation
     Dim FSO As Object
     Dim ZipFilePath, sFolder, sName, [COLOR=#ff0000]sFile[/COLOR]
     On Error GoTo ErrHandler
     Set FSO = CreateObject("Scripting.FileSystemObject")
     sFile = CStr(FilePath)
     If FSO.FileExists([COLOR=#ff0000]CStr(sFile)[/COLOR]) Then
       sFolder = FSO.GetFile([COLOR=#ff0000]CStr(sFile)[/COLOR]).ParentFolder.Path
       If Right$(sFolder, 1) <> "" Then sFolder = sFolder & ""
       sName = FSO.GetFile(sFile).Name
       [COLOR=#ff0000]sFile = sName[/COLOR]
       If InStr(1, sName, ".") Then
         sName = Left$(sName, InStrRev(sName, "."))
         sName = sName & "zip"
         ZipFilePath = CreateNewZip(sFolder & sName)
         With CreateObject("Shell.Application")
           .Namespace(ZipFilePath).CopyHere .Namespace(sFolder).Items.Item([COLOR=#ff0000]sFile[/COLOR])
         End With
         FileToZip = (Err.Number = 0)
         Exit Function
   ErrHandler:     MsgBox Err.Description
       End If
     End If
   End Function

   Xem thử còn lỗi gì nữa không?

   Reply
3. hands says:

   15/01/2023 at 2:54 pm

   trơn quá té bạn ơi . bạn nén file 200Mb thử xem chữ "Done" xuất hiện khi nào . hi hi

   Cái vụ đó bỏ qua! Bởi mục đích chính của ta hoàn toàn không phải muốn thay thể chương trình WinRAR hay WinZIP. Điều ta cần cuối cùng là EDIT FILE XML NẰM TRONG FILE XLSX, XLSM

   vâng có lẽ em đi lạc đề rồi . Thầy định hướng lại đi . sau đây chúng ta sẽ làm gì ?

   Như chủ đề topic, ta đã nén được rồi thì giờ tiên hành giải nén
   (tuy nhiên các bạn khác cứ test thử code bài 61 xem còn lỗi gì không đã)

   bị nêu đích danh ngại quá

   Public Function UnZip(ByVal ZipFilePath, Optional ByVal ZipToFd) As Boolean
   Dim FSO As Object
   On Error GoTo ErrHandler
     Set FSO = CreateObject("Scripting.FileSystemObject")
     If FSO.FileExists(ZipFilePath) Then
       If IsMissing(ZipToFd) Then ZipToFd = FSO.GetFile(ZipFilePath).ParentFolder.Path
         With CreateObject("Shell.Application")
           .Namespace(ZipToFd).CopyHere .Namespace(ZipFilePath).Items
         End With
         UnZip = (Err.Number = 0)
         Exit Function
   ErrHandler:     MsgBox Err.Description
     End If
   End Function

   Sub TestZipFile()
     Dim bRet As Boolean
     Dim vFile
     vFile = Application.GetOpenFilename("All Files, *.zip")
     If TypeName(vFile) = "String" Then
       bRet = UnZip(vFile, "d:")
       If bRet Then MsgBox "Done!"
     End If
   End Sub

   Theo tiêu chí mà ta đang hướng tới thì code cần hoàn thiện là:
   – Code có khả năng nén 1 file vào trong 1 file zip có sẵn (nếu file zip chưa có thì mới tạo NewZip)
   – Code có khả năng giải nén 1 file chỉ định nào đó bên trong file zip đang chứa nhiều files khác (có thể ta chỉ cần edit 1 file nào đó trong file zip mà thôi)

   hi hi . nhưng mà cơm nước cái đã . tí nữa mà chưa có ai làm thì em lại tiếp tục vậy :-=:-=

   Cơm xong uống nước lọc thôi, đừng uống nước cái —> "bay" hổng nỗi luôn đóa –=0

   Theo tiêu chí mà ta đang hướng tới thì code cần hoàn thiện là:
   – Code có khả năng nén 1 file vào trong 1 file zip có sẵn (nếu file zip chưa có thì mới tạo NewZip)
   – Code có khả năng giải nén 1 file chỉ định nào đó bên trong file zip đang chứa nhiều files khác (có thể ta chỉ cần edit 1 file nào đó trong file zip mà thôi)

   rồi chúng ta tiếp tục . bây giờ làm câu 1 trước

   Function FileToZip(ByVal FilePath, Optional ByVal ZipTo, Optional ByVal seekPath) As Boolean
     'ZipTo : Full Name of Existing Zip file
     'seekPath : path in Existing Zip file
     Dim fso As Object, sFolder, sName, sFile
     On Error GoTo ErrHandler
     Set fso = CreateObject("Scripting.FileSystemObject")
     If fso.FileExists(FilePath) Then
       sFolder = fso.getfile(FilePath).ParentFolder
       If Right$(sFolder, 1) <> "" Then sFolder = sFolder & ""
       sName = fso.GetBaseName(FilePath)
       sFile = fso.GetFileName(FilePath)
       If IsMissing(ZipTo) Then ZipTo = CreateNewZip(sFolder & sName & ".zip")
       If Not fso.FileExists(ZipTo) Then ZipTo = CreateNewZip(sFolder & sName & ".zip")
       If Not IsMissing(seekPath) Then ZipTo = ZipTo & "" & seekPath
       With CreateObject("Shell.Application")
         .Namespace(ZipTo).Copyhere .Namespace(sFolder).items.Item(sFile)
       End With
       FileToZip = (Err.Number = 0)
       Exit Function
   ErrHandler:     MsgBox Err.Description
     End If
   End Function

   Kết quả test:
   – Chạy lần đầu, chọn file b1.xlsx nó ra kết quả b1.xlsx nằm trong b1.zip
   – Chạy lần hai, vẫn chọn file b1.xlsx nó ra kết quả b1.xlsx nằm trong b1.xlsx.zip
   Trong khi câu lệnh của ta là:

   bRet = FileToZip(vFile, [COLOR=#ff0000]ThisWorkbook.Path & "b1.xlsx.zip"[/COLOR])

   Đã chỉ rõ nơi đến thì lần đầu chạy hay lần hai cũng phải cho cùng kết quả chứ nhỉ?

   cho thử sức cái nữa . hi hi

   Function FileToZip(ByVal FilePath, Optional ByVal ZipTo, Optional ByVal seekPath) As Boolean
     'ZipTo : Full Name of Existing Zip file
     'path in Existing Zip file
     Dim fso As Object, sFolder, sName, sFile
     On Error GoTo ErrHandler
     Set fso = CreateObject("Scripting.FileSystemObject")
     If fso.FileExists(FilePath) Then
       sFolder = fso.getfile(FilePath).ParentFolder
       If Right$(sFolder, 1) <> "" Then sFolder = sFolder & ""
       sName = fso.GetBaseName(FilePath)
       sFile = fso.GetFileName(FilePath)
       If IsMissing(ZipTo) Then ZipTo = CreateNewZip(sFolder & sName & ".zip")
       If Not fso.FileExists(ZipTo) Then ZipTo = CreateNewZip(ZipTo)
       If Not IsMissing(seekPath) Then ZipTo = ZipTo & "" & seekPath
       With CreateObject("Shell.Application")
         .Namespace(ZipTo).Copyhere .Namespace(sFolder).items.Item(sFile)
       End With
       FileToZip = (Err.Number = 0)
       Exit Function
   ErrHandler:     MsgBox Err.Description
     End If
   End Function

   Mới thử sơ qua —> Kết quả ngon
   Giờ phải vào ca 3, tối nay nếu rảnh sẽ test tiếp

   Reply
4. hands says:

   15/01/2023 at 2:56 pm

   tiếp theo là câu 2 : giải nén file được chỉ định trong 1 file nén

   Public Function UnZip(ByVal ZipFilePath, Optional ByVal ZipToFd, _
   Optional ByVal targetFile, Optional ByVal seekPath) As Boolean
   Dim fso As Object
   On Error GoTo ErrHandler
     Set fso = CreateObject("Scripting.FileSystemObject")
     If fso.FileExists(ZipFilePath) Then
       If IsMissing(ZipToFd) Then ZipToFd = fso.getfile(ZipFilePath).ParentFolder
       If Not IsMissing(seekPath) Then ZipFilePath = ZipFilePath & "" & seekPath
       With CreateObject("Shell.Application")
           If IsMissing(targetFile) Then
               .Namespace(ZipToFd).copyhere .Namespace(ZipFilePath).items
           Else
               .Namespace(ZipToFd).copyhere .Namespace(ZipFilePath).items.Item(targetFile)
           End If
       End With
       UnZip = (Err.Number = 0)
       Exit Function
   ErrHandler:     MsgBox Err.Description
     End If
   End Function

   xin mời thử 4 trường hợp sau đây

   bRet = UnZip(vFile)
   'bRet = UnZip(vFile, , "[Content_Types].xml")
   'bRet = UnZip(vFile, , "sheet2.xml", "xlworksheets")
   'bRet = UnZip(vFile, ThisWorkbook.Path & "Zipto", , "docProps")

   Tôi đoán rằng code ở bài 80 và 86 có thể không cần đối số seekPath
   Thử xem liệu có được không?
   Tốt nhất làm sao cả 2 hàm chỉ cần 2 đối số: Nguồn và Đích

   vâng vậy thầy hướng dẫn đoạn code cho tụi em học với

   Lấy thư mục "do choi" của bạn hôm qua làm ví dụ nhé:

   Sub UnZip()
     Dim path
     path = ThisWorkbook.path
     With CreateObject("Shell.Application")
       .Namespace([COLOR=#ff0000]path[/COLOR]).Copyhere .Namespace([COLOR=#0000cd]path & "b1.xlsx.zipxl"[/COLOR]).items.Item([COLOR=#0000cd]"styles.xml"[/COLOR])
     End With
   End Sub

   Hoặc vầy:

   Sub UnZip()
     Dim path
     path = ThisWorkbook.path
     With CreateObject("Shell.Application")
       .Namespace([COLOR=#ff0000]path[/COLOR]).Copyhere .Namespace([COLOR=#0000cd]path & "b1.xlsx.zip"[/COLOR]).items.Item([COLOR=#0000cd]"xlstyles.xml"[/COLOR])
     End With
   End Sub

   đều được!
   Màu xanh là nguồn, màu đỏ là đích
   Thử xem được không

   màu xanh là nguồn nhưng mà nguồn này được đặt vào 2 vị trí khác nhau + thêm màu đỏ nữa thành ra 3 vị trí . mà thầy biểu dùng 2 tham số đầu vào thì khó quá . nên mới cần thầy múa vài đường cho tụi em học

   Thì 2 cái màu xanh ráp lại là thành nguồn (khi dùng ta chỉ cần truyền vào path & "b1.xlsx.zipxlstyles.xml" là được rồi)
   Việc của ta là "cắt" sao đó để phân cái nguồn này thành 2 để ráp code thôi
   Mới "ý tưởng" thôi (vì thí nghiệm thấy được), lấy gì "múa" đây

   dạ em cũng ương lắm . em biết nếu gắn chung lại rồi vào trong hàm muốn phân chia ra thì phải biết chuỗi truyền vào là 1 folder hay 1 file . nhưng mà thích ngắm thầy ra chiêu cơ . hi hi

   Tôi cũng có nghĩ đến chuyện này rồi (cũng chỉ ý tưởng): Ta viết luôn 2 dòng:

   .Namespace(ZipTo).Copyhere .Namespace(sFolder).items.Item(sFile)
   .Namespace(ZipTo).Copyhere .Namespace(sFolder & "" & sFile).items

   Nếu không được thằng trên thì nhảy xuống thằng dưới
   Chẳng biết nữa, phải thử rồi tính
   (nói chung lúc code mình có thể cực chút, miễn sao lúc dùng thoải mái nhất là ngon! Nhiều đối số truyền quá rất khó hình dung)

   theo ý thầy , em sửa lại

   Function FileToZip(ByVal FilePath, Optional ByVal ZipTo) As Boolean
     Dim fso As Object, sFolder, sName, sFile
     On Error GoTo ErrHandler
     Set fso = CreateObject("Scripting.FileSystemObject")
     If fso.fileexists(FilePath) Then
       sFolder = fso.getfile(FilePath).ParentFolder
       If Right$(sFolder, 1) <> "" Then sFolder = sFolder & ""
       sName = fso.GetBaseName(FilePath)
       sFile = fso.GetFileName(FilePath)
       If IsMissing(ZipTo) Then ZipTo = CreateNewZip(sFolder & sName & ".zip")
       With CreateObject("Shell.Application")
           If Not fso.fileexists(ZipTo) And Right(ZipTo, 4) = ".zip" Then ZipTo = CreateNewZip(ZipTo)
           .Namespace(ZipTo).copyhere .Namespace(sFolder).items.Item(sFile)
       End With
       FileToZip = (Err.Number = 0)
       Exit Function
   ErrHandler:     MsgBox Err.Description
     End If
   End Function

   Public Function UnZip(ByVal ZipFilePath, Optional ByVal ZipToFd) As Boolean
   Dim fso As Object, lPos As Long
   On Error GoTo ErrHandler
   Set fso = CreateObject("Scripting.FileSystemObject")
   If IsMissing(ZipToFd) Then ZipToFd = ThisWorkbook.Path
   With CreateObject("Shell.Application")
       If Right(ZipFilePath, 1) = "" Then ZipFilePath = Left(ZipFilePath, Len(ZipFilePath) - 1)
       If fso.fileexists(ZipFilePath) Then
           .Namespace(ZipToFd).copyhere .Namespace(ZipFilePath).items
       Else
           lPos = InStrRev(ZipFilePath, "")
           If lPos > 0 Then .Namespace(ZipToFd).copyhere ( _
           .Namespace(Left(ZipFilePath, lPos)).items.Item(Mid(ZipFilePath, lPos + 1)))
       End If
   End With
   UnZip = (Err.Number = 0)
   Exit Function
   ErrHandler:     MsgBox Err.Description
   End Function

   thử nghiệm

   Sub TestZipFile()
     Dim bRet As Boolean, vFile
     'vFile = Application.GetOpenFilename("All Files, *.*")
     vFile = Application.GetOpenFilename("All Files, *.zip")
     If TypeName(vFile) = "String" Then
       'bRet = FileToZip(vFile)
       'bRet = FileToZip(vFile, ThisWorkbook.Path & "b1.xlsx.zip")
       'bRet = FileToZip(vFile, ThisWorkbook.Path & "b1.xlsx.zipxl")
   
   'bRet = UnZip(vFile)
       'bRet = UnZip(vFile & "[Content_Types].xml")
       bRet = UnZip(vFile & "xl")
       If bRet Then MsgBox "Done!"
     End If
   End Sub

   Cách test hữu hiệu nhất là đưa vào thực nghiệm
   Tôi đã viết xong thủ tục xóa styles rác từ đường dẫn file styles.xml cho trước:

   Sub ClearStylesFromXML(ByVal xmlFile As String)
     Dim Params As String, filename As String, StartDir As String, ext As String
     Dim text1 As String, text2 As String, text3 As String
     Dim Arr, aBuiltInYes(), aBuiltInNo()
     Dim lBuiltInYes As Long, lBuiltInNo As Long, i As Long, lPos_Start As Long, lPos_End As Long
     Dim FSO As Object
     Set FSO = CreateObject("Scripting.FileSystemObject")
     'On Error Resume Next
     With FSO
       If Not .FileExists(xmlFile) Then Exit Sub
       If .GetFile(xmlFile).Name <> "styles.xml" Then Exit Sub
       With .OpenTextFile(xmlFile)
         text1 = .ReadAll
         .Close
       End With
       lPos_Start = InStr(1, text1, "<cellStyle name=")
       lPos_End = InStr(1, text1, "</cellStyles>")
       text2 = Mid(text1, lPos_Start, lPos_End - lPos_Start)
       text3 = Replace(text2, "/><", "/>" & vbLf & "<")
       Arr = Split(text3, vbLf)
       For i = LBound(Arr) To UBound(Arr)
         If InStr(1, Arr(i), "builtinId") Then
           lBuiltInYes = lBuiltInYes + 1
           ReDim Preserve aBuiltInYes(1 To lBuiltInYes)
           aBuiltInYes(lBuiltInYes) = Arr(i)
         Else
           lBuiltInNo = lBuiltInNo + 1
           ReDim Preserve aBuiltInNo(1 To lBuiltInNo)
           aBuiltInNo(lBuiltInNo) = Arr(i)
         End If
       Next
       If lBuiltInNo Then
         text1 = Replace(text1, text2, Join(aBuiltInYes, ""))
         .CreateTextFile(xmlFile, True).Write text1
          MsgBox "Da xoa xong " & lBuiltInNo & " styles rác"
       Else
         MsgBox "Không có styles rác nào"
       End If
     End With
   End Sub

   Các bạn có thể sửa thủ tục trên thành hàm để trả về giá trị gì đó nếu cần
   ————————————
   Giờ bắt đầu thử nghiệm:
   – Đầu tiên ta sẽ tìm đâu đó một file có nhiều styles rác (trên diễn đàn có đầy). Tiếp theo nếu file chứa styles rác này có định dạng .xls thì hãy mở file SaveAs thành .xlsx (hoặc .xlsm), sau đó bắt đầu viết thêm 1 code làm việc theo quy trình 5 bước sau:
   1> Đổi đuôi file .xlsx (hoặc xlsm) thành .xlsx.zip (hoặc .xlsm.zip)
   2> Dùng hàm giải nén file .xlsx.zip (hoặc .xlsm.zip) để lấy ra file styles.xml
   3> Dùng code tôi viết ở trên để làm sạch style rác
   4> Dùng hàm nén file để đưa file styles.xml vào lại trong file .xlsx.zip (hoặc .xlsm.zip)
   5> Đổi đuôi file .xlsx.zip (hoặc .xlsm.zip) trở lại thành .xlsx (hoặc .xlsm)
   – Mở bằng tay file .xlsx (hoặc .xlsm) kiểm tra xem các styles rác đã thật sự được làm sạch hay chưa?
   ————————————
   Lưu ý quan trọng: Từ bước 2 đến bước 3 có khả năng xảy ra lỗi. Lý do vì quá trình giải nén tại bước 2, file styles.xml chưa kịp hình thành nên không thể xử lý xóa styles tại bước 3. Vậy bằng cách nào đó ta hãy làm trễ bước 2 khoảng 1 vài giây rồi hẳn tiếp bước 3 (Dùng Application.Wait chẳng hạn)
   Nói chung mọi thứ đã có, giờ hãy thí nghiệm để kiểm chứng thành quả nhé
   Cảm ơn!

   Reply
5. hands says:

   15/01/2023 at 2:59 pm

   ẹc thầy làm vậy em bị sốc thầy ơi
   thầy có thể giải thích sơ qua về cấu trúc file styles.xml được không ạ ?

   Mở file styles.xml bằng Notepad là thấy chứ cần gì giải thích
   – Tìm trong styles.xml những chuỗi dạng <cellStyle name="Tên của style" ………/>
   – Nếu thấy từ khóa builtinId bên trong <cellStyle name="Tên của style"…… builtinId… /> thì đó là style có sẵn
   – Nếu không tìm thấy từ khóa builtinId thì đó là style rác và ta sẽ xóa nó

   Nói thêm: Ở đây ta mượn tạm sub xóa styles để test mấy công cụ nén và giải nén. Nếu nó hoạt động tốt thì ta xem như công cụ của ta tốt
   Đương nhiên, việc edit styles bên trong file styles.xml các bạn có thể viết kiểu khác tùy ý

   thầy nói vậy may ra em mới hiểu cần phải làm gì
   tí nữa rảnh em viết lại code thực hiện hết 5 bước của thầy luôn
   báo cáo thầy là code hàm FileToZip của em làm tan xác luôn file Zip . Nhờ thầy cứu với
   trong đây có file excel 500kb có 2 style rác . chạy code xong gán file style.xml lại file zip là đi đời luôn file zip

   Tôi kiểm tra đâu thấy "đi đời" gì đâu, chỉ là file xlsx ấy còn y nguyên 2 styles rác
   Còn 1 chuyện nữa: Nếu file cần xóa styles, sau khi qua xử lý nhận đươc thông báo "không có styles rác nào" thì ta bỏ qua công đoạn nén file luôn chứ
   Bởi vậy tôi cẩn thận gợi ý lần trước rằng:

   Các bạn có thể sửa thủ tục trên thành hàm để trả về giá trị gì đó nếu cần

   Dựa vào kết quả mà hàm trả về, ta biết được có styles rác hay không rồi mới tính tiếp
   Tôi sửa sub ClearStylesFromXML thành Function ClearStylesFromXML

   Function ClearStylesFromXML(ByVal xmlFile As String) As Boolean
     Dim Params As String, filename As String, StartDir As String, ext As String
     Dim text1 As String, text2 As String, text3 As String
     Dim Arr, aBuiltInYes(), aBuiltInNo()
     Dim lBuiltInYes As Long, lBuiltInNo As Long, i As Long, lPos_Start As Long, lPos_End As Long
     Dim FSO As Object
     Set FSO = CreateObject("Scripting.FileSystemObject")
     'On Error Resume Next
     With FSO
       If Not .fileexists(xmlFile) Then Exit Function
       If .GetFile(xmlFile).Name <> "styles.xml" Then Exit Function
       With .OpenTextFile(xmlFile)
         text1 = .ReadAll
         .Close
       End With
       lPos_Start = InStr(1, text1, "<cellStyle name=")
       lPos_End = InStr(1, text1, "</cellStyles>")
       text2 = Mid(text1, lPos_Start, lPos_End - lPos_Start)
       text3 = Replace(text2, "/><", "/>" & vbLf & "<")
       Arr = Split(text3, vbLf)
       For i = LBound(Arr) To UBound(Arr)
         If InStr(1, Arr(i), "builtinId") Then
           lBuiltInYes = lBuiltInYes + 1
           ReDim Preserve aBuiltInYes(1 To lBuiltInYes)
           aBuiltInYes(lBuiltInYes) = Arr(i)
         Else
           lBuiltInNo = lBuiltInNo + 1
           ReDim Preserve aBuiltInNo(1 To lBuiltInNo)
           aBuiltInNo(lBuiltInNo) = Arr(i)
         End If
       Next
       If lBuiltInNo Then
         text1 = Replace(text1, text2, Join(aBuiltInYes, ""))
         .CreateTextFile(xmlFile, True).Write text1
          MsgBox "Da xoa xong " & lBuiltInNo & " styles rác"
          ClearStylesFromXML = True
       Else
         MsgBox "Không có styles rác nào"
         ClearStylesFromXML = False
       End If
     End With
   End Function

   Đồng thời sửa 2 sub cuối thành:

   Private Sub MoveFile(ByVal filePath As String)
     Dim FSO As Object, bRet As Boolean, sPath, ext As String
     Set FSO = CreateObject("Scripting.FileSystemObject")
     ext = FSO.GetExtensionName(filePath)
     If (UCase(ext) <> "XLSX") And (UCase(ext) <> "XLSM") Then Exit Sub
     With FSO
       .MoveFile filePath, filePath & ".zip"
       sPath = ThisWorkbook.Path & "styles.xml"
       If .fileexists(sPath) Then .DeleteFile (sPath)
       bRet = UnZip(filePath & ".zipxlstyles.xml")
       Do While Not .fileexists(sPath)
          Application.Wait (Now + 0.0005)
       Loop
       If ClearStylesFromXML(sPath) Then
         bRet = FileToZip(sPath, filePath & ".zipxl")
         CreateObject("WScript.Shell").Popup "Cho mot chút!", 4, "THÔNG BÁO"
       End If
       .MoveFile filePath & ".zip", filePath
       .DeleteFile sPath
     End With
     MsgBox "done"
   End Sub
   Sub TestZipFile()
     Dim bRet As Boolean, vFile
     vFile = Application.GetOpenFilename("All Files, *.xlsx; *.xlsm")
     If TypeName(vFile) = "String" Then MoveFile vFile
   End Sub

   Các bạn test thử xem!

   có chút bối rối . hi hi
   lNv63UHijWs

   Kỳ vậy ta? Mình test nó chạy phà phà luôn ấy chứ
   Thử đổi câu lệnh:

   CreateObject("WScript.Shell").Popup "Cho mot chút!", 4, "THÔNG BÁO"

   Thành:

   Application.Wait Now + TimeValue("0:00:4")

   và test lại xem sao
   (đang nghi thằng Popup có vấn đề)
   File đính kèm dưới đây là kết quả sau khi chạy code tại máy mình. Bạn tải về xem thử có mở được trên máy bạn không nha? Nếu như mở được thì kiểm tra xem còn styles rác nào không?
   Chờ kết quả

   file này đã xóa 2 style rác rồi , mở bình thường . để tí em vác code sang máy 32 bit chạy coi có bị không . hình như máy em không có duyên với code thầy NDU rồi . hic

   Vậy thử coi Vide của mình nha
   0_Auns_oYXc

   Ta có thể phân ra từng công đoạn để test:
   – Dùng code giải nén file xlsx để lấy ra file styles.xml
   – Dùng code xóa styles rác
   – Dùng code nén file styles.xml (đã được xóa styles) vào lại file xlsx
   Test riêng từng công đoạn một để biết vấn đề nằm chỗ nào
   ————————-

   không biết nên vui hay nên buồn . code của thầy Tuấn đem qua máy 32 bit chạy ngon ơ . thầy trò ta kị hệ rồi chăng +-+-+-++-+-+-+
   thầy cầm tinh con gì á thầy …….

   Thì cứ thử theo bài 114 xem. Phân từng đoạn để test xem vấn đề nằm ở đâu (gọi là "khoanh vùng đối tượng") –=0

   em đã suy nghĩ và khoanh vùng từ trước khi gửi bài #102 rồi . em mới dám chỉ mũi tên đích danh vào hàm FileToZip . em đang xem coi tại sao cứ chạy hàm này là coprupt luôn file zip nè . máy 32 bit thì hoàn toàn không có vấn đề.
   tôi xin tuyên bố : thầy trò Đường Tam Tạng đã qua được 1 kiếp nạn
   máy 64 bit đôi lúc không chấp nhận copy đè lên file có trước trong 1 file nén <==== corrupt File nén
   vậy ta phải đi đường vòng , tôi sửa lại hàm FileToZip

   Function FileToZip(ByVal filePath, Optional ByVal ZipTo) As Boolean
     Dim FSO As Object, sFolder, sName, sFile, sRac
     On Error GoTo ErrHandler
     Set FSO = CreateObject("Scripting.FileSystemObject")
     If FSO.fileexists(filePath) Then
       sFolder = FSO.GetFile(filePath).ParentFolder
       If Right$(sFolder, 1) <> "" Then sFolder = sFolder & ""
       sName = FSO.GetBaseName(filePath)
       sFile = FSO.GetFileName(filePath)
       If IsMissing(ZipTo) Then ZipTo = CreateNewZip(sFolder & sName & ".zip")
       sRac = ThisWorkbook.Path & "ThungRac"
       If Not FSO.FolderExists(sRac) Then FSO.CreateFolder sRac
       With CreateObject("Shell.Application")
           If Not FSO.fileexists(ZipTo) And Right(ZipTo, 4) = ".zip" Then ZipTo = CreateNewZip(ZipTo)
           If Not .Namespace(ZipTo).items.Item(sFile) Is Nothing Then
               .Namespace(sRac).movehere .Namespace(ZipTo).items.Item(sFile), 20  '<= phải đuổi vợ  mới đón bồ nhí được
           End If
           .Namespace(ZipTo).movehere .Namespace(sFolder).items.Item(sFile)
       End With
       FSO.DeleteFolder sRac
       FileToZip = (Err.Number = 0)
       Exit Function
   ErrHandler:     MsgBox Err.Description
     End If
   End Function

   Reply
6. hands says:

   15/01/2023 at 3:01 pm

   Mới thử rồi vẫn vậy cả winxp+7….hay code mình copy trên đó sửa tới lui nhiêu lần có gì sai….bạn úp file Test_Zipfile_V01 của bạn lên mình thử lai coi

   nó đây nè . hôm bữa tôi nhìn tổng dung lượng tối đa của tôi là 15MB . sao hôm nay tự nhiên tăng lên thành 50MB kì vậy ta ?

   Mới test kết quả theo Video
   Zqs5vv1gNbg

   vậy rốt cục là sao ?

   đã tìm ra nguyên nhân đơ máy là xài Function củ sau….Sorry….+-+-+-+–=0
   Public Function UnZip(ByVal ZipFilePath, Optional ByVal ZipToFd) As Boolean
   Dim FSO As Object
   On Error GoTo ErrHandler
   Set FSO = CreateObject("Scripting.FileSystemObject")
   If FSO.fileexists(ZipFilePath) Then
   If IsMissing(ZipToFd) Then ZipToFd = FSO.GetFile(ZipFilePath).ParentFolder.Path
   With CreateObject("Shell.Application")
   .Namespace(ZipToFd).copyhere .Namespace(ZipFilePath).items
   End With
   UnZip = (Err.Number = 0)
   Exit FunctionErrHandler: MsgBox Err.Description
   End If
   End Function

   xin phép được viết lại hàm xóa Style rác trong file xml của thầy NDU
   cách này chắc sẽ chậm hơn cách của thầy . Nhưng được cái dễ xài hơn . hi hi

   Public Function ClearStyleXML(ByVal xmlFile As String) As Boolean
   Dim doc As Object, xNode, n As Long
   Set doc = CreateObject("Microsoft.XMLDOM")
   doc.Load xmlFile
   For Each xNode In doc.SelectNodes("/styleSheet/cellStyles/cellStyle")
       If TypeName(xNode.Attributes.getNamedItem("builtinId")) = "Nothing" Then
           xNode.ParentNode.RemoveChild xNode
           n = n + 1
       End If
   Next
   If n > 0 Then
       MsgBox "Da xoa xong " & n & " styles rác"
       doc.Save xmlFile
       ClearStyleXML = True
   Else
       MsgBox "Không có styles rác nào"
       ClearStyleXML = False
   End If
   End Function

   Reply
7. hands says:

   15/01/2023 at 3:02 pm

   phải có bác Tài thì xe mới chạy được chứ ! chúng ta thì làm gì được .

   Ủa! Mình tưởng "đồ chơi" như vậy là đủ rồi chứ, giờ muốn làm cái gì các bạn tự sáng tạo thôi

   thầy nói vậy em nghe sao thấy đau lòng quá đi …. nói sao nhỉ ?
   không phải ai cũng mạnh mẽ như thầy … hi hi .
   biết giải nén file xml là 1 chuyện . hiểu được cấu trúc file xml đó và sửa nó theo ý mình lại là 1 con đường xa thăm thẳm trời đất .
   thôi thì bữa nào rảnh nghiên cứu lại vậy . nếu em có nói câu gì không phải mong thầy bỏ quá nhé thầy . hi

   Thì tôi cũng có hiểu cấu trúc xml gì đâu trời! Toàn đoán và mò thôi mà. Mọi người cũng cùng.. mò xem có gì lạ trong xml thì hãy chia sẻ

   Reply