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

[ndu96081631]

Tôi mở topic này nhằm mục đích cùng nhau nghiên cứu về nén và giải nén dùng công cụ VBA
Đầu tiên chúng ta cùng làm cuộc thí nghiệm nhỏ sau:
- Click chuột phải trên Desktop, chọn New ---> WinRAR archive (hoặc WinRAR Zip archive). Đương nhiên ta sẽ nhận được một file RAR hoặc ZIP trắng
- Tiếp theo khởi động Notepad
- Dùng chuột nắm kéo file RAR (hoặc ZIP) mới vừa tạo thả vào cửa sổ Notepad
Các bạn nhìn thấy cái gì trong Notepad?
Mời trả lời rồi chúng ta sẽ tiếp tục

 

[ndu96081631]

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

 

[ndu96081631]

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 & ".zip\xl\styles.xml")
    Do While Not .fileexists(sPath)
       Application.Wait (Now + 0.0005)
    Loop
    If ClearStylesFromXML(sPath) Then
      bRet = FileToZip(sPath, filePath & ".zip\xl")
      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!

 

[Kiều Mạnh]

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 & ".zip\xl\styles.xml")
    Do While Not .fileexists(sPath)
       Application.Wait (Now + 0.0005)
    Loop
    If ClearStylesFromXML(sPath) Then
      bRet = FileToZip(sPath, filePath & ".zip\xl")
      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!

Em mới thử chạy nó đơ ra rất lâu phải tắt bằng Start Task Manager thì mới được
xong tao ra 1 File zip

 

[ndu96081631]

Em mới thử chạy nó đơ ra rất lâu phải tắt bằng Start Task Manager thì mới được
xong tao ra 1 File zip

Có thấy hiện ra thông báo nào không?

 

[Kiều Mạnh]

Có thấy hiện ra thông báo nào không?

Em thấy lâu quá không đủ kiên nhẫn chờ tắt luôn

 

[doveandrose]

có chút bối rối . hi hi
[video=youtube;lNv63UHijWs]https://www.youtube.com/watch?v=lNv63UHijWs[/video]

 

[ndu96081631]

Em thấy lâu quá không đủ kiên nhẫn chờ tắt luôn

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 đề)

 

[ndu96081631]

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

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ả

 

[doveandrose]

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

 

[Kiều Mạnh]

Vậy thử coi Vide của mình nha
[video=youtube;0_Auns_oYXc]https://www.youtube.com/watch?v=0_Auns_oYXc&feature=youtu.be[/video]

 

[ndu96081631]

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

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
-------------------------

Vậy thử coi Vide của mình nha
[video=youtube;0_Auns_oYXc]https://www.youtube.com/watch?v=0_Auns_oYXc&feature=youtu.be[/video]

Video này không mở được

 

[doveandrose]

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 .......

 

[ndu96081631]

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")

 

[doveandrose]

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")

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 đề

 

[doveandrose]

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

 

[Kiều Mạnh]

Mới thử Code bài 118 nó cũng đơ như cái video bài 113

 

[doveandrose]

Mới thử Code bài 118 nó cũng đơ như cái video bài 113

ca này cực khó . sửa code chạy lỗi trên máy em mà em còn lên bờ xuống ruộng nữa là đi sửa lỗi trên máy anh =))

 

[Kiều Mạnh]

ca này cực khó . sửa code chạy lỗi trên máy em mà em còn lên bờ xuống ruộng nữa là đi sửa lỗi trên máy anh =))

Vụ này mình chỉ theo học tập và test code thôi......chứ ko giúp được gì hết á....

 

[doveandrose]

Vụ này mình chỉ theo học tập và test code thôi......chứ ko giúp được gì hết á....

cái đơ máy của anh em đoán 90 % là do hàm Application.Wait . để mai em coi lại

 

[ndu96081631]

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

Code này trên máy mình chạy được luôn
(chỉ có 3 người test tới test lui ---> Làm gì ăn đây ta?)