ich bin im Internet fündig geworden um mein bestehendes Excelsheet zu versenden. Leider bin ich kein VBA Profi und habe da noch ein kleines Problem. Ich hoffe mir kann dabei einer helfen.
Momentan ist es so das die Datei als .xlsm verschickt wird. Mir wäre es am liebsten wenn er die Quelldatei als .xlsm speichert und eine Kopie als .xls verschickt - sprich das bei meiner Email die Makros deaktiviert sind. Ist dies möglich und kann mir einer dabei helfen? Vielen Dank im voraus :-)
Der Code sieht bisher so aus:
Sub Mail_Workbook()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb1 = ActiveWorkbook
'Make a copy of the file/Open it/Edit it/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = "Pfad zum Zielordner"
TempFileName = "filename " & Format(Now() - 1, "dd-mmm-yy")
'Configure yesterday
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
'**************Add code to edit the file here********************
'Insert a text and Date in cell A1 of the first sheet in the workbook.
'Other things you can think of are for example, delete a whole sheet or a range.
wb2.Worksheets(1).Range("A1").Value = "Copy created on " & Format(Date, "dd-mmm-yyyy")
'Save the file after we changed it with the code above
wb2.Save
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = ThisWorkbook.Sheets("QUELLEVERSAND").Range("O1").Value
.CC = ""
.BCC = ""
.Subject = "TEXT - " & Format(Now() - 1, "dd-mmm-yy")
.Body = "Dear colleagues," & vbCrLf & "pls find attached our latest ..." & vbCrLf & " _
Feel free to contact me if there are any questions." & vbCrLf & "Kindly regards" & vbCrLf & "ME"
.Attachments.Add wb2.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
wb2.Close savechanges:=False
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub