Vọc chơi với những thuật toán nén và giải nén file (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
ndu96081631

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia
5/6/08
Bài viết
30,703
Được thích
53,970
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
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
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
Nhấp chuột vào đây để mở rộng...

Tôi kiểm tra đâu thấy "đi đời" gì đâu, chỉ là file xlsx ấy còn y nguyên 2 styles rác
Còn 1 chuyện nữa: Nếu file cần xóa styles, sau khi qua xử lý nhận đươc thông báo "không có styles rác nào" thì ta bỏ qua công đoạn nén file luôn chứ
Bởi vậy tôi cẩn thận gợi ý lần trước rằng:
ndu96081631 đã viết:
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
Nhấp chuột vào đây để mở rộng...
Dựa vào kết quả mà hàm trả về, ta biết được có styles rác hay không rồi mới tính tiếp
 
Lần chỉnh sửa cuối:
Upvote 0
Tôi sửa sub ClearStylesFromXML thành Function ClearStylesFromXML
Mã: 
Function ClearStylesFromXML(ByVal xmlFile As String) As Boolean
  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 Function
    If .GetFile(xmlFile).Name <> "styles.xml" Then Exit Function
    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"
       ClearStylesFromXML = True
    Else
      MsgBox "Không có styles rác nào"
      ClearStylesFromXML = False
    End If
  End With
End Function
Đồng thời sửa 2 sub cuối thành:
Mã: 
Private Sub MoveFile(ByVal filePath As String)
  Dim FSO As Object, bRet As Boolean, sPath, ext As String
  Set FSO = CreateObject("Scripting.FileSystemObject")
  ext = FSO.GetExtensionName(filePath)
  If (UCase(ext) <> "XLSX") And (UCase(ext) <> "XLSM") Then Exit Sub
  With FSO
    .MoveFile filePath, filePath & ".zip"
    sPath = ThisWorkbook.Path & "\styles.xml"
    If .fileexists(sPath) Then .DeleteFile (sPath)
    bRet = UnZip(filePath & ".zip\xl\styles.xml")
    Do While Not .fileexists(sPath)
       Application.Wait (Now + 0.0005)
    Loop
    If ClearStylesFromXML(sPath) Then
      bRet = FileToZip(sPath, filePath & ".zip\xl")
      CreateObject("WScript.Shell").Popup "Cho mot chút!", 4, "THÔNG BÁO"
    End If
    .MoveFile filePath & ".zip", filePath
    .DeleteFile sPath
  End With
  MsgBox "done"
End Sub
Sub TestZipFile()
  Dim bRet As Boolean, vFile
  vFile = Application.GetOpenFilename("All Files, *.xlsx; *.xlsm")
  If TypeName(vFile) = "String" Then MoveFile vFile
End Sub
Các bạn test thử xem!
 
Lần chỉnh sửa cuối:
Upvote 0
ndu96081631 đã viết:
Tôi sửa sub ClearStylesFromXML thành Function ClearStylesFromXML
Mã: 
Function ClearStylesFromXML(ByVal xmlFile As String) As Boolean
  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 Function
    If .GetFile(xmlFile).Name <> "styles.xml" Then Exit Function
    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"
       ClearStylesFromXML = True
    Else
      MsgBox "Không có styles rác nào"
      ClearStylesFromXML = False
    End If
  End With
End Function
Đồng thời sửa 2 sub cuối thành:
Mã: 
Private Sub MoveFile(ByVal filePath As String)
  Dim FSO As Object, bRet As Boolean, sPath, ext As String
  Set FSO = CreateObject("Scripting.FileSystemObject")
  ext = FSO.GetExtensionName(filePath)
  If (UCase(ext) <> "XLSX") And (UCase(ext) <> "XLSM") Then Exit Sub
  With FSO
    .MoveFile filePath, filePath & ".zip"
    sPath = ThisWorkbook.Path & "\styles.xml"
    If .fileexists(sPath) Then .DeleteFile (sPath)
    bRet = UnZip(filePath & ".zip\xl\styles.xml")
    Do While Not .fileexists(sPath)
       Application.Wait (Now + 0.0005)
    Loop
    If ClearStylesFromXML(sPath) Then
      bRet = FileToZip(sPath, filePath & ".zip\xl")
      CreateObject("WScript.Shell").Popup "Cho mot chút!", 4, "THÔNG BÁO"
    End If
    .MoveFile filePath & ".zip", filePath
    .DeleteFile sPath
  End With
  MsgBox "done"
End Sub
Sub TestZipFile()
  Dim bRet As Boolean, vFile
  vFile = Application.GetOpenFilename("All Files, *.xlsx; *.xlsm")
  If TypeName(vFile) = "String" Then MoveFile vFile
End Sub
Các bạn test thử xem!
Nhấp chuột vào đây để mở rộng...
Em mới thử chạy nó đơ ra rất lâu phải tắt bằng Start Task Manager thì mới được
xong tao ra 1 File zip
 
Lần chỉnh sửa cuối:
Upvote 0
có chút bối rối . hi hi
[video=youtube;lNv63UHijWs]https://www.youtube.com/watch?v=lNv63UHijWs[/video]
 
Upvote 0
kieu manh đã viết:
Em thấy lâu quá không đủ kiên nhẫn chờ tắt luôn
Nhấp chuột vào đây để mở rộng...

Kỳ vậy ta? Mình test nó chạy phà phà luôn ấy chứ
Thử đổi câu lệnh:
Mã: 
CreateObject("WScript.Shell").Popup "Cho mot chút!", 4, "THÔNG BÁO"
Thành:
Mã: 
 Application.Wait Now + TimeValue("0:00:4")
và test lại xem sao
(đang nghi thằng Popup có vấn đề)
 
Lần chỉnh sửa cuối:
Upvote 0
doveandrose đã viết:
có chút bối rối . hi hi
Nhấp chuột vào đây để mở rộng...

File đính kèm dưới đây là kết quả sau khi chạy code tại máy mình. Bạn tải về xem thử có mở được trên máy bạn không nha? Nếu như mở được thì kiểm tra xem còn styles rác nào không?
Chờ kết quả
 

File đính kèm

Upvote 0
ndu96081631 đã viết:
File đính kèm dưới đây là kết quả sau khi chạy code tại máy mình. Bạn tải về xem thử có mở được trên máy bạn không nha? Nếu như mở được thì kiểm tra xem còn styles rác nào không?
Chờ kết quả
Nhấp chuột vào đây để mở rộng...
file này đã xóa 2 style rác rồi , mở bình thường . để tí em vác code sang máy 32 bit chạy coi có bị không . hình như máy em không có duyên với code thầy NDU rồi . hic
 
Upvote 0
Vậy thử coi Vide của mình nha
[video=youtube;0_Auns_oYXc]https://www.youtube.com/watch?v=0_Auns_oYXc&feature=youtu.be[/video]
 
Lần chỉnh sửa cuối:
Upvote 0
doveandrose đã viết:
file này đã xóa 2 style rác rồi , mở bình thường . để tí em vác code sang máy 32 bit chạy coi có bị không . hình như máy em không có duyên với code thầy NDU rồi . hic
Nhấp chuột vào đây để mở rộng...

Ta có thể phân ra từng công đoạn để test:
- Dùng code giải nén file xlsx để lấy ra file styles.xml
- Dùng code xóa styles rác
- Dùng code nén file styles.xml (đã được xóa styles) vào lại file xlsx
Test riêng từng công đoạn một để biết vấn đề nằm chỗ nào
-------------------------
kieu manh đã viết:
Vậy thử coi Vide của mình nha
[video=youtube;0_Auns_oYXc]https://www.youtube.com/watch?v=0_Auns_oYXc&feature=youtu.be[/video]
Nhấp chuột vào đây để mở rộng...
Video này không mở được
 
Upvote 0
không biết nên vui hay nên buồn . code của thầy Tuấn đem qua máy 32 bit chạy ngon ơ . thầy trò ta kị hệ rồi chăng +-+-+-++-+-+-+
thầy cầm tinh con gì á thầy .......
 
Upvote 0
doveandrose đã viết:
không biết nên vui hay nên buồn . code của thầy Tuấn đem qua máy 32 bit chạy ngon ơ . thầy trò ta kị hệ rồi chăng +-+-+-++-+-+-+
thầy cầm tinh con gì á thầy .......
Nhấp chuột vào đây để mở rộng...

Thì cứ thử theo bài 114 xem. Phân từng đoạn để test xem vấn đề nằm ở đâu (gọi là "khoanh vùng đối tượng") --=0
 
Upvote 0
ndu96081631 đã viết:
Thì cứ thử theo bài 114 xem. Phân từng đoạn để test xem vấn đề nằm ở đâu (gọi là "khoanh vùng đối tượng") --=0
Nhấp chuột vào đây để mở rộng...

em đã suy nghĩ và khoanh vùng từ trước khi gửi bài #102 rồi . em mới dám chỉ mũi tên đích danh vào hàm FileToZip . em đang xem coi tại sao cứ chạy hàm này là coprupt luôn file zip nè . máy 32 bit thì hoàn toàn không có vấn đề
 
Upvote 0
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
 
Upvote 0
Mới thử Code bài 118 nó cũng đơ như cái video bài 113
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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?)
 
