Modify Before Send

[andiam24]

Hello,

For the following code Destwb is a new workbook created and sent to an
end-user. I am attempting to delete all buttons and a few rows from this new
workbook prior to sending but the code is not working. Any suggestions? (This
is only a portion of the code)

With Destwb
.SaveAs FName
Dim shp As Shape
Dim cell As Range

For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp

For Each cell In ActiveSheet.Range("a86:a120")
If cell.Value = False Then
cell.EntireRow.Delete
End If
Next

Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Set VBProj = Destwb.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
ActiveSheet.Protect ("qconly")

On Error Resume Next


With OutMail

For Each cell In ThisWorkbook.Sheets("Summary").Range("ae91:ae117")
If cell.Value Like "*@*.*" And cell.Offset(0, 1).Value = True Then
strto = strto & cell.Value & ";"
End If
Next cell
For Each cell In ThisWorkbook.Sheets("Summary").Range("ae91:ae117")
If cell.Value Like "*@*.*" And 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("b100").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 sent
Kill FName

Set OutMail = Nothing
Set OutApp = Nothing

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

 

[Ron de Bruin]

Hi andiam24

Are you the only user that use this code ?
Let me know and I create a bsic example for you

 

[Sheeloo]

Are you sure that the activsheet IS the new sheet?
Test by
Debug.print activesheet.name

You need to activate the new sheet...

 

[andiam24]

Two other people will use the code on their PC. Thanks, Ron!

 

[andiam24]

Hello Sheeloo,

Thanks for the reply; I tried activating the worksheet- probably
incorrectly, and that seemed to make matters worse.

 

[Ron de Bruin]

You can use this maybe ?

It create a workbook with one sheet and copy the usedrange in it
This way you not copy the code and because you use PasteSpecial also not the buttons

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
Dim rng As Range

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

Set Sourcewb = ActiveWorkbook

'Copy the sheetinfo to a new workbook
Set rng = ActiveSheet.UsedRange
Set Destwb = Workbooks.Add(1)

rng.Copy
With Destwb.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False

On Error Resume Next
.Name = rng.Parent.Name
On Error GoTo 0
End With

If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " _
& Format(Now, "dd-mmm-yy h-mm-ss")

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

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
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



--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[andiam24]

Hello Ron,

After a little tweaking it worked perfectly! Thanks!

 

[andiam24]

Hi Again

I completely forgot that pictures may be sent! How can the code be modified
to include the pictures and also paste just the values? Thanks!

 

[andiam24]

I completely forgot that pictures may be sent! How can the code be modified
to include the pics but delete the buttons? Thanks!

 

[Ron de Bruin]

Test this one then (you can add code to delete the button if you want)

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
Dim rng As Range

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

Set Sourcewb = ActiveWorkbook

'Copy the sheetinfo to a new workbook
Set rng = ActiveSheet.Cells
Set Destwb = Workbooks.Add(1)

rng.Copy Destwb.Sheets(1).Range("A1")
With Destwb.Sheets(1)
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False

On Error Resume Next
Destwb.Sheets(1).Name = rng.Parent.Name
On Error GoTo 0

If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " _
& Format(Now, "dd-mmm-yy h-mm-ss")

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

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
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

 

[andiam24]

Ron you are AWESOME!

Test this one then (you can add code to delete the button if you want)

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
Dim rng As Range

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

Set Sourcewb = ActiveWorkbook

'Copy the sheetinfo to a new workbook
Set rng = ActiveSheet.Cells
Set Destwb = Workbooks.Add(1)

rng.Copy Destwb.Sheets(1).Range("A1")
With Destwb.Sheets(1)
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False

On Error Resume Next
Destwb.Sheets(1).Name = rng.Parent.Name
On Error GoTo 0

If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " _
& Format(Now, "dd-mmm-yy h-mm-ss")

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

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
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