請問vba使用系統內建來解壓縮zip??

lshsien

您好!
請教各位前輩
目前小弟想使用以下來解壓縮
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=False)
FileNameFolder = ThisWorkbook.Path & "\" & folder_name & "\"
Worksheets("工作表1").Range("F2") = FileNameFolder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
目前測試成功，
但使用這方式，還需選擇所需要解縮的檔案，
請問是否可以不需選擇而自行解壓縮
ps.檔案名稱與資料夾名稱擷取自Worksheets("工作表1").Range("F2")

載煩請各位前輩指導
謝謝

蝕光迴狼

回復 1# lshsien

試試看，是不是這樣?

1.     Sub 解壓縮文件()
   
2.         Dim Rarexe As String  'WINRAR執行文件的位置
   
3.         Dim FileString As String 'Shell指令中的字符串
   
4.         Dim Result As Long
   
5.         Rarexe = "C:\program files\winrar\winrar"  'WINRAR執行文件的位置
   
6.         '[B1]欄位 解壓縮前的原始文件
   
7.         '[B2]欄位 解壓縮後的目地文件
   
8.         FileString = Rarexe & " x " & "-Y " & [B1] & " " & [B2]  '指定-Y 開關，“是”為默認值，並自動回應全部的詢問。
   
9.         Result = Shell(FileString, vbHide)
   
10.     End Sub

複製代碼

還有另一個更便利的方法，但我功力不夠深厚，要請高手來幫忙了～
程式碼如下，需另外貼在上面程式的最上方
這方法是直接點欄位，就會自動帶出路徑

1. Option Explicit
   
2. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
3. 
   
4.     Dim gb As FileDialog    '宣告一個檔案對話框
   
5.     'Dim fd As FileDialog    '宣告一個檔案對話框
   
6. 
   
7.     Set gb = Excel.Application.FileDialog(msoFileDialogFilePicker)  '設定選取檔案功能
   
8.     'Set fd = Application.FileDialog(msoFileDialogFolderPicker)  '設定選取資料夾功能
   
9.    
   
10.     With Target(1)
    
11.         If .Address = "$B$1" Then If gb.Show Then .Cells = gb.SelectedItems(1) '點選哪個欄位儲存格,檔案路徑秀在那個欄位
    
12.         'If .Address = "$B$2" Then If fd.Show Then .Cells = fd.SelectedItems(1) '點選哪個欄位儲存格,檔案路徑秀在那個欄位
    
13.     End With
    
14. 
    
15. End Sub

複製代碼

stillfish00

回復 1# lshsien
你寫反了吧
Fname = Worksheets("工作表1").Range("F2").value          '從F2取得zip檔路徑
FileNameFolder = ThisWorkbook.Path & "\" & folder_name & "\"        '解壓縮位置
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items

lshsien

感謝蝕光迴狼大大
已經試驗成功了

感謝stillfish00更正

蝕光迴狼

回復 4# lshsien


你用試成功的方法是
　可否分享一下，互相學習

蝕光迴狼

回復 3# stillfish00


stillfish00 大大：

　請問以下程式要怎麼改，才能兩個條件都成立，並正常執行程式?

1. Option Explicit
   
2. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
3.     Dim gb As FileDialog    '宣告一個檔案對話框
   
4.     'Dim fd As FileDialog    '宣告一個檔案對話框
   
5.     Set gb = Excel.Application.FileDialog(msoFileDialogFilePicker)  '設定選取檔案功能
   
6.     'Set fd = Application.FileDialog(msoFileDialogFolderPicker)  '設定選取資料夾功能
   
7.     With Target(1)
   
8.         If .Address = "$B$1" Then If gb.Show Then .Cells = gb.SelectedItems(1) '點選哪個欄位儲存格,檔案路徑秀在那個欄位
   
9.         'If .Address = "$B$2" Then If fd.Show Then .Cells = fd.SelectedItems(1) '點選哪個欄位儲存格,檔案路徑秀在那個欄位
   
10.     End With
    
11. End Sub

複製代碼

stillfish00

回復 6# 蝕光迴狼
若是一個檔案一個資料夾:

1. Option Explicit
   
2. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
3.     Dim gb As FileDialog    '宣告一個檔案對話框
   
4.     Dim fd As FileDialog    '宣告一個檔案對話框
   
5.     With Target(1)
   
6.         If .Address = "$B$1" Then
   
7.             Set gb = Excel.Application.FileDialog(msoFileDialogFilePicker)  '設定選取檔案功能
   
8.             If gb.Show Then .Cells = gb.SelectedItems(1) '點選哪個欄位儲存格,檔案路徑秀在那個欄位
   
9.         ElseIf .Address = "$B$2" Then
   
10.             Set fd = Application.FileDialog(msoFileDialogFolderPicker)  '設定選取資料夾功能
    
11.             If fd.Show Then .Cells = fd.SelectedItems(1) '點選哪個欄位儲存格,檔案路徑秀在那個欄位
    
12.         End If
    
13.     End With
    
14. End Sub

複製代碼

蝕光迴狼

回復 7# stillfish00


    謝謝 stillfish00 大大的回答，可以正常執行了，萬分感謝～

joey0415

單一檔案單一路徑解壓成功，留下紀錄參考參考！

1. Sub vba_unzip()
   
2.     Dim oApplicationlication As Object
   
3.     Dim fileName As Variant
   
4.     Dim folderFileName As Variant
   
5.     'fileName = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=False)
   
6.     fileName = "E:\期交所\opdata\OptionsDaily_2018_02_21.zip"
   
7.     folderFileName = "e:\test\"
   
8.     'MkDir folderFileName
   
9.     Set oApplication = CreateObject("Shell.Application")
   
10.     oApplication.Namespace(folderFileName).CopyHere oApplication.Namespace(fileName).items
    
11.     DoEvents
    
12. 
    
13. End Sub

複製代碼