VBA Save as PDF and email

[miturand]

hi all,

i have a following VBA but it keeps trowing a runtime 438 error object doesn't support property or method. ms outlook library 16.0 is active

file saving works, just can launch Outlook and send. Any ideas?

Public Sub SaveAndSendPDF()


Dim OutApp, OutMail  As Object


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)






  myPath = "N:\AX\Reports\InventoryShiftReports\"
  strDate = Format(Date, "ddmmyyyy")
  PDF = myPath & "InventoryShiftReport" & "_" & strDate & "_" & Environ("Username") & ".pdf"
 
  With ActiveSheet.Range("A1:G40")
    .ExportAsFixedFormat Type:=xlTypePDF, FileName:=PDF_File
  End With
  OutApp.Visible = True
  With myMail
    .Subject = "Stock Inventory report " & Date
    .To = ""
    .Body = "<H3>Hi All,</H3><br><br>" & _
            "******>Please see the attached PDF file with the latest report." & _
            "<br><br>" & "Kind Regards,</body>"
    .Signature = True
    .Attachments.Add PDF
    .Display
    


  End With
 
 
        Set OutApp = Nothing
        Set OutMail = Nothing
 
End Sub

 

[Kamolga]

Hi,

Can you test this macro to see if it opens your outlook (it will prompt you for folder to save the first sheet as pdf)

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xStr As String


Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)


If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xStr = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
xFolder = xFolder + "\" + xSht.Name + "-" + xStr + ".pdf"


'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If


Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard


'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = xSht.Name + "-" + xStr + ".pdf"
.Attachments.Add xFolder
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub

 

[miturand]

it does work, however its too complicated.

dont need folder selection, this is set variable

 

[Kamolga]

This work for me, with your parameters, just put the name of your signature

Function GetBoiler(ByVal sFile As String) As StringDim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xStr As String
Set xSht = ActiveSheet
xFolder = "c:\users\Kamal\Desktop"
xStr = Format(Date, "ddmmyyyy")
xFolder = xFolder & "InventoryShiftReport" & "_" & xStr & "_" & Environ("Username") & ".pdf"
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
On Error Resume Next
'Body
Dim strbody As String
strbody = "<H3><B>Hi All,</B></H3>" & _
              "******>Please see the attached PDF file with the latest report.<br>" & _
              "<br><br><B>Kind Regards,</B>"
'Signature
'Change only Signature1 to the name of your signature
    Dim SigString As String
Dim Signature As String
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\[COLOR=#ff0000]Signature1[/COLOR].htm"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = "Stock Inventory report " & Date
.Attachments.Add xFolder
.HTMLBody = strbody & "<br>" & Signature
End With


End Sub