Mailen bestaand als bestand zzonder macro

[PeterBijns]

Beste specialisten,
Ik heb onderstaande macro welke het bestand mailt, het bestand wordt gemaild als een bestaand met de macro's daarin.

Hoe kan ik het zo maken dat het bestaand wel als bestaand met macro wordt opgeslaagen wordt maaar het te mailen bestaand geen macro's bevat??

Alvast weer bedankt,

Peter

Sub Mail()
'---Deze macro slaat dit bestand in een bepaalde map en met een bepaalde bestandsnaam op tevens wordt het bestand gemaild

'-----Opslag gedeelte-----------------------------
Range("B3").Select


ChDir "F:\Weekroosters"
ActiveWorkbook.SaveAs Filename:="F:\Weekroosters\Verzonden\" & Range("MailGegevens!E7"), _
FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

On Error Resume Next
MkDir directory
On Error GoTo 0
Application.DisplayAlerts = False
fileNaam = Naam & ".xlsm"
'----Mail gedeelte-------------------------------
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 strto As String
Dim strbody As String
Dim cell As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
Sheets("Rooster").Copy
Set Destwb = ActiveWorkbook
With Destwb
'opslaan als excel bestand met macro's
FileExtStr = ".xlsx": FileFormatNum = 51

'opslaan als excelbestand zonder macro's
' FileExtStr = ".xlsm": FileFormatNum = 50
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = ThisWorkbook.Sheets("MailGegevens").Range("E7").Value
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
For Each cell In ThisWorkbook.Sheets("MailGegevens").Range("B1:B60")
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value) = "ja" Then
If strto = "" Then strto = stro & ";"
strto = strto & cell.Value & ";"
End If
Next cell
.To = strto
.CC = ""
.BCC = ""
.Subject = ThisWorkbook.Sheets("MailGegevens").Range("E7").Value
For Each cell In ThisWorkbook.Sheets("MailGegevens").Range("D160")
strbody = strbody & cell.Value & vbNewLine
Next
.body = strbody
.Attachments.Add Destwb.FullName
.Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.EnableEvents = True
End With
End Sub

 

[edmoor]

Sla hem op met extensie .xlsx en FileFormat:=xlOpenXMLWorkbook

Plaats ook even je code in codetags want het is zeer slecht te lezen zo zonder de juiste inspringpunten.

 

[PeterBijns]

Edmoor,

Het is gelukt dank je wel.

Groet, Peter