Consulting

Results 1 to 3 of 3

Thread: Run-Time Error 1004: Document Not Saved

  1. #1

    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


    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

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Posts
    8,028
    Location
    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


    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
    Attached Files Attached Files
    Last edited by Paul_Hossler; 11-22-2021 at 09:44 PM.
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •