Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Help with Delete Macro
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!! |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Help with Delete Macro
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. "andiam24" wrote: 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!! |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Help with Delete Macro
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. |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Help with Delete Macro
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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Help with Delete Macro
Joel, you're fast! Copied and pasted the code but still getting code in my
sent attachment. Very frustrating :( |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Help with Delete Macro
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. "andiam24" wrote: Joel, you're fast! Copied and pasted the code but still getting code in my sent attachment. Very frustrating :( |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Help with Delete Macro
Thanks Joel!!
"joel" wrote: 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. "andiam24" wrote: Joel, you're fast! Copied and pasted the code but still getting code in my sent attachment. Very frustrating :( |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Macro to delete sheets and saves remaining file does not properly delete module | Excel Programming | |||
Macro to delete sheets and saves remaining file does not properly delete module | Excel Programming | |||
Macro to delete sheets and saves remaining file does not properly delete module | Excel Programming | |||
Macro to delete sheets and saves remaining file does not properly delete module | Excel Programming | |||
Macro to delete sheets and saves remaining file does not properly delete module | Excel Programming |