Em Vân có Nhiều Folder, Trong mỗi Folder lại có rất nhiều các File đang được nén vào đuôi Zip. Em Vân Muốn hỏi Anh (Chị ) trên diễn đàn có cách nào dùng Vba để giải nén hết các Folder này bằng VBA hoặc 1 phần mềm đó mà vẫn thỏa mã các điều kiện
+ Giữ nguyên tên Folder
+ Các File nén trong Folder sau khi giải nén sẽ được xóa các File nén
Em Vân cảm ơn anh ( chị ) diễn đàn ạ j
Em Vân có Nhiều Folder, Trong mỗi Folder lại có rất nhiều các File đang được nén vào đuôi Zip. Em Vân Muốn hỏi Anh (Chị ) trên diễn đàn có cách nào dùng Vba để giải nén hết các Folder này bằng VBA hoặc 1 phần mềm đó mà vẫn thỏa mã các điều kiện
+ Giữ nguyên tên Folder
+ Các File nén trong Folder sau khi giải nén sẽ được xóa các File nén
Em Vân cảm ơn anh ( chị ) diễn đàn ạ j
Bạn tải ứng dụng Win 7z ( bất kì file nào giải nén được ) về, sửa đường dẫn trong VBA tương ứng với đường dẫn ứng dụng
Public Const PathZipProgram = "D:\Program Files\7-Zip\"
Sửa đường dẫn thư mục cần giải nén:
Const fPathFile = "D:\Folder\"
*Copy thêm một Folder khác để tránh trường hợp mất File.
Code VBA:
PHP:
'Tools -> References -> chọn Microsoft Scrtipting Runtime
Public FSO As Scripting.FileSystemObject
Public SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Public FileItem As Scripting.File
Public IsFileTypeExists As Boolean
Public oApp
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessID As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#Else
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#End If
'--------------------------------------------------------------------------------------
Public Const PathZipProgram = "D:\Program Files\7-Zip\"
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103
Public Sub RunUnZip()
Const fPathFile = "D:\Folder\"
Set FSO = New Scripting.FileSystemObject
If FSO.FolderExists(fPathFile) = False Then Exit Sub
ListFilesInFolder FSO.GetFolder(fPathFile), True, True
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Public Sub ListFilesInFolder( _
SourceFolder As Scripting.Folder, _
IncludeSubfolders As Boolean, _
Optional ByVal HasDel As Boolean)
On Error Resume Next
Dim FileFolder$, fileNameInZip
For Each FileItem In SourceFolder.Files
If LCase$(FileItem.Type) Like "*zip*" Then
FileFolder = Replace$(FileItem.Path, FileItem.Name, "")
ShellAndWait PathZipProgram & "7z.exe x -aoa" _
& " " & Chr(34) & FileItem.Path & Chr(34) _
& " -o" & Chr(34) & FileFolder & Chr(34) & " " & "*.*", vbHide
If HasDel Then FSO.DeleteFile FileItem.Path
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder, True, HasDel
Next SubFolder
End If
End Sub
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
Dim hProg As Long
Dim hProcess As Long, ExitCode As Long
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do
GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub
Bạn tải ứng dụng Win 7z ( bất kì file nào giải nén được ) về, sửa đường dẫn trong VBA tương ứng với đường dẫn ứng dụng
Public Const PathZipProgram = "D:\Program Files\7-Zip\"
Sửa đường dẫn thư mục cần giải nén:
Const fPathFile = "D:\Folder\"
*Copy thêm một Folder khác để tránh trường hợp mất File.
Code VBA:
PHP:
'Tools -> References -> chọn Microsoft Scrtipting Runtime
Public FSO As Scripting.FileSystemObject
Public SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Public FileItem As Scripting.File
Public IsFileTypeExists As Boolean
Public oApp
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessID As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#Else
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#End If
'--------------------------------------------------------------------------------------
Public Const PathZipProgram = "D:\Program Files\7-Zip\"
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103
Public Sub RunUnZip()
Const fPathFile = "D:\Folder\"
Set FSO = New Scripting.FileSystemObject
If FSO.FolderExists(fPathFile) = False Then Exit Sub
Set SourceFolder = FSO.GetFolder(fPathFile)
ListFilesInFolder SourceFolder, True, True
End Sub
Public Sub ListFilesInFolder( _
SourceFolder As Scripting.Folder, _
IncludeSubfolders As Boolean, _
Optional ByVal HasDel As Boolean)
On Error Resume Next
Dim FileFolder$, fileNameInZip
For Each FileItem In SourceFolder.Files
If LCase$(FileItem.Type) Like "*zip*" Then
FileFolder = Replace$(FileItem.Path, FileItem.Name, "")
ShellAndWait PathZipProgram & "7z.exe x -aoa" _
& " " & Chr(34) & FileItem.Path & Chr(34) _
& " -o" & Chr(34) & FileFolder & Chr(34) & " " & "*.*", vbHide
If HasDel Then FSO.DeleteFile FileItem.Path
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
Dim hProg As Long
Dim hProcess As Long, ExitCode As Long
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do
GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub
Em Vân thử chạy thì đối với các Folder con trong Folder với kết quả chuyển thành hết 1 Folder chung của các File mà không phải là mỗi Folder con có file nén được giải nén anh ạ !
Em Vân có Nhiều Folder, Trong mỗi Folder lại có rất nhiều các File đang được nén vào đuôi Zip. Em Vân Muốn hỏi Anh (Chị ) trên diễn đàn có cách nào dùng Vba để giải nén hết các Folder này bằng VBA hoặc 1 phần mềm đó mà vẫn thỏa mã các điều kiện
+ Giữ nguyên tên Folder
+ Các File nén trong Folder sau khi giải nén sẽ được xóa các File nén
Em Vân cảm ơn anh ( chị ) diễn đàn ạ j
Sub UnzipFiles()
Dim myfolder
Dim destfolder
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
MsgBox "vanaccex can chon Folder chua cac file ZIP muon giai nen"
.Show
myfolder = .SelectedItems(1) & "\"
End With
With Application.FileDialog(msoFileDialogFolderPicker)
MsgBox "vanaccex chon Folder muon luu file giai nen "
.Show
destfolder = .SelectedItems(1) & "\"
End With
Call Recursive(myfolder, destfolder)
MsgBox "Da giai nen xong!"
End Sub
Sub Recursive(FolderPath As Variant, destfolder As Variant)
Dim Value As String, Folders() As String
Dim Folder As Variant, a As Long
Dim SApp As Object
ReDim Folders(0)
If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
Folders(UBound(Folders)) = Value
ReDim Preserve Folders(UBound(Folders) + 1)
Else
If Right(Value, 4) = ".zip" Then
Set SApp = CreateObject("Shell.Application")
SApp.Namespace(destfolder).CopyHere _
SApp.Namespace(FolderPath & Value).items
End If
End If
End If
Value = Dir
Loop
For Each Folder In Folders
Call Recursive(FolderPath & Folder & "\", destfolder)
Next Folder
End Sub
Em Vân thử chạy thì đối với các Folder con trong Folder với kết quả chuyển thành hết 1 Folder chung của các File mà không phải là mỗi Folder con có file nén được giải nén anh ạ !
Dạ em Vân thử với ! Folder cho 5 Folder con ( có khoảng 6 file né ở trong) + 10 File nén ở ngoài . Chạy lại Đoạn code đó mà nó gộp thành 40 File ra ngoài hết anh ạ !
Sub UnzipFiles()
Dim myfolder
Dim destfolder
On Error Resume Next
With Application.FileDialog(msoFileDialogFolderPicker)
MsgBox "vanaccex can chon Folder chua cac file ZIP muon giai nen"
.Show
myfolder = .SelectedItems(1) & "\"
End With
With Application.FileDialog(msoFileDialogFolderPicker)
MsgBox "vanaccex chon Folder muon luu file giai nen "
.Show
destfolder = .SelectedItems(1) & "\"
End With
Call Recursive(myfolder, destfolder)
MsgBox "Da giai nen xong!"
End Sub
Sub Recursive(FolderPath As Variant, destfolder As Variant)
Dim Value As String, Folders() As String
Dim Folder As Variant, a As Long
Dim SApp As Object
ReDim Folders(0)
If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
Folders(UBound(Folders)) = Value
ReDim Preserve Folders(UBound(Folders) + 1)
Else
If Right(Value, 4) = ".zip" Then
Set SApp = CreateObject("Shell.Application")
SApp.Namespace(destfolder).CopyHere _
SApp.Namespace(FolderPath & Value).items
End If
End If
End If
Value = Dir
Loop
For Each Folder In Folders
Call Recursive(FolderPath & Folder & "\", destfolder)
Next Folder
End Sub
Em Vân thử mà vẫn chưa được như ý muốn là Giải nén được cả các File trong các Folder con anh ạ
Em Vân có Nhiều Folder, Trong mỗi Folder lại có rất nhiều các File đang được nén vào đuôi Zip. Em Vân Muốn hỏi Anh (Chị ) trên diễn đàn có cách nào dùng Vba để giải nén hết các Folder này bằng VBA hoặc 1 phần mềm đó mà vẫn thỏa mã các điều kiện
+ Giữ nguyên tên Folder
+ Các File nén trong Folder sau khi giải nén sẽ được xóa các File nén
Em Vân cảm ơn anh ( chị ) diễn đàn ạ j
Nhiều người hay dùng từ đuôi để ám chỉ định dạng: xlsx, xls, xlsm, doc, docx, jpg, gif, avi, mp3, exe, dll, bat ... Bạn cũng dùng từ đuôi nhưng có lẽ không ám chỉ định dạng. Lần sau nên nói rõ.
Nếu bạn muốn bung các tập tin có tên là "...ZIP" nhưng không phải là "...KRAB.ZIP"? Nếu thế thì đọc tiếp.
- code dưới không tạo thêm các thư mục con. Code của huuthang_bd tạo thêm thư mục con. vd. trong thư mục có anh.zip là tập tin nén của anh.jpg thì sau khi chạy code trong thư mục có thư mục con anh, và trong thư mục con anh mới có anh.jpg.
- code sẽ lưu thư mục cũ với tên <tên cũ>_<ngay, tháng, năm, gio, phút, giây>. Tức khi cần thì luôn có bản lưu.
- với các code của huuthang_bd, LamNA và của tôi thì mọi tập tin ZIP mà trong đường dẫn có ký tự unicode sẽ không được bung.
- macro để gán cho nút là DoExtractZip
Mã:
Sub DoExtractZip()
' Cac tap tin ZIP co duong dan unicode se khong duoc bung ra
Dim FolderStart As String, fso As Object, shellObj As Object
MsgBox "Hay chon thu muc bat dau"
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
FolderStart = .SelectedItems(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set shellObj = CreateObject("Shell.Application")
fso.CopyFolder FolderStart, FolderStart & Format(Now, "_ddmmyyyyhhmmss")
ExtractZip FolderStart, fso, shellObj
Set fso = Nothing
Set shellObj = Nothing
MsgBox "Done"
End If
End With
End Sub
Public Sub ExtractZip(ByVal FolderStart As String, fso As Object, shellObj)
Dim f As Object, SubF As Object
Set f = fso.GetFolder(FolderStart)
For Each SubF In f.files
If LCase(SubF.Name) Like "*.zip" And Not LCase(SubF.Name) Like "*krab.zip" Then
shellObj.Namespace(f & "\").CopyHere shellObj.Namespace(FolderStart & "\" & SubF.Name).items
fso.DeleteFile FolderStart & "\" & SubF.Name
End If
Next SubF
For Each SubF In f.SubFolders
ExtractZip SubF.Path, fso, shellObj
Next
Set f = Nothing
End Sub
Nhiều người hay dùng từ đuôi để ám chỉ định dạng: xlsx, xls, xlsm, doc, docx, jpg, gif, avi, mp3, exe, dll, bat ... Bạn cũng dùng từ đuôi nhưng có lẽ không ám chỉ định dạng. Lần sau nên nói rõ.
Nếu bạn muốn bung các tập tin có tên là "...ZIP" nhưng không phải là "...KRAB.ZIP"? Nếu thế thì đọc tiếp.
- code dưới không tạo thêm các thư mục con. Code của huuthang_bd tạo thêm thư mục con. vd. trong thư mục có anh.zip là tập tin nén của anh.jpg thì sau khi chạy code trong thư mục có thư mục con anh, và trong thư mục con anh mới có anh.jpg.
- code sẽ lưu thư mục cũ với tên <tên cũ>_<ngay, tháng, năm, gio, phút, giây>. Tức khi cần thì luôn có bản lưu.
- với các code của huuthang_bd, LamNA và của tôi thì mọi tập tin ZIP mà trong đường dẫn có ký tự unicode sẽ không được bung.
- macro để gán cho nút là DoExtractZip
Mã:
Sub DoExtractZip()
' Cac tap tin ZIP co duong dan unicode se khong duoc bung ra
Dim FolderStart As String, fso As Object, shellObj As Object
MsgBox "Hay chon thu muc bat dau"
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
FolderStart = .SelectedItems(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set shellObj = CreateObject("Shell.Application")
fso.CopyFolder FolderStart, FolderStart & Format(Now, "_ddmmyyyyhhmmss")
ExtractZip FolderStart, fso, shellObj
Set fso = Nothing
Set shellObj = Nothing
MsgBox "Done"
End If
End With
End Sub
Public Sub ExtractZip(ByVal FolderStart As String, fso As Object, shellObj)
Dim f As Object, SubF As Object
Set f = fso.GetFolder(FolderStart)
For Each SubF In f.files
If LCase(SubF.Name) Like "*.zip" And Not LCase(SubF.Name) Like "*krab.zip" Then
shellObj.Namespace(f & "\").CopyHere shellObj.Namespace(FolderStart & "\" & SubF.Name).items
fso.DeleteFile FolderStart & "\" & SubF.Name
End If
Next SubF
For Each SubF In f.SubFolders
ExtractZip SubF.Path, fso, shellObj
Next
Set f = Nothing
End Sub
Dạ vâng em Vân cảm ơn anh @batman1 nhiều ạ. Em Vân thành thật xin lỗi, Em Vân sẽ rút kinh nghiệm ạ.
Em Vân là muốn giải nén tất cả các File có đuôi là .zip kể cả File có đuôi KRAB.zip. Với File có đuôi KRAB.zip thì sau khi giải nén xong sẽ tiếp tục giải nén File có đuôi KRAB anh ạ
Với Đoạn code của Anh Thắng là do Em Vân bị lỗi đường dẫn quá dài nên nó báo vậy anh ạ
Em Vân cảm ơn các anh đã giúp đỡ em Vân rất nhiều ạ !