Hello,

I'm still a newbie to VBA and have generated the following code that is not
working to delete macros from the new workbook!:
Sub Mail_ActiveSheet()
'Working in 2000-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook

'Change all cells in the worksheet to values if you want
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
.Range("a88:ag118").Font.ColorIndex = 2
End With
Application.CutCopyMode = False

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = Sourcewb.Name

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
Dim shp As Shape
Dim testStr As String
Dim cell As Range
Dim strto As String
Dim ccto As String
'Delete control buttons
For Each shp In ActiveSheet.Shapes

If shp.Type = 8 Then
If shp.FormControlType = 2 Then
testStr = ""
On Error Resume Next
testStr = shp.TopLeftCell.Address
On Error GoTo 0
If testStr < "" Then shp.Delete
Else
shp.Delete
End If
End If
Next shp
'Delete code from new workbook
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule

Set VBProj = ActiveWorkbook.VBProject

For Each VBComp In VBProj.VBComponents
If VBComp.Type = vbext_ct_Document Then
Set CodeMod = VBComp.CodeModule
With CodeMod
.DeleteLines 1, .CountOfLines
End With
Else
VBProj.VBComponents.Remove VBComp
End If
Next VBComp

On Error Resume Next
With OutMail
For Each cell In ThisWorkbook.Sheets("Summary").Range("ae91:ae118")
If cell.Value Like "*@*.*" And LCase(cell.Offset(0, 1).Value)
= True Then
strto = strto & cell.Value & ";"
End If
Next cell
For Each cell In ThisWorkbook.Sheets("Summary").Range("ae91:ae118")
If cell.Value Like "*@*.*" And LCase(cell.Offset(0, 2).Value)
= True Then
ccto = ccto & cell.Value & ";"
End If
Next cell
.To = strto
.CC = ccto
.BCC = ""
.Subject = ThisWorkbook.Sheets("Summary").Range("B1").Value &
"Summary Report"
.Body = ThisWorkbook.Sheets("Summary").Range("a100").Value
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub


PLEASE HELP!!