Upvote 0
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?)
Nhấp chuột vào đây để mở rộng...
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)
 

File đính kèm

  • Capture.jpg
    Capture.jpg
    26.5 KB · Đọc: 40
Upvote 0
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)
Nhấp chuột vào đây để mở rộng...

ở 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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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 ?
 

File đính kèm

Upvote 0
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 ?
Nhấp chuột vào đây để mở rộng...
Mới test kết quả theo Video
[video=youtube;Zqs5vv1gNbg]https://www.youtube.com/watch?v=Zqs5vv1gNbg&feature=youtu.be[/video]
 
Lần chỉnh sửa cuối:
Upvote 0
đã tìm ra nguyên nhân đơ máy là xài Function củ sau....Sorry....+-+-+-+--=0
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
 
Upvote 0
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...

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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...

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ẻ
 
Upvote 0
ndu96081631 đã viết:
"Công trình" đầu tiên

Đây là "công trình" đầu tiên của việc nén file:
Mã: 
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
Nhấp chuột vào đây để mở rộng...

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

File đính kèm

Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

dungluyen2119
  • Question Question
Code VBA để tính tổng theo chiều ngang mà số cột không cố định
Trả lời
4
Đọc
73
HUONGHCKT
H
D
Lọc cột chứa nhiều nhóm từ trong Excel. Mong các bạn giải đáp giúp
Trả lời
7
Đọc
109
ptm0412
ptm0412
V
  • Question Question
