Excel VBA to save file as PDF and email

[Rlkirkland]

I am trying to make a VBA to save a file and email it as an attachment. I have gotten it to save file as pdf. But cant for the life of me get it to send as attachment through outlook

Code for save is

Sub Save_as_PDF()



Dim wsA As Worksheet

Dim wbA As Workbook

Dim strName As String

Dim strPath As String

Dim strFile As String

Dim strPathFile As String

Dim myFile As Variant

Dim lOver As Long

On Error GoTo errHandler



Set wbA = ActiveWorkbook

Set wsA = ActiveSheet



strPath = wbA.Path

If strPath = "" Then

strPath = Application.DefaultFilePath

End If

strPath = strPath & ""



strName = wsA.Range("A1").Value _

& " - " & wsA.Range("A2").Value _

& " - " & wsA.Range("A3").Value



strFile = strName & ".pdf"

strPathFile = strPath & strFile



If bFileExists(strPathFile) Then

lOver = MsgBox("Overwrite existing file?", _

vbQuestion + vbYesNo, "File Exists")

If lOver <> vbYes Then



myFile = Application.GetSaveAsFilename _

(InitialFileName:=strPathFile, _

FileFilter:="PDF Files (*.pdf), *.pdf", _

Title:="Select Folder and FileName to save")

If myFile <> "False" Then

strPathFile = myFile

Else

GoTo exitHandler

End If

End If

Else



wsA.ExportAsFixedFormat _

Type:=xlTypePDF, _

FileName:=strPathFile, _

Quality:=xlQualityStandard, _

IncludeDocProperties:=True, _

IgnorePrintAreas:=False, _

OpenAfterPublish:=True



MsgBox "PDF file has been created: " _

& vbCrLf _

& strPathFile

End If



exitHandler:

Exit Sub

errHandler:

MsgBox "Could not create PDF file"

Resume exitHandler

End Sub

'=============================

Function bFileExists(rsFullPath As String) As Boolean

bFileExists = CBool(Len(Dir$(rsFullPath)) > 0)

End Function

'=============================

 

[Logit]

.
Edits needed to be made to your code ...

Option Explicit


Sub pdf()
Dim wsA As Worksheet, wbA As Workbook, strTime As String
Dim strName As String, strPath As String
Dim strFile As String
Dim strPathFile As String




'On Error GoTo errHandler


    Set wbA = ActiveWorkbook
    Set wsA = ActiveSheet
    


'replace spaces and periods in sheet name
    strName = Replace(wsA.Name, " ", "")
    strName = Replace(strName, ".", "_")
    
'create default name for savng file
    
    strPath = Environ("UserProfile") & "\Desktop\PDFs\"
    strFile = Sheets("Email").Range("B2").Value
    strPathFile = strPath & strFile




Dim myFolder$
myFolder = "PDFs"
    
    If Dir(myFolder, vbDirectory) = "" Then
         MkDir myFolder
    End If


'export to PDF if a folder was selected
    wsA.ExportAsFixedFormat 0, strPathFile
    
    If Len(Dir$(myFolder)) > 0 Then
        SetAttr myFolder, vbNormal
    End If


'confirmation message with file info
    MsgBox "PDF file has been created: " _
      & vbCrLf _
      & strPathFile


Mail_workbook_Outlook


exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub




Sub Mail_workbook_Outlook()


    Dim c As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strPath As String
    Dim FileName As String


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    strPath = Environ("UserProfile") & "\Desktop\PDFs\"
    FileName = Dir(strPath & "*.*")


    'On Error Resume Next
    For Each c In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).Cells
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = c.Value
            .CC = ""
            .BCC = ""
            .Subject = c.Offset(0, 1).Value
            .Body = "The parts have been placed on today's load sheet and will be processed by EOB today.  The parts have also been transferred to the repository file."
            FileName = Dir(strPath & "*.*")
            .Attachments.Add strPath & FileName
            
            '.Send                              '<-- .Send will auto send email without review
            .Display                            '<-- .Display will show the email first for review
        End With
        'On Error GoTo 0
    Next c




    Set OutMail = Nothing
    Set OutApp = Nothing
    
   byby
      
End Sub


Sub byby()  'deletes PDF file after attaching to email
Dim folder As Object
Dim path As String
path = Environ("UserProfile") & "\Desktop\PDFs\*.*"
Set folder = CreateObject("scripting.filesystemobject")


    folder.DeleteFolder path, True


End Sub

Download workbook : https://www.amazon.com/clouddrive/share/Jypwu1n0oOVb8ziUiEzWb5mBeUpVDBt5GXHPNBdb1xw

 

[DanteAmor]

After this line:

wsA.ExportAsFixedFormat _   Type:=xlTypePDF, _
   FileName:=strPathFile, _
   Quality:=xlQualityStandard, _
   IncludeDocProperties:=True, _
   IgnorePrintAreas:=False, _
   OpenAfterPublish:=True

Put:

     Dim dam
        Set dam = CreateObject("Outlook.Application").CreateItem(0)
        dam.To = email@gmail.com
        dam.Cc = another@gmail.com           'with copy
        dam.Subject ="test"
        dam.Body = "test send mail"
        dam.Attachments.Add strPathFile