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

ndu96081631 · 23/9/15

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 · 25/9/15

doveandrose đã viết:
vâng chào "bác Tài" . khi nào "bác Tài" quay lại thì đoàn lại tiếp tục . hi hi

Ôi! Dù là "bác Tài" thì cũng có lúc phải nghỉ chứ, vậy sẽ có "bác Tài" khác thay thế hen!
Tuy nhiên, mình chẳng bao giờ nghĩ mình là "bác Tài". Mình chỉ muốn là người truyền cảm hứng để các bạn thấy yêu Excel hơn mà thôi
Rất mong nhiều bạn khác nữa cùng tham gia cuộc chơi
(hãy cứ nghĩ đây là cuộc chơi cho nó đở căng thẳng)

doveandrose · 25/9/15

ồ thầy quay lại rồi . Chúng ta lại tiếp tục nào

doveandrose · 25/9/15

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

Mã:

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

Mã:

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

ndu96081631 · 25/9/15

doveandrose đã viết:

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

Mã:

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

Mã:

bRet = UnZip(vFile)
'bRet = UnZip(vFile, , "[Content_Types].xml")
'bRet = UnZip(vFile, , "sheet2.xml", "xl\worksheets")
'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

doveandrose · 25/9/15

ndu96081631 đã viết:
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

ndu96081631 · 25/9/15

doveandrose đã viết:
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é:

Mã:

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

Hoặc vầy:

Mã:

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]"xl\styles.xml"[/COLOR])
  End With
End Sub

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

doveandrose · 25/9/15

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

Cá ngừ F1 · 25/9/15

ndu96081631 đã viết:
Ôi! Dù là "bác Tài" thì cũng có lúc phải nghỉ chứ, vậy sẽ có "bác Tài" khác thay thế hen!
Tuy nhiên, mình chẳng bao giờ nghĩ mình là "bác Tài". Mình chỉ muốn là người truyền cảm hứng để các bạn thấy yêu Excel hơn mà thôi
Rất mong nhiều bạn khác nữa cùng tham gia cuộc chơi
(hãy cứ nghĩ đây là cuộc chơi cho nó đở căng thẳng)

N ĐÚ luôn luôn là người truyền cảm hứng cho anh em GPE học hỏi. }}}}}

Tuy nhiên, em chưa hiểu ứng dụng của Topic này là gì (chắc bị V Ba cho tầu hỏa nhập ma rồi +-+-+-+

)

ndu96081631 · 25/9/15

Cá ngừ F1 đã viết:
Tuy nhiên, em chưa hiểu ứng dụng của Topic này là gì

Chú này! Nói cả đống bài trong topic này rồi còn gì (về mục đích)
Chắc chưa đọc hết?

ndu96081631 · 25/9/15

doveandrose đã viết:
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.zip\xl\styles.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

doveandrose · 25/9/15

ndu96081631 đã viết:
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.zip\xl\styles.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

ndu96081631 · 25/9/15

doveandrose đã viết:
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:

Mã:

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

doveandrose · 25/9/15

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

Mã:

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

Mã:

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

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.zip\xl")
    
    'bRet = UnZip(vFile)
    'bRet = UnZip(vFile & "\[Content_Types].xml")
    bRet = UnZip(vFile & "\xl")
    If bRet Then MsgBox "Done!"
  End If
End Sub

ndu96081631 · 26/9/15

doveandrose đã viết:
theo ý thầy , em sửa lại

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:

Mã:

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!

doveandrose · 26/9/15

ẹ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 ạ ?

ndu96081631 · 26/9/15

doveandrose đã viết:
ẹ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ó

ndu96081631 · 26/9/15

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 ý

doveandrose · 26/9/15

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ó

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

doveandrose · 26/9/15

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

Kiều Mạnh · 26/9/15

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

Mình mới thử thấy file Zip ok mà

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

Huyền thoại GPE

Huyền thoại GPE

hello

hello

File đính kèm

Huyền thoại GPE

hello

Huyền thoại GPE

hello

( ͡° ͜ʖ ͡°)

Huyền thoại GPE

Huyền thoại GPE

hello

Huyền thoại GPE

hello

File đính kèm

Huyền thoại GPE

hello

Huyền thoại GPE

Huyền thoại GPE

hello

hello

File đính kèm

I don't program, I beat code into submission!!!

Đếm ngược thời gian