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

doveandrose · 24/9/15

quocphuoc88 đã viết:
Máy e trơn tru . Tạo file nén KHÔNG RỖNG !

trơn quá té bạn ơi . bạn nén file 200Mb thử xem chữ "Done" xuất hiện khi nào . hi hi

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

doveandrose đã viết:
trơn quá té bạn ơi . bạn nén file 200Mb thử xem chữ "Done" xuất hiện khi nào . hi hi

định làm khó sao .... }}}}}

...càng về cuối càng hay đây

doveandrose · 24/9/15

kieu manh đã viết:
định làm khó sao .......càng về cuối càng hay đây

em làm sao dám giỡn mặt với quần hùng . ai nén file vài trăm MB là thấy rồi . ca này vui nè : làm sao tắt bảng thông báo đang nén mặc định của Hệ điều hành đây ........

ndu96081631 · 24/9/15

doveandrose đã viết:
trơn quá té bạn ơi . bạn nén file 200Mb thử xem chữ "Done" xuất hiện khi nào . hi hi

Cái vụ đó bỏ qua! Bởi mục đích chính của ta hoàn toàn không phải muốn thay thể chương trình WinRAR hay WinZIP. Điều ta cần cuối cùng là EDIT FILE XML NẰM TRONG FILE XLSX, XLSM

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

doveandrose đã viết:
em làm sao dám giỡn mặt với quần hùng . ai nén file vài trăm MB là thấy rồi . ca này vui nè : làm sao tắt bảng thông báo đang nén mặc định của Hệ điều hành đây ........

Mới thử thấy hình sau
File 1,557,618KB chạy tốt nhưng hơi chậm thôi

doveandrose · 24/9/15

ndu96081631 đã viết:
Cái vụ đó bỏ qua! Bởi mục đích chính của ta hoàn toàn không phải muốn thay thể chương trình WinRAR hay WinZIP. Điều ta cần cuối cùng là EDIT FILE XML NẰM TRONG FILE XLSX, XLSM

vâng có lẽ em đi lạc đề rồi . Thầy định hướng lại đi . sau đây chúng ta sẽ làm gì ?

leonguyenz · 24/9/15

ndu96081631 đã viết:
Đây là "công trình" đầu tiên của việc nén file:

Mã:

