How to email an opened Excel file as attachment using VBA?

You can email an open Excel file as an attachment using VBA, but you need to save a copy of the workbook first, because Outlook can't attach a file that's currently open and locked for editing.

Sub SendActiveWorkbookAsEmail()
    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim tempFolderPath As String
    Dim tempFileName As String
    Dim tempFileFullPath As String
    Dim currentWorkbook As Workbook
    Dim waitTime As Date

    On Error GoTo ErrorHandler

    Set currentWorkbook = ThisWorkbook

    tempFolderPath = Environ$("TEMP") & "\"
    tempFileName = "EmailCopy_" & Format(Now, "yyyymmdd_hhnnss") & "_" & currentWorkbook.Name
    tempFileFullPath = tempFolderPath & tempFileName

    ' Save a copy of the workbook
    currentWorkbook.SaveCopyAs tempFileFullPath

    ' Wait 3 seconds to ensure file is saved
    waitTime = Now + TimeValue("0:00:03")
    Do While Now < waitTime
        DoEvents
    Loop

    ' Check if file exists before proceeding
    If Dir(tempFileFullPath) = "" Then
        MsgBox "Temporary file was not created successfully.", vbCritical
        Exit Sub
    End If

    ' Initialize Outlook
    On Error Resume Next
    Set outlookApp = GetObject(, "Outlook.Application")
    If outlookApp Is Nothing Then
        Set outlookApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo ErrorHandler

    ' Create email
    Set outlookMail = outlookApp.CreateItem(0)

    With outlookMail
        .To = "[email protected]"
        .Subject = "Subject of the Email"
        .Body = "Please find the attached Excel file."
        .Attachments.Add tempFileFullPath
        .Display ' Use .Send to send automatically
    End With

    ' Optional: Delete temp file
    On Error Resume Next
    Kill tempFileFullPath
    On Error GoTo 0

Cleanup:
    Set outlookMail = Nothing
    Set outlookApp = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbExclamation
    Resume Cleanup
End Sub

I adjusted Michal's script from below and this works:

Sub SendEmailWithOpenedWorkbook()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim TempFileFullPath As String
    
    ' Define temporary file path and name
    TempFilePath = Environ("TEMP") & "\"
    TempFileName = "File_Name" & Format(Now, "YYYYMMDD") & ".xlsx"
    TempFileFullPath = TempFilePath & TempFileName
    
    ' Save a copy of the workbook to the temporary location
    ThisWorkbook.SaveCopyAs TempFileFullPath
    
    ' Create Outlook application and email
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
    With OutMail
        .To = "email address" ' Replace with recipient's email
        .CC = ""                     ' Add CC if needed
        .BCC = ""                    ' Add BCC if needed
        .Subject = "Subject of the Email"
        .Body = "Please find the attached Excel file."
        .Attachments.Add TempFileFullPath
        .Send
    End With
    On Error GoTo 0
    
    ' Clean up
    Kill TempFileFullPath ' Delete the temporary file
    Set OutMail = Nothing
    Set OutApp = Nothing
    
End Sub