Nhờ mọi người giúp cách xóa các mục đã chọn trong Droplist của một nhóm các ô cùng dạy một môn học.
Trả lời
2
Đọc
154
vinhphtdp
V
H
Câu lệnh mở file Excel trong Macbook Pro 1 (1 người xem)
Trả lời
0
Đọc
20
huafu_Jackl
H
N
Tạo COM Add-In bằng Visual C++
    • Thích
Trả lời
8
Đọc
741
nguyendang95
N
PhanTuHuong
Chương trình lập Báo cáo khảo sát Địa chất công trình GeoSection
    • Thích
Trả lời
8
Đọc
6K
PhanTuHuong
PhanTuHuong
V
  • Question Question
Xác định xu hướng cấp 1,2,3
Trả lời
0
Đọc
25
vuthienfx
V
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
384
Đọc
45K
thanhluan0912
T
Nguyễn Duy Tuân
  • Question Question
AI muốn lập trình DLL cho Excel và các loại bằng Delphi thì xem video này nhé!
    • Thích
    • Yêu thích
13 14 15
Trả lời
1K
Đọc
198K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
K
Tạo sheet tổng hợp
    • Cười
Trả lời
7
Đọc
316
SA_DQ
SA_DQ
V
Công thức để phân công chuyên môn cho giáo viên
Trả lời
9
Đọc
352
Hoàng Tuấn 868
H
Gà Con yêu VBA
Mở Pass file excel phiên bản .xlsx , xlsm, xlsb
Trả lời
4
Đọc
130
befaint
befaint
V
  • Question Question
xác định xu hướng
Trả lời
3
Đọc
136
vuthienfx
V
giaiphap
Lập trình C# tạo Add-ins cho excel.
    • Thích
Trả lời
52
Đọc
8K
nguyendang95
N
OverAC
  • Dán lên cao
  • Suggestion Suggestion
Chúc mừng sinh nhật GiaiPhapExcel 19 tuổi và tặng ebook "Lập trình VBA phần cơ bản."
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
7
Đọc
1K
PhanTuHuong
PhanTuHuong
Y
Lấy dữ liệu từ sheet chi tiết sang sheet tổng hợp hàng dọc
Trả lời
6
Đọc
588
yoomi
Y
E
Đánh số cho các cặp số chứng từ và số chứng từ đối ứng
Trả lời
16
Đọc
415
Phan Thế Hiệp
Phan Thế Hiệp
N
Hàm tính chuỗi số trong 1 ô hoặc 1 dãy ô ra tổng kết quả.
Trả lời
2
Đọc
128
minhminh27
minhminh27
NguyenthiH
Mở file Excel có Pass Open (1 người xem)
Trả lời
39
Đọc
3K
Hoàng Tuấn 868
H
M
Tách dữ liệu trong 1 file thành nhiều sheet theo số lượng dòng
    • Ngạc nhiên
Trả lời
25
Đọc
3K
Hoàng Tuấn 868
H
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom