The macro below works great in excel 2003. however in excel 2007 I get
a mesage as follows:-

The following features cannot be saved in macro free workbook

VBProject

To save a file with these features click no, then choose a macro
enabled file type in the File Type list.

To continue saving as a macro free workbook chose yes.


The code below I put together several years ago with the help of a Ron
DeBriun posting.

The workbook itself is an excel 97-2003 format (in excel 2007 it comes
up as (combatability mode), I'm the only user currently using excel
2007, other users will remain on excel 2003 until this problem is
resolved. The problem occur when I save the file to email, I noted the
location below where the macro fails

..SaveAs " " & sh.Name & " " & custname & " " & strdate & ".xls" this
line fails.

Any help would be greatly appreciated

burl_rfc

Sub Rectangle15_Click()
'Mail_Every_Worksheet2()
Dim sh As Worksheet
Dim wb As Workbook
Dim strdate As String
Dim custname As String
Dim MyArrIndex As Long
Dim E_Mail_Count As Long
Dim cell As Range
Dim MyArr() As String
Application.ScreenUpdating = False
Worksheets("QuoteForm").Activate
Range("I10").Select
Selection.Copy
Range("L2").Select
custname = Range("b7")
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
For Each sh In ThisWorkbook.Worksheets
If sh.Range("L1").Value Like "?*@?*.?*" Then
strdate = Format(Now, "mm-dd-yy h-mm-ss")

E_Mail_Count = sh.Columns("L").Cells.SpecialCells
(xlCellTypeConstants).Count
ReDim MyArr(1 To E_Mail_Count)
MyArrIndex = 1
For Each cell In sh.Columns("L").Cells.SpecialCells
(xlCellTypeConstants)
If cell Like "*@*" Then
MyArr(MyArrIndex) = cell.Value
MyArrIndex = MyArrIndex + 1
End If
Next
ReDim Preserve MyArr(1 To MyArrIndex)

sh.Copy
Set wb = ActiveWorkbook
sh.Name = Range("b6")
With wb

problem ocurrs on the following line

.SaveAs " " & sh.Name & " " & custname & " " &
strdate & ".xls"

.SendMail MyArr, _
"New DT Flycut Quote (Customer: " & custname
& ") "
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With

End If

Next sh

Application.ScreenUpdating = True
ActiveSheet.Name = "QuoteForm"
Worksheets("Quote Data Entry").Activate

Call Rectangle16_Click

End Sub

See the updated code examples on my site
Working in 97-2007
http://www.rondebruin.nl/sendmail.htm


--

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


"burl_rfc" wrote in message ...
The macro below works great in excel 2003. however in excel 2007 I get
a mesage as follows:-

The following features cannot be saved in macro free workbook

VBProject

To save a file with these features click no, then choose a macro
enabled file type in the File Type list.

To continue saving as a macro free workbook chose yes.


The code below I put together several years ago with the help of a Ron
DeBriun posting.

The workbook itself is an excel 97-2003 format (in excel 2007 it comes
up as (combatability mode), I'm the only user currently using excel
2007, other users will remain on excel 2003 until this problem is
resolved. The problem occur when I save the file to email, I noted the
location below where the macro fails

.SaveAs " " & sh.Name & " " & custname & " " & strdate & ".xls" this
line fails.

Any help would be greatly appreciated

burl_rfc

Sub Rectangle15_Click()
'Mail_Every_Worksheet2()
Dim sh As Worksheet
Dim wb As Workbook
Dim strdate As String
Dim custname As String
Dim MyArrIndex As Long
Dim E_Mail_Count As Long
Dim cell As Range
Dim MyArr() As String
Application.ScreenUpdating = False
Worksheets("QuoteForm").Activate
Range("I10").Select
Selection.Copy
Range("L2").Select
custname = Range("b7")
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
For Each sh In ThisWorkbook.Worksheets
If sh.Range("L1").Value Like "?*@?*.?*" Then
strdate = Format(Now, "mm-dd-yy h-mm-ss")

E_Mail_Count = sh.Columns("L").Cells.SpecialCells
(xlCellTypeConstants).Count
ReDim MyArr(1 To E_Mail_Count)
MyArrIndex = 1
For Each cell In sh.Columns("L").Cells.SpecialCells
(xlCellTypeConstants)
If cell Like "*@*" Then
MyArr(MyArrIndex) = cell.Value
MyArrIndex = MyArrIndex + 1
End If
Next
ReDim Preserve MyArr(1 To MyArrIndex)

sh.Copy
Set wb = ActiveWorkbook
sh.Name = Range("b6")
With wb

problem ocurrs on the following line

.SaveAs " " & sh.Name & " " & custname & " " &
strdate & ".xls"

.SendMail MyArr, _
"New DT Flycut Quote (Customer: " & custname
& ") "
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With

End If

Next sh

Application.ScreenUpdating = True
ActiveSheet.Name = "QuoteForm"
Worksheets("Quote Data Entry").Activate

Call Rectangle16_Click

End Sub

Ron,

I added all that I thought I may need from your site, however it still
hangs up. This time it on the following line

For Each sh In ThisWorkbook.Worksheets
If sh.Range("L1").Value Like "?*@?*.?*" Then

It returns a null value, thus ending the for each statement. This is
where I verify that email address do exist in column L. If so
it'ssupposed to add the name to the array. This works without any
issue in excel 2003.

burl_rfc


Sub Rectangle20_Click()
'Mail_Every_Worksheet2()
Dim sh As Worksheet
Dim wb As Workbook
Dim strdate As String
Dim custname As String
Dim MyArrIndex As Long
Dim E_Mail_Count As Long
Dim cell As Range
Dim MyArr() As String

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String

Application.ScreenUpdating = False

Set Sourcewb = ActiveWorkbook

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

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.VERSION) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security
dialog that you only
'see when you copy a sheet from a xlsm file with macro's
disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

custname = Range("b7")
Range("I10").Select
Selection.Copy
Range("L2").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
For Each sh In ThisWorkbook.Worksheets
If sh.Range("L1").Value Like "?*@?*.?*" Then
strdate = Format(Now, "mm-dd-yy h-mm-ss")


E_Mail_Count = sh.Columns("L").Cells.SpecialCells
(xlCellTypeConstants).Count
ReDim MyArr(1 To E_Mail_Count)
MyArrIndex = 1
For Each cell In sh.Columns("L").Cells.SpecialCells
(xlCellTypeConstants)
If cell Like "*@*" Then
MyArr(MyArrIndex) = cell.Value
MyArrIndex = MyArrIndex + 1
End If
Next
ReDim Preserve MyArr(1 To MyArrIndex)

sh.Name = Range("b6")

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

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
.SendMail MyArr, _
"New Quote (Customer: " & custname & ") "
On Error GoTo 0
.Close SaveChanges:=False
End With

End If

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

Next sh

Application.ScreenUpdating = True

End Sub

The code is not correct that you use

Do you want to send each sheet in the workbook to the people in column L of that sheet ??



--

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


"burl_h" wrote in message ...
Ron,

I added all that I thought I may need from your site, however it still
hangs up. This time it on the following line

For Each sh In ThisWorkbook.Worksheets
If sh.Range("L1").Value Like "?*@?*.?*" Then

It returns a null value, thus ending the for each statement. This is
where I verify that email address do exist in column L. If so
it'ssupposed to add the name to the array. This works without any
issue in excel 2003.

burl_rfc


Sub Rectangle20_Click()
'Mail_Every_Worksheet2()
Dim sh As Worksheet
Dim wb As Workbook
Dim strdate As String
Dim custname As String
Dim MyArrIndex As Long
Dim E_Mail_Count As Long
Dim cell As Range
Dim MyArr() As String

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String

Application.ScreenUpdating = False

Set Sourcewb = ActiveWorkbook

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

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.VERSION) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security
dialog that you only
'see when you copy a sheet from a xlsm file with macro's
disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

custname = Range("b7")
Range("I10").Select
Selection.Copy
Range("L2").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
For Each sh In ThisWorkbook.Worksheets
If sh.Range("L1").Value Like "?*@?*.?*" Then
strdate = Format(Now, "mm-dd-yy h-mm-ss")


E_Mail_Count = sh.Columns("L").Cells.SpecialCells
(xlCellTypeConstants).Count
ReDim MyArr(1 To E_Mail_Count)
MyArrIndex = 1
For Each cell In sh.Columns("L").Cells.SpecialCells
(xlCellTypeConstants)
If cell Like "*@*" Then
MyArr(MyArrIndex) = cell.Value
MyArrIndex = MyArrIndex + 1
End If
Next
ReDim Preserve MyArr(1 To MyArrIndex)

sh.Name = Range("b6")

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

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
.SendMail MyArr, _
"New Quote (Customer: " & custname & ") "
On Error GoTo 0
.Close SaveChanges:=False
End With

End If

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

Next sh

Application.ScreenUpdating = True

End Sub

Ron,

I need to send the initial sheet within the workbook that is copied to
each of the email names listed in column L, typically it's about 3
names. The initial sheet that is copied is always named "QuoteForm".

The initial 2 names are permanently located in cell L1 and L2, the
third name comes from cell I10, this is copied and placed into cell L3
to complete the email list.

The copied sheet is then to be named as a quote number that is in cell
"B6", for example "RFQ0999". The sheet is then saved as sheet name,
customer name and current time.
example.
customer name in cell "B7" = ABC Company , sheet name in cell "B6" =
RFQ0999 and current time.
The sheet save then becomes RFQ0999 ABC Company 02/08/09 04:15:59, we
then add the file extension on the end.

We then send the file to the email recipient listed in column L, which
should be within the array "MyArr". The email subject is also update
to contain the "New Quote (Customer: " & custname & ") "

The initial sheet "QuoteForm" should maintain it original sheet name.

Hopefully this helps

Thanks
bulr_rfc

Maybe I not understand you correct but

Why do you use this if you want to send one sheet
For Each sh In ThisWorkbook.Worksheets

Start with this code example for one sheet and read the information on the tip page
http://www.rondebruin.nl/mail/folder1/mail2.htm


--

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


"burl_h" wrote in message ...
Ron,

I need to send the initial sheet within the workbook that is copied to
each of the email names listed in column L, typically it's about 3
names. The initial sheet that is copied is always named "QuoteForm".

The initial 2 names are permanently located in cell L1 and L2, the
third name comes from cell I10, this is copied and placed into cell L3
to complete the email list.

The copied sheet is then to be named as a quote number that is in cell
"B6", for example "RFQ0999". The sheet is then saved as sheet name,
customer name and current time.
example.
customer name in cell "B7" = ABC Company , sheet name in cell "B6" =
RFQ0999 and current time.
The sheet save then becomes RFQ0999 ABC Company 02/08/09 04:15:59, we
then add the file extension on the end.

We then send the file to the email recipient listed in column L, which
should be within the array "MyArr". The email subject is also update
to contain the "New Quote (Customer: " & custname & ") "

The initial sheet "QuoteForm" should maintain it original sheet name.

Hopefully this helps

Thanks
bulr_rfc