Outlook - Save Worksheet as PDF and attach to outlook mail

hi,

I have userform with textbox "FileName" and "Send" button.

I need to save current sheet "Sheet1" as PDF and name it as entered in "FileName" then attach it to outlook once you click "Send"

Please help!

Hi,
try this
Dont forget to select Outlook Object Library in the references under Tools

Sean

Sub SendaPDF()
'   Copies Sheet and Calls function Create_PDF to create a pdf copy and place in e-mail
'   Uses early binding
'   Requires a reference to the Outlook Object Library
    Dim OutlookApp As Outlook.Application
    Dim MItem As Object
    Dim Recipient As String, Subj As String
    Dim Msg As String, Fname As String
    Dim EmailAddr As String
            
    Application.ScreenUpdating = False
                
'   Message details
    EmailAddr = "Your e-mail goes here"
    Subj = "Your Title goes here"
    Msg = "Please find attached Sheet1"     
    ' Determines new file name to be given to PDF file
    Fname = userform1.FileName.value
    ' Calls on function to create PDF for desired sheet(s), gives the name to call the new file
    Filename = Create_PDF(Sheets("Sheet1"), Fname, True, True)

'   Create the attachment
    Sheets("Sheet1").Activate
    ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=Fname
    
'   Create Outlook object
    Set OutlookApp = New Outlook.Application
    
'   Create Mail Item and send it
    Set MItem = OutlookApp.CreateItem(olMailItem)
    With MItem
      .To = EmailAddr
      .Subject = Subj
      .Display  ' opens mail to allow edit
      .Body = Msg '& .Body ' adds signature
      .Attachments.Add Filename 'Fname
      '.Save 'to Drafts folder (delete .display if required to send mail to drafts)
      '.Send   'if chosen will automate sending of mail
    End With
   Set OutlookApp = Nothing

'   Delete the file
    Kill Fname
    Sheets("Sheet1").Activate
    Application.ScreenUpdating = True
End Sub


Function Create_PDF(Myvar As Object, FixedFilePathName As String, _
                 OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant

    'Test to see if the Microsoft Create/Send add-in is installed.
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the PDF file.
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                  Title:="Create PDF")

            'If you cancel this dialog, exit the function.
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        'If OverwriteIfFileExist = False then test to see if the PDF
        'already exists in the folder and exit the function if it does.
        If OverwriteIfFileExist = False Then
        If Dir(Fname) <> "" Then Exit Function
        End If

        'Now export the PDF file.
        On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False 'OpenPDFAfterPublish
        On Error GoTo 0

        'If the export is successful, return the file name.
        If Dir(Fname) <> "" Then Create_PDF = Fname
    End If
End Function

Hi,
try this one
ive tested it and it works ok

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
     
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     ' type debug.print browseforfolder in intermediate and enter for folder path
End Function

Sub SendAsPDF()
'   Uses early binding
'   Requires a reference to the Outlook Object Library
    Dim OutlookApp As Outlook.Application
    Dim MItem As Object
    Dim Recipient As String, Subj As String
    Dim Msg As String, FName As String
    Dim WorkbookName As String
    Dim EmailAddr As String
    
    Application.ScreenUpdating = False
    
    EmailAddr = "your e-mail address goes here"
    WorkbookName = UserForm1.TBFilename.Value
'   Message details
    Subj = "Your title goes here"
    Msg = "Please find attached  " & WorkbookName
    FName = Application.DefaultFilePath & "\" & _
      WorkbookName & ".pdf"
  
'   Create the attachment
    Sheets("Sheet1").Activate
    ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=FName
    
'   Create Outlook object
    Set OutlookApp = New Outlook.Application
    
'   Create Mail Item and send it
    Set MItem = OutlookApp.CreateItem(olMailItem)
    With MItem
      .To = EmailAddr
      .Subject = Subj
      .Body = Msg
      .Display
      .Attachments.Add FName
      '.Save 'to Drafts folder
      '.Send
    End With
    Set OutlookApp = Nothing

'   Delete the file
    Kill FName
    Sheets("Sheet1").Activate
    Application.ScreenUpdating = True
End Sub

Sean.

This line keeps giving me issues

ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=FName

Finally worked! God bless!

Sean,
Unfortunately i am getting an error when i try the code on my Sheet with multiple data. It works fine on new sheet with single cell filled, but when i try running on my sheet with a table it gives me an error

"run-time error '1004' application-defined or object-defined error"

On line:

ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName1:=Fname

Please advise!

thx