[發問] 刪除指定資料夾中所有巨集

PJChen

請教高手:
VBA TEST 6_刪除所有巨集.zip (281.2 KB)

下載次數: 14

2012-6-8 16:37

我要在Cancel VBA.xlsm的E6儲存格中指定一個資料夾名稱為"刪除所有巨集",
1) 只要是放在這個資料夾中的所有檔案,一律刪除所有巨集(不論EXCEL檔案中有多少巨集)
2) 資料夾中的EXCEL檔案類型有.xls/.xlsm

這樣的要求是否可寫成一個巨集?

Hsieh

回復 1# PJChen
參考用程式寫程式 (VBProject / VBComponents)

1. Sub Try()
   
2. fd = ThisWorkbook.Path & "\" & Sheets(1).[E6] & "\"
   
3. fs = Dir(fd & "*.xlsm")
   
4. Do Until fs = ""
   
5. With Workbooks.Open(fd & fs)
   
6. For Each vbc In .VBProject.VBComponents
   
7.   Select Case vbc.Type
   
8.   Case vbext_rk_Project, vbext_wt_Browser, vbext_ct_MSForm '註
   
9.     .VBProject.VBComponents.Remove .Item(vbc.Name)
   
10. 
    
11.   Case Else
    
12.     .VBProject.VBComponents(vbc.Name).CodeModule.DeleteLines 1, _
    
13.     .VBProject.VBComponents(vbc.Name).CodeModule.CountOfLines
    
14. 
    
15.   End Select
    
16. Next
    
17. .Close 1
    
18. End With
    
19. fs = Dir
    
20. Loop
    
21. End Sub

複製代碼

GBKEE

回復 1# PJChen
另存為 2007無巨集格式的活頁簿 "xlsx"

1. Sub Ex()
   
2.     Dim xlPath As String, xlFile As String      'String: 資料型態
   
3.     Application.DisplayAlerts = False           '停止系統的提示
   
4.     xlPath = ThisWorkbook.Path & "\"            'ThisWorkbook.Path: 程式碼活頁簿所存檔的路徑;  你可修改為指定的路徑
   
5.     xlFile = Dir(xlPath & "*.xlsm")             '指定的路徑中 尋找副檔名"xlsm"的檔案
   
6.     Do While xlFile <> ""                        '處裡 找到"xlsm"的檔案
   
7.         With Workbooks.Open(xlPath & xlFile)    '開啟這檔案
   
8.             .SaveAs Filename:=Mid(xlPath & xlFile, 1, Len(xlPath & xlFile) - 1) & "x", FileFormat:=51
   
9.                                                 '這檔案另存為 2007無巨集格式的活頁簿 "xlsx"
   
10.             .Close                              '關閉檔案
    
11.         End With
    
12.         xlFile = Dir                            '指定的路徑中繼續尋找副檔名"xlsm"的檔案
    
13.     Loop
    
14.     If Dir(xlPath & "*.xlsm") <> "" Then Kill xlPath & "*.xlsm"
    
15.                                                 '刪除指定的路徑中所有副檔名"xlsm"的檔案
    
16.     Application.DisplayAlerts = True            '恢復系統的提示
    
17. End Sub

複製代碼

OFFICE專家

看到這問題想起多年前ZZ版兄在OFFICE精英
也問過同樣問題.那時後StartUp剛出現沒多久

不過剛要進OFFICE精英...仍進不去...OFFICE精英有好幾天進不去了
上次OFFICE精英進不去是2004年的時候了.結果是主機壞掉.所有文章退回1個月前

PJChen

回復 2# Hsieh
版大,
在程式執行過程中,它會一直出現對話框問是否更新連結?我想到之前大大給的二句話(藍色字),就將它加在這個程式中,但執行時停在With Workbooks.Open(fd & fs),是否前述二句話放錯位置了?
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

1. Sub Try()
   
2. fd = ThisWorkbook.Path & "\" & Sheets(1).[E6] & "\"
   
3. fs = Dir(fd & "*.xlsm")
   
4. fs = Dir(fd & "*.xls")
   
5. Do Until fs = ""
   
6. Application.DisplayAlerts = False
   
7. Application.AskToUpdateLinks = False
   
8. With Workbooks.Open(fd & fs)
   
