Help with Delete Macro

A

andiam24

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!!
 
J

joel

I don't think the new workbooks have any macro in them? the Copy without the
BEFORE or AFTER doesn't copy the macros. I said this before. Why do you
keep on adding unnecesary code to delete macros that don't exist?

TRY mailing the file to your own email address and you will see there is no
macros in the file you will receive.
 
A

andiam24

Every attachment received contains the macro. I ran a macro that worked but
that was before I changed from SendMail to Outlook object. I'm thinking the
Outlook conversion has something to do with the retained code. Thanks for the
quick response though.
 
J

joel

You were attaching the wrong file. You had two workbooks one with XLS and
the other without XLS. You saved the the one with the xls (no macros) and
then attached the one with the macros.

When you did the SAVEAS you had a nunberformat. Not sure what this was so I
removed it because it was giving me an error. Try this new code.

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
FName = TempFilePath & TempFileName & ".xls"

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

With Destwb
.SaveAs FName
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

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 FName
'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 FName

Set OutMail = Nothing
Set OutApp = Nothing

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

andiam24

Joel, you're fast! Copied and pasted the code but still getting code in my
sent attachment. Very frustrating :(
 
J

joel

I should of tested the change better. Still ended up with two XLS at the end
of the file. One problem is using the TMP directory your original workbook
is opened and puts the open file into the Tmp directory. I put a Z infront
of the temporay filename because I got an error that I was saving a file to a
filename that already existed (the open file).

Make this change to my last posting and it will work. guarenteeed.

from
FName = TempFilePath & TempFileName & ".xls"
to
FName = TempFilePath & "z" & TempFileName


Note: TempFilename has the XLS on the end already.
 
A

andiam24

Thanks Joel!!

joel said:
I should of tested the change better. Still ended up with two XLS at the end
of the file. One problem is using the TMP directory your original workbook
is opened and puts the open file into the Tmp directory. I put a Z infront
of the temporay filename because I got an error that I was saving a file to a
filename that already existed (the open file).

Make this change to my last posting and it will work. guarenteeed.

from
FName = TempFilePath & TempFileName & ".xls"
to
FName = TempFilePath & "z" & TempFileName


Note: TempFilename has the XLS on the end already.
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Macro Running very slow 5
Mail Multiple Sheets via PDF Q 5
file extension shows up twice on attachment 2
Converting an Excel file to PDF Q 1
Address Range in Email Script 4
Change Range in macro 2
Run-time error '1004'??? 7
Change PDF properties 2

Top