12
返回列表 上一主題 發帖

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

OFFICE專家

帖子
24 
主題
3 
精華
0 
積分
52 
點名
0  
作業系統
windows vista 
軟體版本
office95 
閱讀權限
20 
性別
男 
註冊時間
2011-1-7 
最後登錄
2012-6-9 
4# 跳轉到 »
發表於 2012-6-9 17:00 | 只看該作者
看到這問題想起多年前ZZ版兄在OFFICE精英
也問過同樣問題.那時後StartUp剛出現沒多久

不過剛要進OFFICE精英...仍進不去...OFFICE精英有好幾天進不去了
上次OFFICE精英進不去是2004年的時候了.結果是主機壞掉.所有文章退回1個月前
不恥下問,不斷學習,才會進步

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 2012-6-9 12:08 | 只看該作者
本帖最後由 GBKEE 於 2012-6-9 12:11 編輯

回復 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
複製代碼

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
109  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-5-11 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2012-6-8 23:14 | 只看該作者
回復 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)

  11.   Case Else
  12.     .VBProject.VBComponents(vbc.Name).CodeModule.DeleteLines 1, _
  13.     .VBProject.VBComponents(vbc.Name).CodeModule.CountOfLines

  15.   End Select
  16. Next
  17. .Close 1
  18. End With
  19. fs = Dir
  20. Loop
  21. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 知識要用心體會，才能變成自己的智慧。
12
返回列表 上一主題