Dim [COLOR=#ff0000]ZipFilePath, sFolder, sName[/COLOR], sFile As String

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

sName As String vẫn chạy bình thường thầy ạ (tại không thấy ai phản hồi cái này).
Windows 7, Excel 2007

ndu96081631 · 24/9/15

doveandrose đã viết:
sau đây chúng ta sẽ làm gì ?

Như chủ đề topic, ta đã nén được rồi thì giờ tiên hành giải nén
(tuy nhiên các bạn khác cứ test thử code bài 61 xem còn lỗi gì không đã)

doveandrose · 24/9/15

leonguyenz đã viết:
sName As String vẫn chạy bình thường thầy ạ (tại không thấy ai phản hồi cái này).
Windows 7, Excel 2007

thì vẫn chạy bình thường là đúng rồi . vì đâu có lệnh nào là .Namespace(sName) ở trong bài đâu . hi hi

ndu96081631 · 24/9/15

Anh Chim Hồng và các bạn khác làm tiếp công đoạn giải nén xem nào
(viết hoài mệt quá)

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

ndu96081631 đã viết:
Anh Chim Hồng và các bạn khác làm tiếp công đoạn giải nén xem nào
(viết hoài mệt quá)

nén và Giải nén OK..........Tuyệt

doveandrose · 24/9/15

bị nêu đích danh ngại quá

Mã:

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 Function
ErrHandler:     MsgBox Err.Description
  End If
End Function

Mã:

Sub TestZipFile()
  Dim bRet As Boolean
  Dim vFile
  vFile = Application.GetOpenFilename("All Files, *.zip")
  If TypeName(vFile) = "String" Then
    bRet = UnZip(vFile, "d:\")
    If bRet Then MsgBox "Done!"
  End If
End Sub

ndu96081631 · 24/9/15

doveandrose đã viết:

bị nêu đích danh ngại quá

Mã:

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 Function
ErrHandler:     MsgBox Err.Description
  End If
End Function

Mã:

Sub TestZipFile()
  Dim bRet As Boolean
  Dim vFile
  vFile = Application.GetOpenFilename("All Files, *.zip")
  If TypeName(vFile) = "String" Then
    bRet = UnZip(vFile, "d:\")
    If bRet Then MsgBox "Done!"
  End If
End Sub

Theo tiêu chí mà ta đang hướng tới thì code cần hoàn thiện là:
- Code có khả năng nén 1 file vào trong 1 file zip có sẵn (nếu file zip chưa có thì mới tạo NewZip)
- Code có khả năng giải nén 1 file chỉ định nào đó bên trong file zip đang chứa nhiều files khác (có thể ta chỉ cần edit 1 file nào đó trong file zip mà thôi)

doveandrose · 24/9/15

hi hi . nhưng mà cơm nước cái đã . tí nữa mà chưa có ai làm thì em lại tiếp tục vậy :-=

ndu96081631 · 24/9/15

doveandrose đã viết:
hi hi . nhưng mà cơm nước cái đã . tí nữa mà chưa có ai làm thì em lại tiếp tục vậy

Cơm xong uống nước lọc thôi, đừng uống nước cái ---> "bay" hổng nỗi luôn đóa --=0

doveandrose · 24/9/15

ndu96081631 đã viết:
Theo tiêu chí mà ta đang hướng tới thì code cần hoàn thiện là:
- Code có khả năng nén 1 file vào trong 1 file zip có sẵn (nếu file zip chưa có thì mới tạo NewZip)
- Code có khả năng giải nén 1 file chỉ định nào đó bên trong file zip đang chứa nhiều files khác (có thể ta chỉ cần edit 1 file nào đó trong file zip mà thôi)

rồi chúng ta tiếp tục . bây giờ làm câu 1 trước

Mã:

Function FileToZip(ByVal FilePath, Optional ByVal ZipTo, Optional ByVal seekPath) As Boolean
  'ZipTo : Full Name of Existing Zip file
  'seekPath : path in Existing Zip file
  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")
    If Not fso.FileExists(ZipTo) Then ZipTo = CreateNewZip(sFolder & sName & ".zip")
    If Not IsMissing(seekPath) Then ZipTo = ZipTo & "\" & seekPath
    With CreateObject("Shell.Application")
      .Namespace(ZipTo).Copyhere .Namespace(sFolder).items.Item(sFile)
    End With
    FileToZip = (Err.Number = 0)
    Exit Function
ErrHandler:     MsgBox Err.Description
  End If
End Function

ndu96081631 · 24/9/15

doveandrose đã viết:
r
khi dialogfile mở lên nhớ chọn file excel thôi nhé

Kết quả test:
- Chạy lần đầu, chọn file b1.xlsx nó ra kết quả b1.xlsx nằm trong b1.zip
- Chạy lần hai, vẫn chọn file b1.xlsx nó ra kết quả b1.xlsx nằm trong b1.xlsx.zip
Trong khi câu lệnh của ta là:

Mã:

bRet = FileToZip(vFile, [COLOR=#ff0000]ThisWorkbook.Path & "\b1.xlsx.zip"[/COLOR])

Đã chỉ rõ nơi đến thì lần đầu chạy hay lần hai cũng phải cho cùng kết quả chứ nhỉ?

doveandrose · 24/9/15

ndu96081631 đã viết:
Kết quả test:
- Chạy lần đầu, chọn file b1.xlsx nó ra kết quả b1.xlsx nằm trong b1.zip
- Chạy lần hai, vẫn chọn file b1.xlsx nó ra kết quả b1.xlsx nằm trong b1.xlsx.zip
Trong khi câu lệnh của ta là:

Mã:

bRet = FileToZip(vFile, [COLOR=#ff0000]ThisWorkbook.Path & "\b1.xlsx.zip"[/COLOR])

Đã chỉ rõ nơi đến thì lần đầu chạy hay lần hai cũng phải cho cùng kết quả chứ nhỉ?

cho thử sức cái nữa . hi hi

Mã:

Function FileToZip(ByVal FilePath, Optional ByVal ZipTo, Optional ByVal seekPath) As Boolean
  'ZipTo : Full Name of Existing Zip file
  'path in Existing Zip file
  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")
    If Not fso.FileExists(ZipTo) Then ZipTo = CreateNewZip(ZipTo)
    If Not IsMissing(seekPath) Then ZipTo = ZipTo & "\" & seekPath
    With CreateObject("Shell.Application")
      .Namespace(ZipTo).Copyhere .Namespace(sFolder).items.Item(sFile)
    End With
    FileToZip = (Err.Number = 0)
    Exit Function
ErrHandler:     MsgBox Err.Description
  End If
End Function

ndu96081631 · 24/9/15

doveandrose đã viết:

cho thử sức cái nữa . hi hi

Mã:

Function FileToZip(ByVal FilePath, Optional ByVal ZipTo, Optional ByVal seekPath) As Boolean
  'ZipTo : Full Name of Existing Zip file
  'path in Existing Zip file
  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")
    If Not fso.FileExists(ZipTo) Then ZipTo = CreateNewZip(ZipTo)
    If Not IsMissing(seekPath) Then ZipTo = ZipTo & "\" & seekPath
    With CreateObject("Shell.Application")
      .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ới thử sơ qua ---> Kết quả ngon
Giờ phải vào ca 3, tối nay nếu rảnh sẽ test tiếp

doveandrose · 24/9/15

ndu96081631 đã viết:
Mới thử sơ qua ---> Kết quả ngon
Giờ phải vào ca 3, tối nay nếu rảnh sẽ test tiếp

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

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

hello

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

hello

Huyền thoại GPE

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

File đính kèm

hello

Thành viên gạo cội

Huyền thoại GPE

hello

Huyền thoại GPE

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

hello

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

hello

Đếm ngược thời gian