Hi
i am trying to adapt a code, to create and email a pdf to include the option to select where to save the file. I keep getting a runtime error 1004 Getsaveasfilename of object application failed.
Sub AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim IntialName As String
Dim fileSaveName As Variant
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set ws = Sheets("Open day letter")
Set rng = ws.Range("B8:J274")
Title = Range("c6").Text & "_" & Range("B1") & "_" & Format(Now(), "DD-MM-YYYY")
InitialName = Range("c6").Text & "_" & Range("B1") & "_" & Format(Now(), "DD-MM-YYYY") & ".PDF"
fileSaveName = Application.GetSaveAsFilename(InitialFileName:=InitialName, _
fileFilter:="PDF Files (*.PDF")
If fileSaveName <> False Then
MsgBox "Save as " & fileSaveName
End If
' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"
' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = Title
.To = Range("E6")
.CC = ""
.BCC = ""
.Subject = Range("C6").Value & " , " & Range("C18").Value & " , " & Range("B2").Value
.Body = Range("C20").Text & vbNewLine & " " & vbNewLine & "I am pleased to invite you along to our pump open day and have attached the necessary details.." & vbNewLine & " " & vbNewLine & "I would be grateful if you confirm attendence in the next 10 days. In the meantime if you have any questions please do not hesitate to contact me."
.Attachments.Add PdfFile
' Try to send
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
On Error GoTo 0
End With
' Delete PDF file
Kill PdfFile
' Quit Outlook if it was created by this code
If IsCreated Then OutlApp.Quit
' Release the memory of object variable
Set OutlApp = Nothing
End Sub
Any help much appreciated.
Bookmarks