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

 

[Kiều Mạnh]

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

Em mới thử máy Winxp+Office2010 vẫn đơ như vậy lâu quá em tắt = start task manager thì báo lỗi dòng sau

If Not FSO.fileexists(ZipTo) And Right(ZipTo, 4) = ".zip" Then ZipTo = CreateNewZip(ZipTo)

 

[doveandrose]

Em mới thử máy Winxp+Office2010 vẫn đơ như vậy lâu quá em tắt = start task manager thì báo lỗi dòng sau

If Not FSO.fileexists(ZipTo) And Right(ZipTo, 4) = ".zip" Then ZipTo = CreateNewZip(ZipTo)

ở lệnh application.Wait anh sửa lại
Application.Wait (Now + 0.000005) (có 5 số 0 sau dấu chấm) => khoảng nửa giây

 

[Kiều Mạnh]

ở lệnh application.Wait anh sửa lại
Application.Wait (Now + 0.000005) (có 5 số 0 sau dấu chấm) => khoảng nửa giây

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

 

[doveandrose]

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 ?

 

[Kiều Mạnh]

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
[video=youtube;Zqs5vv1gNbg]https://www.youtube.com/watch?v=Zqs5vv1gNbg&feature=youtu.be[/video]

 

[doveandrose]

Cũng đơ vậy mình cứ nghĩ copy code lộn

có đang online không , gửi số Team viewer vào hộp thư của em

 

[doveandrose]

Mới test kết quả theo Video
[video=youtube;Zqs5vv1gNbg]https://www.youtube.com/watch?v=Zqs5vv1gNbg&feature=youtu.be[/video]

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

 

[Kiều Mạnh]

đã tìm ra nguyên nhân đơ máy là xài Function củ sau....Sorry....

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

 

[Kiều Mạnh]

có đang online không , gửi số Team viewer vào hộp thư của em

Gửi rồi đó bản Team viewer 10 nha

 

[doveandrose]

Gửi rồi đó bản Team viewer 10 nha

hết chuyện rồi gửi làm chi nữa

 

[Kiều Mạnh]

hết chuyện rồi gửi làm chi nữa

Mới test Winxp cũng ok ...vậy là tốt rồi

 

[doveandrose]

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

 

[Kiều Mạnh]

Bạn Hiền
doveandrose


Lâu quá nhớ đề tài này ghê.............

 

[doveandrose]

Bạn Hiền
doveandrose


Lâu quá nhớ đề tài này ghê.............

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

 

[ndu96081631]

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

 

[doveandrose]

Ủ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

 

[ndu96081631]

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ẻ

 

[saobekhonglac]

"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

Nếu nén 1 lần nhiều folder thì có được không vậy Anh.