Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Discussion (Misc queries) > Modify Before Send
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 29
Default Modify Before Send
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

Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 11,123
Default Modify Before Send
Hi andiam24

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



--

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




"andiam24" wrote in message ...
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

Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 793
Default Modify Before Send
Are you sure that the activsheet IS the new sheet?
Test by
Debug.print activesheet.name

You need to activate the new sheet...

"andiam24" wrote:

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

Reply With QuoteReply With Quote
  #4   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 29
Default Modify Before Send
Two other people will use the code on their PC. Thanks, Ron!

"Ron de Bruin" wrote:

Hi andiam24

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



--

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




"andiam24" wrote in message ...
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


Reply With QuoteReply With Quote
  #5   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 29
Default Modify Before Send
Hello Sheeloo,

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

"Sheeloo" wrote:

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

You need to activate the new sheet...

"andiam24" wrote:

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

Reply With QuoteReply With Quote
  #6   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 11,123
Default Modify Before Send
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 = "
.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" wrote in message ...
Two other people will use the code on their PC. Thanks, Ron!

"Ron de Bruin" wrote:

Hi andiam24

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



--

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




"andiam24" wrote in message ...
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


Reply With QuoteReply With Quote
  #7   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 29
Default Modify Before Send
Hello Ron,

After a little tweaking it worked perfectly! Thanks!

"Ron de Bruin" wrote:

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 = "
.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" wrote in message ...
Two other people will use the code on their PC. Thanks, Ron!

"Ron de Bruin" wrote:

Hi andiam24

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



--

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




"andiam24" wrote in message ...
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



Reply With QuoteReply With Quote
  #8   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 29
Default Modify Before Send

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!
Reply With QuoteReply With Quote
  #9   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 29
Default Modify Before Send

I completely forgot that pictures may be sent! How can the code be modified
to include the pics but delete the buttons? Thanks!
Reply With QuoteReply With Quote
  #10   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 11,123
Default Modify Before Send
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 = "
.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" wrote in message ...

I completely forgot that pictures may be sent! How can the code be modified
to include the pics but delete the buttons? Thanks!
Reply With QuoteReply With Quote
  #11   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 29
Default Modify Before Send
Ron you are AWESOME!

"Ron de Bruin" wrote:

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 = "
.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" wrote in message ...

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

Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
Help to modify the query? Eric Excel Worksheet Functions 0 March 11th 08 05:54 AM
Modify a UDF please? Excel Helps Excel Worksheet Functions 2 January 23rd 08 09:40 AM
Modify a UDF please? Excel Helps Excel Worksheet Functions 0 January 23rd 08 12:10 AM
My send to in excel/word does not offer send as attachment Mstink Excel Discussion (Misc queries) 11 March 16th 06 02:49 PM
Modify width Peter Kwong Setting up and Configuration of Excel 4 February 10th 06 03:37 PM


All times are GMT +1. The time now is 09:44 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
Copyright ©2004-2025 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement