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
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作者: PD961A 時間: 2010-5-10 07:44
