- 帖子
- 172
- 主題
- 39
- 精華
- 20
- 積分
- 177
- 點名
- 0
- 作業系統
- Microsoft Windows XP
- 軟體版本
- Microsoft Office 2003
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 高雄
- 註冊時間
- 2010-5-1
- 最後登錄
- 2023-3-19
 
|
Option Explicit
Sub CleanVBComponents()
Dim objVBC As Object
Dim objMdl As Object
Dim arr() As Variant
Dim intCounter As Integer
Dim txt As String
Dim fileSaveName As Variant
Dim Msg As String
Dim ctl As Shape
Msg = "另存檔案"
ChDir ThisWorkbook.Path
fileSaveName = Application.GetSaveAsFilename( _
FileFilter:="Excel Files (*.xls), *.xls", Title:=Msg)
If fileSaveName = False Then Exit Sub
Application.ScreenUpdating = False
For Each ctl In Sheet1.Shapes
ctl.Delete
Next ctl
ReDim arr(1 To 3, 1 To ActiveWorkbook.VBProject.VBComponents.Count)
intCounter = 0
Application.StatusBar = "刪除VBE程式碼..."
For Each objVBC In ActiveWorkbook.VBProject.VBComponents
Set objMdl = objVBC.CodeModule
intCounter = intCounter + 1
arr(1, intCounter) = objVBC.Type
arr(2, intCounter) = objVBC.Name
If objMdl.countoflines > 0 Then
txt = objVBC.CodeModule.Lines(1, objMdl.countoflines)
End If
arr(3, intCounter) = txt
Select Case arr(1, intCounter)
Case 1
ActiveWorkbook.VBProject.VBComponents.Remove objVBC
Case 2
ActiveWorkbook.VBProject.VBComponents.Remove objVBC
Case 100
objVBC.CodeModule.DeleteLines 1, objMdl.countoflines
Case 3
ActiveWorkbook.VBProject.VBComponents.Remove objVBC
DoEvents
End Select
Next objVBC
ThisWorkbook.SaveAs fileSaveName
Application.ScreenUpdating = True
Application.StatusBar = ""
End Sub |
|
發表於 2010-5-9 21:05
| 
發表於 2012-1-30 12:01
| 
