指定文件夹修改另存模块修改

icenotcool

各位老师好：我想把下面这个模块修改一下，要求：求另存整个工作簿（去掉宏，去掉链接，去掉所有按钮，去掉函数公式，保留报表格式，去掉工作簿vba工程密码）。
下面这个是我根据另外一个模块改得：可是运行出错：想麻烦老师帮我看看，先谢谢各位老师了，
ub 另存() '引用 Microsoft Visual Basic For Application Extensibility 5.3
    Dim vbc As Object, shp As Shape, s$, sh As Worksheet
   ' s = ThisWorkbook.Path & "\备份" & ThisWorkbook.Name
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
     ActiveWorkbook.SaveAs Filename:="D:\备份\业务收入" & Format(Now, "YYYY-MM-DD-HHmmSS") & ".xls", _
             FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False '删除函数公式
    ThisWorkbook.SaveCopyAs s
    With Workbooks.Open(s)
        For Each sh In .Sheets
            For Each shp In sh.Shapes
                shp.Delete
            Next
        Next
        For Each vbc In .VBProject.VBComponents
            Select Case vbc.Type
            Case 1, 2, 3
                With Application.VBE.ActiveVBProject.VBComponents
                    .Remove .Item(vbc.Name) '删除模块、类模块、窗体
               ActiveSheet.Hyperlinks.Delete '删除链接
            REMOVE '删除VBA工程密码，已知密码为“111”
                End With
            Case Else
                vbc.CodeModule.DeleteLines 1, vbc.CodeModule.CountOfLines '删除工作表或Thisworkbook代码区代码
            End Select
        Next
        .Close True
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "备份完毕"
End Sub