返回列表下一主題上一主題發帖

[分享] 另存新檔時去除檔案中所有程式碼

Min

　暱稱: 閔

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 172
主題: 39
精華: 20
積分: 177
點名: 0
作業系統: Microsoft Windows XP
軟體版本: Microsoft Office 2003
閱讀權限: 100
性別: 男
來自: 高雄
註冊時間: 2010-5-1
最後登錄: 2023-3-19

論壇貢獻勳章帥哥勳章

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2010-5-9 21:05 | 顯示全部帖子

[分享] 另存新檔時去除檔案中所有程式碼

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