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

 

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