Consulting

Results 1 to 3 of 3

Thread: SaveAs PDF problem

  1. #1

    SaveAs PDF problem

    I'm running Word 2016 version and I'm having an issue with a VBA routine I found on line. All i'm trying to do is to save as pdf. The routine works fine if the word doc is brand new and it hasn't been saving before. The routine checks to see if the document has been saved before, let's call it "Sales Proposal 1" and if it has, it prompts the user with 3 choices: "Sales 1 proposal" is already on your PC, do you wish to overwrite it? YES, NO, Cancel.

    The error message is generated whenever I click on 'NO' it gives the following message:

    invalid procedure call or argument
    It's seems to be having an issue with the 'SaveAs2' part towards the bottom of the script below in the functions section. (The bold & underline is my emphasis only so you can spot it quicker).

    Any assistance would be greatly appreciated. Thanks.

    Here is the VBA routine:
    =========================================================================== ================================
    Sub Word_ExportPDF()
    'PURPOSE: Generate A PDF Document From Current Word Document
    'NOTES: PDF Will Be Saved To Same Folder As Word Document File
    'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
    
    Dim CurrentFolder As String
    Dim FileName As String
    Dim myPath As String
    Dim UniqueName As Boolean
    
    UniqueName = False
    
    'Store Information About Word File
      myPath = ActiveDocument.FullName
      CurrentFolder = ActiveDocument.Path & ""
      FileName = Mid(myPath, InStrRev(myPath, "") + 1, _
       InStrRev(myPath, ".") - InStrRev(myPath, "") - 1)
    
    'Does File Already Exist?
      Do While UniqueName = False
        DirFile = CurrentFolder & FileName & ".pdf"
        If Len(Dir(DirFile)) <> 0 Then
          UserAnswer = MsgBox("Filename Already Exists! Click " & _
           "[Yes] to override. Click [No] to Rename.", vbYesNoCancel)
          
          If UserAnswer = vbYes Then
            UniqueName = True
          ElseIf UserAnswer = vbNo Then
            Do
              'Retrieve New File Name
                FileName = InputBox("Provide New File Name " & _
                 "(will ask again if you provide an invalid file name)", _
                 "Enter File Name", FileName)
              
              'Exit if User Wants To
                If FileName = "False" Or FileName = "" Then Exit Sub
            Loop While ValidFileName(FileName) = False
          Else
            Exit Sub 'Cancel
          End If
        Else
          UniqueName = True
        End If
      Loop
      
    'Save As PDF Document
      On Error GoTo ProblemSaving
        ActiveDocument.ExportAsFixedFormat _
         OutputFileName:=CurrentFolder & FileName & ".pdf", _
         ExportFormat:=wdExportFormatPDF
      On Error GoTo 0
    
    'Confirm Save To User
      With ActiveDocument
        FolderName = Mid(.Path, InStrRev(.Path, "") + 1, Len(.Path) - InStrRev(.Path, ""))
      End With
      
      MsgBox "PDF has now been saved in the Folder: " & FolderName
    
    Exit Sub
    
    'Error Handlers
    ProblemSaving:
      MsgBox "There was a problem saving your PDF. This is most commonly caused" & _
       " by the original PDF file already being open."
      Exit Sub
    
    End Sub
    
    
    Function ValidFileName(FileName As String) As Boolean
    'PURPOSE: Determine If A Given Word Document File Name Is Valid
    'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
    
    Dim TempPath As String
    Dim doc As Document
    
    'Determine Folder Where Temporary Files Are Stored
      TempPath = Environ("TEMP")
    
    'Create a Temporary XLS file (XLS in case there are macros)
      On Error GoTo InvalidFileName
        Set doc = ActiveDocument.SaveAs2(ActiveDocument.TempPath & _
         "" & FileName & ".doc", wdFormatDocument)
      On Error Resume Next
    
    'Delete Temp File
      Kill doc.FullName
    
    'File Name is Valid
      ValidFileName = True
    
    Exit Function
    
    'ERROR HANDLERS
    InvalidFileName:
    'File Name is Invalid
      ValidFileName = False
    
    End Function
    Last edited by Paul_Hossler; 03-04-2019 at 07:06 AM.

  2. #2
    That code is frankly dreadful - even allowing for the several undeclared document variables, the syntax for the SaveAs2 routine is wrong. To save to PDF, use the following instead. There won't be any invalid characters because it uses the same name as the document. In the event the PDF name exists in the document folder, a number is appended to the filename e.g filename(1).pdf, filename(2).pdf etc., so no PDF files are overwritten.
    Option Explicit
    
    Sub SaveAsPDF()
    'Graham Mayor - https://www.gmayor.com - Last updated - 04 Mar 2019
    Dim strDocName As String
    Dim strPath As String
    Dim intPos As Integer
    Start:
        'Find position of extension in filename
        strDocName = ActiveDocument.Name
        strPath = ActiveDocument.path & "\"
        intPos = InStrRev(strDocName, ".")
        If intPos = 0 Then
            ActiveDocument.Save
            GoTo Start
        End If
        strDocName = Left(strDocName, intPos - 1)
        strDocName = strPath & FileNameUnique(strPath, strDocName, ".pdf")
    
        ActiveDocument.ExportAsFixedFormat OutputFileName:=strDocName, _
                                           ExportFormat:=wdExportFormatPDF, _
                                           OpenAfterExport:=False, _
                                           OptimizeFor:=wdExportOptimizeForPrint, _
                                           Range:=wdExportAllDocument, from:=1, to:=1, _
                                           Item:=wdExportDocumentContent, _
                                           IncludeDocProps:=True, _
                                           KeepIRM:=True, _
                                           CreateBookmarks:=wdExportCreateHeadingBookmarks, _
                                           DocStructureTags:=True, _
                                           BitmapMissingFonts:=True, _
                                           UseISO19005_1:=False
    lbl_Exit:
        Exit Sub
    End Sub
    
    Private Function FileNameUnique(strPath As String, _
                                    strFileName As String, _
                                    strExtension As String) As String
    'Graham Mayor - http://www.gmayor.com - Last updated - 22 Jun 2018
    'strPath is the path in which the file is to be saved
    'strFilename is the filename to check
    'strextension is the extension of the filename to check
    Dim lng_F As Long
    Dim lng_Name As Long
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        strExtension = Replace(strExtension, Chr(46), "")
        lng_F = 1
        lng_Name = Len(strFileName) - (Len(strExtension) + 1)
        strFileName = Left(strFileName, lng_Name)
        'If the filename exists, add or increment a number to the filename
        'and keep checking until a unique name is found
        Do While FSO.FileExists(strPath & strFileName & Chr(46) & strExtension) = True
            strFileName = Left(strFileName, lng_Name) & "(" & lng_F & ")"
            lng_F = lng_F + 1
        Loop
        'Reassemble the filename
        FileNameUnique = strFileName & Chr(46) & strExtension
    lbl_Exit:
        Set FSO = Nothing
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    @JohnnyBravo --

    You have 172 posts so please remember to use the CODE tags icon.

    We really do like to have the macros formatted and set off

    I added them to your first post
    ---------------------------------------------------------------------------------------------------------------------

    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

Posting Permissions

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