Save Sheet as PDF and Email

[human12345]

Hello,


Ultimately, I am trying to have my excel sheet saved as a PDF and then emailed. I have figured out a way to do that, however once I started tweaking it, I realized I am way out of my league.

I need to also be able to:
(1) save the file as the value in cell A40 of the current sheet,
(2) save the PDF in the same location the excel file is located (right now it is specific to C:\Folder, however the file is not always in the same location, so this needs to be variable), and
(3) rename the file with a sequential number if there is an existing file.

Help would be greatly appreciated!

Sub EmailAsPDF()

Dim strFileName As String
Dim strFileExists As String

    strFileName = "C:\Folder\" & Range("A40").Value & ".pdf"
    strFileExists = Dir(strFileName)

If strFileExists = "" Then
    'The selected file doesn't exist
    
    ChDir "C:\Folder"
    'Print to PDF
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Range("A40").Value, OpenAfterPublish:=True
    
    'Declare Variables
    Dim EmailApp As Object
    Dim EmailItem As Object
    Dim myAttachments As Object
    
    'Set Variables
    Set EmailApp = CreateObject("Outlook.application")
    Set EmailItem = EmailApp.CreateItem(0)
    Set myAttachments = EmailItem.Attachments
    
    'Specify Email Items and Add Attachment
    With EmailItem
    .To = ""
    .bcc = ""
    .Subject = Range("A40").Value
    .Body = "Please see attached."
    .Attachments.Add "C:\Folder\" & Range("A40").Value & ".pdf"
    '.send
    .Display
    End With
    Set EmailItem = Nothing
    Set EmailApp = Nothing


Else
        'The selected file exists
    
        ChDir "C:\Folder"
        'Print to PDF
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Range("A40").Value & "(1)", OpenAfterPublish:=True
               
        'Set Variables
        Set EmailApp = CreateObject("Outlook.application")
        Set EmailItem = EmailApp.CreateItem(0)
        Set myAttachments = EmailItem.Attachments
        
        'Specify Email Items and Add Attachment
        With EmailItem
        .To = ""
        .bcc = ""
        .Subject = Range("A40").Value & "(1)"
        .Body = "Please see attached."
        .Attachments.Add "C:\Folder\" & Range("A40").Value & "(1).pdf"
        '.send
        .Display
        End With
        Set EmailItem = Nothing
        Set EmailApp = Nothing

    End If


End Sub

 

[human12345]

Update: I figured it out. If there are any suggestions on shortening up the sub that would be appreciated. Hope this helps someone else.

Sub EmailAsPDF()

Dim strPath As String
Dim strFileName As String
Dim strFileExists As String
Dim C As Integer

    strPath = ActiveWorkbook.Path & "\"
    C = 1
    strFileName = strPath & Range("A40").Value & " (" & C & ")" & ".pdf"
    strFileExists = Dir(strFileName)

If strFileExists = "" Then
    'The selected file doesn't exist
    
    ChDir strPath
    'Print to PDF
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Range("A40").Value & " (" & C & ")", OpenAfterPublish:=True
    
    'Declare Variables
    Dim EmailApp As Object
    Dim EmailItem As Object
    Dim myAttachments As Object
    
    'Set Variables
    Set EmailApp = CreateObject("Outlook.application")
    Set EmailItem = EmailApp.CreateItem(0)
    Set myAttachments = EmailItem.Attachments
    
    'Specify Email Items and Add Attachment
    With EmailItem
    .to = ""
    .bcc = ""
    .Subject = Range("A40").Value & " (" & C & ")"
    .Body = "Please see attached"
    .Attachments.Add strFileName
    '.send
    .Display
    End With
    Set EmailItem = Nothing
    Set EmailApp = Nothing


Else
    'The selected file exists
    Dim strFileName2 As String
    Dim strFileExists2 As String
    
    
    Do
                
        C = C + 1
        strFileName2 = strPath & Range("A40").Value & " (" & C & ")" & ".pdf"
        strFileExists2 = Dir(strFileName2)
        
                    
        If strFileExists2 = "" Then
            ChDir strPath
            'Print to PDF
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Range("A40").Value & " (" & C & ")", OpenAfterPublish:=True
                       
            'Set Variables
            Set EmailApp = CreateObject("Outlook.application")
            Set EmailItem = EmailApp.CreateItem(0)
            Set myAttachments = EmailItem.Attachments
                
            'Specify Email Items and Add Attachment
            With EmailItem
            .to = ""
            .bcc = ""
            .Subject = Range("A40").Value & " (" & C & ")"
            .Body = "Please see attached."
            .Attachments.Add strFileName2
            '.send
            .Display
            End With
            Set EmailItem = Nothing
            Set EmailApp = Nothing
            
            Exit Sub
        Else
        
        End If
            
    Loop



End If


End Sub

 

[human12345]

Actually....

I have tried putting this file onto our shared network, and now ".Attachments.Add strFileName" errors, can't locate file. I changed "ChDir" to "ChDrive" and that seems to have solved the issue, however now won't work on my local drive. Any suggestions to make this file compatible on both?