9. For Each vbc In .VBProject.VBComponents
   
10.   Select Case vbc.Type
    
11.   Case vbext_rk_Project, vbext_wt_Browser, vbext_ct_MSForm '註
    
12.     .VBProject.VBComponents.Remove .Item(vbc.Name)
    
13. 
    
14.   Case Else
    
15.     .VBProject.VBComponents(vbc.Name).CodeModule.DeleteLines 1, _
    
16.     .VBProject.VBComponents(vbc.Name).CodeModule.CountOfLines
    
17. 
    
18.   End Select
    
19. Next
    
20. .Close 1
    
21. End With
    
22. fs = Dir
    
23. Loop
    
24. End Sub

複製代碼

Hsieh

回復 5# PJChen


    開啟檔案不更新連結

1. Sub Try()
   
2. fd = ThisWorkbook.Path & "\" & Sheets(1).[E6] & "\"
   
3. fs = Dir(fd & "*.xlsm")
   
4. fs = Dir(fd & "*.xls")
   
5. Do Until fs = ""
   
6. Application.DisplayAlerts = False
   
7. With Workbooks.Open(fd & fs, False)  ' 開啟檔案不更新連結
   
8. 'With Workbooks.Open(fd & fs, True)  ' 開啟檔案更新連結
   
9. 
   
10. For Each vbc In .VBProject.VBComponents
    
11.   Select Case vbc.Type
    
12.   Case vbext_rk_Project, vbext_wt_Browser, vbext_ct_MSForm '註
    
13.     .VBProject.VBComponents.Remove .Item(vbc.Name)
    
14. 
    
15.   Case Else
    
16.     .VBProject.VBComponents(vbc.Name).CodeModule.DeleteLines 1, _
    
17.     .VBProject.VBComponents(vbc.Name).CodeModule.CountOfLines
    
18. 
    
19.   End Select
    
20. Next
    
21. .Close 1
    
22. End With
    
23. fs = Dir
    
24. Loop
    
25. End Sub

複製代碼

PJChen

回復 6# Hsieh
請問大大,
若是待刪除巨集的檔案中有些是完全沒有巨集的(程式會停下來),我要讓"刪除巨集"的程式忽略它,繼續執行指令刪除其它有巨集的檔案,
我應該加入什麼語言(加在什麼地方)?才能達成我想要的?

PJChen

回復 6# Hsieh

再補充問題,程式執行時是否會因為簡體字而無法執行,像以下的檔名,它就出現了這樣的訊息:

下載 (34.74 KB)

2012-6-12 08:45

6月11日出车表.xls

Hsieh

回復 8# PJChen
1. 並無你所說當無程式碼檔案執行時會停止的現象
2. 要正確顯示檔名，只能借用儲存格顯示

1. Sub Try()
   
2. Dim fs
   
3. Application.DisplayAlerts = False
   
4. fd = ThisWorkbook.Path & "\" & Sheets(1).[E6] '檔案目錄
   
5. Set fos = CreateObject("Scripting.FileSystemObject")
   
6. Set fdn = fos.getfolder(fd)
   
7. Set fc = fdn.Files '檔案目錄中所有檔案
   
8. For Each fs In fc
   
9. [A1] = fs.Name '借用儲存格顯示正確檔名
   
10. With Workbooks.Open(fd & "\" & [A1].Text, 0) ' 開啟檔案不更新連結
    
11. For Each vbc In .VBProject.VBComponents
    
12.   Select Case vbc.Type
    
13.   Case 100
    
14.     .VBProject.VBComponents(vbc.Name).CodeModule.DeleteLines 1, _
    
15.     .VBProject.VBComponents(vbc.Name).CodeModule.CountOfLines '刪除所有程式碼
    
16.   Case Else
    
17.     .VBProject.VBComponents.Remove .VBProject.VBComponents.Item(vbc.Name) '移除模組、表單、類別模組
    
18.   End Select
    
19. Next
    
20. .Close 1
    
21. End With
    
22. Next
    
23. End Sub

複製代碼

PJChen

回復 9# Hsieh
也許我誤以為簡體字檔名為無巨集便會停下來,現在測試未發現有問題了,不過想請教,為何將檔名顯示在[A1]儲存格,為何它就可以接受簡體字了?