Email Code to Email Active XLSX sheet

[blandreth]

Hi,

I have the below code that will convert my active sheet to a .pdf file to be emailed. However, I am looking for code that will attach the active xlsx or xlsm sheet to an email.

Sub CreateEmail()
Dim olMail As Object
Dim ws As Worksheet
Dim fName As String
Dim olApp As Object
 
 
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.createItem(0)
Set ws = ActiveSheet
fName = Environ("UserProfile") & "\Desktop\” & Range(“L10”).Value & “.pdf"
ws.ExportAsFixedFormat xlTypePDF, fName, xlQualityStandard
 
 
With olMail
    .To = ""
    .Subject = "Range(“L10”)"
    .Body = ""
    .Attachments.Add fName
    .Display 'You can change to .Send to send email instead of displaying it
End With
 
 
Kill fName
End Sub


[\code]

I appreciate the help.

Thanks,
Brian

 

[John_w]

Try this macro:

Public Sub Email_Active_Sheet()

    Dim wb As Workbook
    Dim p As Long, tempWorkbookFullName As String
    Dim emailSubject As String
    Dim oApp As Object, oMail As Object
    
    Set wb = ActiveWorkbook
    
    With wb
        If .Path = vbNullString Then
            MsgBox "You must save the active workbook (" & .Name & ")", vbExclamation
            Exit Sub
        End If
        p = InStrRev(.FullName, ".")
        emailSubject = .ActiveSheet.Range("L10").Value
        tempWorkbookFullName = Environ("temp") & "\" & emailSubject & Mid(.FullName, p)
        .ActiveSheet.Copy
        ActiveWorkbook.SaveAs Filename:=tempWorkbookFullName, FileFormat:=.FileFormat
        ActiveWorkbook.Close False
    End With
   
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.createItem(0)
   
    With oMail
        .To = "email.address@domain"
        .Subject = emailSubject
        .Body = "This is the body of the email."
        .Attachments.Add tempWorkbookFullName
        .Display  'or .Send
    End With
    
    Kill tempWorkbookFullName
    
    Set oMail = Nothing
    Set oApp = Nothing
   
End Sub

 

[DanteAmor]

Try this

Sub CreateEmail()
  Dim olMail As Object, ws As Worksheet, fName As String
  Set olMail = CreateObject("Outlook.Application").createItem(0)
  Set ws = ActiveSheet
  fName = Environ("UserProfile") & "\Desktop\" & Range("L10").Value & ".xlsx"
[COLOR=#0000ff]  ws.Copy[/COLOR]
[COLOR=#0000ff]  ActiveWorkbook.SaveAs Filename:=fName, FileFormat:=xlOpenXMLWorkbook[/COLOR]
[COLOR=#0000ff]  ActiveWorkbook.Close False[/COLOR]
  With olMail
    .To = ""
    .Subject = Range("L10")
    .Body = ""
    .Attachments.Add fName
    .Display 'You can change to .Send to send email instead of displaying it
  End With
  Kill fName
End Sub

 

[blandreth]

Perfect!

Thanks guys. I appreciate the help.

 

[DanteAmor]

Glad to help you, thanks for the feedback.