Sub SaveToPDF()
Dim StrPath As String, StrName As String, Result
With ActiveDocument
  On Error GoTo Errhandler
  StrPath = GetFolder & "\"
  StrName = Split(.Name, ".")(0)
  While Dir(StrPath & StrName & ".pdf") <> ""
    Result = InputBox("WARNING - A file already exists with the name:" & vbCr & _
      Split(.Name, ".")(0) & vbCr & _
      "You may edit the filename or continue without editing." _
      & vbCr & vbTab & vbTab & vbTab & "Proceed?", "File Exists", StrName)
    If Result = vbCancel Then Exit Sub
    If StrName = Result Then GoTo Overwrite
    StrName = Result
  Wend
Overwrite:
  .ExportAsFixedFormat OutputFileName:=StrPath & StrName & ".pdf", _
  ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
  OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
  Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
  CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
  BitmapMissingFonts:=True, UseISO19005_1:=False
End With
Errhandler:
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function