Sub Finn_Comfort_bestellen()
Dim ZeileMax As Long
Dim Name As Variant
Dim rngToFill As Range
With ThisWorkbook.Sheets("Finn Comfort")
ZeileMax = .Cells(Rows.Count, 1).End(xlUp).Row
Dim SourceWB As Workbook
Dim DestinWB As Workbook
Dim SourceWS As Worksheet
Dim WSb As Worksheet
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim ExternalLinks As Variant
Dim TempFilePath As String
Dim FileExtStr As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim x As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Set SourceWB = ActiveWorkbook
SourceWB.Windows(1).SelectedSheets.Copy
Set DestinWB = ActiveWorkbook
TempFilePath = Environ$("temp") & "\"
DefaultName = "Bestellung"
TempFileName = Application.InputBox("Wie söll dä Aahang heissä?", _
"File Name", Type:=2, Default:=DefaultName)
If TempFileName = False Then GoTo ExitSub
FileExtStr = ".xlsx"
ExternalLinks = DestinWB.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error Resume Next
For x = 1 To UBound(ExternalLinks)
DestinWB.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
Next x
On Error GoTo 0
DestinWB.SaveCopyAs TempFilePath & TempFileName & FileExtStr
On Error Resume Next
Set OutlookApp = GetObject(class:="Outlook.Application")
Err.Clear
If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application")
If Err.Number = 429 Then
MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
GoTo ExitSub
End If
On Error GoTo 0
Set OutlookMessage = OutlookApp.CreateItem(0)
On Error Resume Next
With OutlookMessage
.To = ""
.CC = ""
.BCC = ""
.Subject = TempFileName
.Body = "Im Anhang finden Sie die Liste mit unseren Bestellungen" & vbNewLine & vbNewLine & "Orthopädie" & vbNewLine & "Malgaroli & Werne"
.Attachments.Add TempFilePath & TempFileName & FileExtStr
.Display
End With
On Error GoTo 0
DestinWB.Close SaveChanges:=False
Kill TempFilePath & TempFileName & FileExtStr
Set OutlookMessage = Nothing
Set OutlookApp = Nothing
ExitSub:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Set WSb = Sheets("Finn Comfort bestellt")
WSb.Range("A2").EntireRow.Resize(ZeileMax).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
WSb.Range("A2").Value = .Range("A2:I" & ZeilMax).Value
.Range("A2:I" & ZeileMax).ClearContents
Name = InputBox("Wer bist du?", "Sali du.")
Set rngToFill = WSb.Range("J2:J" & ZeileMax)
rngToFill.Value = Name
Set rngToFill = WSb.Range("K2:K" & ZeileMax)
rngToFill.Value = Date
End With
ActiveWorkbook.Save
End Sub