Ajannear
11-22-2021, 06:25 PM
Hi,
I am new to VBA and am having some issues with the below code. Currently I have a Command Button set up to PDF the active excel sheet, save it to the home location of the document, and then attach it to an email and send to a list of people.
This document will be shared across the business, and during testing on another computer found that the code coloured red below, did not work, instead coming up with Run Time Error 1004: Document no saved. The document may be open, or an error may have been encountered when saving.
When setting up the home location, I have ensured to have this as a common location that has no permissions to access, and is the same across the business. I thought it may have been the formatting on the date, but have worked repeatedly on my own computer.
Any help would be greatly appreciated. Thanks
Private Sub CommandButton2_Click()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim strFilename As String
Dim rngRange As Range
Dim strSaveToDirectory As String
Dim x As Date
x = Format(Now, "dd-MMM-yyyy")
Title = Range("I4")
' where you need to pick file name
Set rngRange = Worksheets("DWS").Range("I4")
'Create File name
strFilename = rngRange.Value & "_" & "DWS" & "_" & x
'Subfolder for saving
strSaveToDirectory = ThisWorkbook.Path & Application.PathSeparator
Application.ScreenUpdating = False
myFilename = strSaveToDirectory & strFilename
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=myFilename, _
OpenAfterPublish:=False
Application.ScreenUpdating = True
' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strSaveToDirectory & strFilename & ".pdf", 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 & " DWS"
.To = Worksheets("DWS").Range("B5").Value ' <-- Put email of the recipient here
' .CC = "Mobilisation" & ";" & Worksheets("DWS").Range("F5").Value ' <-- Put email of 'copy to' recipient here
.Body = "Hi," & vbLf & vbLf _
& "Please find attached your copy of signed DWS in PDF format." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add myFilename & ".pdf"
' 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
' 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
I am new to VBA and am having some issues with the below code. Currently I have a Command Button set up to PDF the active excel sheet, save it to the home location of the document, and then attach it to an email and send to a list of people.
This document will be shared across the business, and during testing on another computer found that the code coloured red below, did not work, instead coming up with Run Time Error 1004: Document no saved. The document may be open, or an error may have been encountered when saving.
When setting up the home location, I have ensured to have this as a common location that has no permissions to access, and is the same across the business. I thought it may have been the formatting on the date, but have worked repeatedly on my own computer.
Any help would be greatly appreciated. Thanks
Private Sub CommandButton2_Click()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim strFilename As String
Dim rngRange As Range
Dim strSaveToDirectory As String
Dim x As Date
x = Format(Now, "dd-MMM-yyyy")
Title = Range("I4")
' where you need to pick file name
Set rngRange = Worksheets("DWS").Range("I4")
'Create File name
strFilename = rngRange.Value & "_" & "DWS" & "_" & x
'Subfolder for saving
strSaveToDirectory = ThisWorkbook.Path & Application.PathSeparator
Application.ScreenUpdating = False
myFilename = strSaveToDirectory & strFilename
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=myFilename, _
OpenAfterPublish:=False
Application.ScreenUpdating = True
' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strSaveToDirectory & strFilename & ".pdf", 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 & " DWS"
.To = Worksheets("DWS").Range("B5").Value ' <-- Put email of the recipient here
' .CC = "Mobilisation" & ";" & Worksheets("DWS").Range("F5").Value ' <-- Put email of 'copy to' recipient here
.Body = "Hi," & vbLf & vbLf _
& "Please find attached your copy of signed DWS in PDF format." & vbLf & vbLf _
& "Regards," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add myFilename & ".pdf"
' 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
' 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