VBA som sender et kopi ef den kørende excel-fil som vedhæftet fil

Sub Mail_ActiveSheet()
' sender kopi af plan som vedhæftet fil til de initialer der er defineret i de dedikerede celler i arket Settings
'For Tips see: http://www.rondebruin.nl/win/winmail/div/tips.htm
'Working in Excel 2000-2013
    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 i As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    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-2013
            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 With

    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False

    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Kopi af plan " & Format(Now, "YYYYMMDD")

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
               
        On Error Resume Next
       
        Dim MailToInits As Variant
        ThisWorkbook.Sheets("Settings").Activate
        MailToInits = Range("MailToInits") ' definerer hvor mange rækker der skal løbes igennem

        For i = 1 To UBound(MailToInits, 2) ' løber kolonnen med initialer igennem indtil rækk4 14
          If Len(MailToInits(1, i)) < 5 Then ' tjekker at modtager er defineret som initaler (max 4 tegn)
          ToMailAdr = LCase(MailToInits(1, i)) & "@OurDomain.com" ' bygger emailadressen op ud fra inits
          End If
            .SendMail ToMailAdr, _
                      "Kopi af plan (vedhæftet fil)..." '<--Adresse og Emne tilrettes
            If Err.Number = 0 Then Exit For
        Next i
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

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

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
Sheets(1).Select
End Sub

Kill TempFilePath & TempFileName & FileExtStr