Run-Time Error 1004: Document Not Saved

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

Code:

---

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

---

1. It looked like there was some redundant code in there, like Exporting the file twice

2. Not sure exactly what caused the difference between computers, but taking a wild guess, something like Title = Range ("I4") will use I4 on whatever the active sheet is, and it might not be DWS

3. Did a little re-arranging, but this seems to work regardless of the active sheet

Code:

---

Option Explicit


Private Sub CommandButton2_Click()
    Dim IsCreated As Boolean
    Dim PdfFile As String, Title As String
    Dim OutlApp As Object
   
    Title = Worksheets("DWS").Range("I4").Value
    PdfFile = ThisWorkbook.Path & Application.PathSeparator & Title & "_" & "DWS" & "_" & Format(Now, "dd-MMM-yyyy") & ".pdf"
   
    Worksheets("Sheet1").Activate  '  <<<<<<<<<<<<<<<<<


    Application.ScreenUpdating = False
    MsgBox PdfFile
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, OpenAfterPublish:=False
    Application.ScreenUpdating = True


    ' 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 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
 
 
    ' 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

---

Thanks Paul, that seems to have fixed the bugs. Your help is greatly appreciated!