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

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

doveandrose đã viết:
ca này cực khó . sửa code chạy lỗi trên máy em mà em còn lên bờ xuống ruộng nữa là đi sửa lỗi trên máy anh =))

Vụ này mình chỉ theo học tập và test code thôi......chứ ko giúp được gì hết á.... --=0

doveandrose · 26/9/15

kieu manh đã viết:
Vụ này mình chỉ theo học tập và test code thôi......chứ ko giúp được gì hết á....

cái đơ máy của anh em đoán 90 % là do hàm Application.Wait . để mai em coi lại

ndu96081631 · 27/9/15

doveandrose đã viết:

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

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

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

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

PHP:

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

doveandrose · 27/9/15

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

PHP:

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

doveandrose đã viết:
ở 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 · 27/9/15

kieu manh đã viết:
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 · 27/9/15

doveandrose đã viết:
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 · 27/9/15

kieu manh đã viết:
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 · 27/9/15

kieu manh đã viết:
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 · 27/9/15

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

PHP:

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

doveandrose đã viết:
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 · 27/9/15

kieu manh đã viết:
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 · 27/9/15

doveandrose đã viết:
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 · 27/9/15

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

Mã:

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 · 10/10/15

Bạn Hiền

doveandrose

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

doveandrose · 10/10/15

kieu manh đã viết:
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 · 10/10/15

doveandrose đã viết:
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 · 10/10/15

ndu96081631 đã viết:
Ủ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 · 10/10/15

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

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

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

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

hello

File đính kèm

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

hello

hello

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

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

hello

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

hello

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

hello

Huyền thoại GPE

hello

Huyền thoại GPE

Facebook

Group