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

Liên hệ QC
ndu96081631

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia
5/6/08
Bài viết
30,703
Được thích
53,930
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
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
ndu96081631 đã viết:
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ó
Nhấp chuột vào đây để mở rộng...

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

File đính kèm

  • do choi.rar
    871.8 KB · Đọc: 15
Upvote 0
doveandrose đã viết:
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
Nhấp chuột vào đây để mở rộng...
Mình mới thử thấy file Zip ok mà
 
Upvote 0
doveandrose đã viết:
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
Nhấp chuột vào đây để mở rộng...

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:
ndu96081631 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
 
Lần chỉnh sửa cuối:
Upvote 0
Tôi sửa sub ClearStylesFromXML thành Function ClearStylesFromXML
Mã: 
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:
Mã: 
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!
 
Lần chỉnh sửa cuối:
Upvote 0
ndu96081631 đã viết:
Tôi sửa sub ClearStylesFromXML thành Function ClearStylesFromXML
Mã: 
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:
Mã: 
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!
Nhấp chuột vào đây để mở rộng...
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
 
Lần chỉnh sửa cuối:
Upvote 0
có chút bối rối . hi hi
[video=youtube;lNv63UHijWs]https://www.youtube.com/watch?v=lNv63UHijWs[/video]
 
Upvote 0
kieu manh đã viết:
Em thấy lâu quá không đủ kiên nhẫn chờ tắt luôn
Nhấp chuột vào đây để mở rộng...

Kỳ vậy ta? Mình test nó chạy phà phà luôn ấy chứ
Thử đổi câu lệnh:
Mã: 
CreateObject("WScript.Shell").Popup "Cho mot chút!", 4, "THÔNG BÁO"
Thành:
Mã: 
 Application.Wait Now + TimeValue("0:00:4")
và test lại xem sao
(đang nghi thằng Popup có vấn đề)
 
Lần chỉnh sửa cuối:
Upvote 0
doveandrose đã viết:
có chút bối rối . hi hi
Nhấp chuột vào đây để mở rộng...

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 đính kèm

  • DAILY % NG JUL.2015.xlsx
    536 KB · Đọc: 15
Upvote 0
ndu96081631 đã viết:
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ả
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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]
 
Lần chỉnh sửa cuối:
Upvote 0
doveandrose đã viết:
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
Nhấp chuột vào đây để mở rộng...

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
-------------------------
kieu manh đã viết:
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]
Nhấp chuột vào đây để mở rộng...
Video này không mở được
 
Upvote 0
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 .......
 
Upvote 0
doveandrose đã viết:
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 .......
Nhấp chuột vào đây để mở rộng...

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
 
Upvote 0
ndu96081631 đã viết:
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
Nhấp chuột vào đây để mở rộ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 đề
 
Upvote 0
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
Mã: 
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
 
Upvote 0
Mới thử Code bài 118 nó cũng đơ như cái video bài 113
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

LuuAnh980
Vấn đề viết tắt trong Diễn Đàn.
    • Thích
    • Cười
2 3
Trả lời
56
Đọc
1K
SA_DQ
SA_DQ
Tuấn Bụng Bự
  • Question
Hiển thị UserForm theo vị trí ô cell được chọn
Trả lời
0
Đọc
21
Tuấn Bụng Bự
Tuấn Bụng Bự
V
  • Question
GIúp code xóa các tên mặt hàng trùng nhau, chỉ chừa lại tên cho dòng trên cùng
Trả lời
14
Đọc
410
Văn Toàn 1996
V
solomon2211
PDF Tools giúp ghép, tách, xóa file pdf
    • Thích
    • Yêu thích
Trả lời
15
Đọc
279
cantl
C
T
xin công thức tính kết chuyển lỗ vào thu nhập tính thuế TNDN trong nhiều năm
Trả lời
1
Đọc
68
HieuCD
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom