VBA warning message when saving PDF over existing file

[Shadkng]

Hi, would it be possible to have a warning box pop up to prevent saving the PDF over an existing file? Also, can we have the box show the existing filename and be able to change the name and then save it? Thanks

Sub DETAIL_PDF()
    Dim response As String
    Dim PrintAreaString As String
    response = InputBox("Enter column letter for 2nd part of range", "Enter Data")
    If response = Cancel Then
    Exit Sub
    End If
      Application.ScreenUpdating = False
      With ActiveSheet
        PrintAreaString = "A3:$" & Trim(UCase(response)) & "$" & .Range("B1").Value
        If response <> "" Then
            .PageSetup.PrintArea = PrintAreaString
            .PageSetup.Orientation = xlLandscape
            .PageSetup.Zoom = False
            .PageSetup.FitToPagesWide = 1
            .PageSetup.FitToPagesTall = False
            .PageSetup.LeftMargin = 36
            .PageSetup.TopMargin = 72
            .PageSetup.RightMargin = 36
            .PageSetup.BottomMargin = 36
    End If
    End With
    fileSaveName = ActiveWorkbook.Path & "\" & "FRIEDLAND QUOTE " & [B6] & " " & "JOB " & [B7] & " " & [A15] & " " & [AB15] & " " & [AD15] & [B9] & " PCS" & " " & Format(Date, "mmddyy")
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        fileSaveName _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=True '(change this to "False" to prevent the file from opening after saving)
    Application.ScreenUpdating = True
End Sub

 

[Yongle]

spotted an error post deleteded - see below

 

[Yongle]

Insert immediately below line beginning fileSaveName = ActiveWorkbook.Path.....

Dim fpath As String [COLOR=#006400][I]'declare with other variables[/I][/COLOR]

TestExistence:
fpath = Left(fileSaveName, InStrRev(fileSaveName, "\"))
If Not Dir(fileSaveName & ".pdf", vbDirectory) = vbNullString Then
    fileSaveName = fpath & InputBox("Amend file name to continue!", "PDF File Exists!", Replace(fileSaveName, fpath, ""))
    GoTo TestExistence
End If

 

[Shadkng]

Hi, pretty much works fine except if you hit "cancel" in the input box it returns a run time error 2147024773.

 

[Yongle]

minor modification to allow value of input box to be assessed

you did not say what should happen upon cancel
- here procedure exits without saving pdf
- amend to suit your own requirements

Dim fPath As String [I][COLOR=#006400]'declare with other variables[/COLOR][/I]
Dim fName As String

TestExistence:
    fPath = Left(fileSaveName, InStrRev(fileSaveName, "\"))
    fName = Replace(fileSaveName, fPath, "")
    If Not Dir(fileSaveName & ".pdf", vbDirectory) = vbNullString Then
        On Error Resume Next
        fName = InputBox("Amend file name to continue!", "PDF File Exists!", fName)
        If fName = "" Then
            MsgBox "Cancelled, not saved,...!"
            Exit Sub
        Else
            fileSaveName = fPath & fName
        End If
        GoTo TestExistence
    End If

 

[John_w]

Another way, without the GoTo and On Error statements.

    Dim fileSaveName As String, filePath As String

    fileSaveName = "FRIEDLAND QUOTE " & [B6] & " " & "JOB " & [B7] & " " & [A15] & " " & [AB15] & " " & [AD15] & [B9] & " PCS" & " " & Format(Date, "mmddyy")
    
    filePath = ActiveWorkbook.Path & "\" & fileSaveName & ".pdf"
    While Dir(filePath) <> vbNullString And fileSaveName <> ""
        fileSaveName = InputBox("The PDF for " & fileSaveName & " already exists." & vbCrLf & vbCrLf & "Please enter a new file name:", "Save as PDF", fileSaveName)
        filePath = ActiveWorkbook.Path & "\" & fileSaveName & ".pdf"
    Wend
        
    If fileSaveName <> "" Then
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=filePath, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True '(change this to "False" to prevent the file from opening after saving)
    Else
        MsgBox "PDF not created"
    End If

 

[Shadkng]

Hi, Thanks. I forget that the cancel part has to be coded. Next time I think I can do it myself!

 

[Shadkng]

Hi, Would it be possible to revise the code so when the filename exists we could write over it when hitting OK. But it still needs to show the filename in the box with the option to edit it. Thanks

 

[John_w]

Try this:

    Dim fileSaveName As String, filePath As String
    Dim reply As Variant
    
    fileSaveName = "FRIEDLAND QUOTE " & [B6] & " " & "JOB " & [B7] & " " & [A15] & " " & [AB15] & " " & [AD15] & [B9] & " PCS" & " " & Format(Date, "mmddyy")
    
    filePath = ActiveWorkbook.Path & "\" & fileSaveName & ".pdf"
    
    reply = vbNo
    While Dir(filePath) <> vbNullString And fileSaveName <> "" And reply = vbNo
        reply = MsgBox("The PDF for " & fileSaveName & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo, "Save as PDF")
        If reply = vbNo Then
            fileSaveName = InputBox("Please enter a new file name:", "Save as PDF", fileSaveName)
        End If
        filePath = ActiveWorkbook.Path & "\" & fileSaveName & ".pdf"
    Wend
        
    If fileSaveName <> "" Then
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=filePath, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True '(change this to "False" to prevent the file from opening after saving)
    Else
        MsgBox "PDF not created"
    End If

 

[Shadkng]

Hi, I tried it but now it goes straight to making a PDF skipping the message box.