Option Explicit

Sub Macro1()
Dim strPath As String
Dim strDocname As String
Dim lngAsk As Long
    On Error Resume Next
    ActiveDocument.Save
    If Len(ActiveDocument.Path) = 0 Then
        MsgBox "You must save the file before using this macro!"
        GoTo lbl_Exit
    End If
    On Error GoTo 0
    strPath = ActiveDocument.Path & Chr(92)
    lngAsk = MsgBox("Do you wish to save the PDF in the same folder as the document?", vbYesNo)
    If lngAsk = vbNo Then
        strPath = BrowseForFolder("Select the folder to save the PDF")
    End If
    strDocname = ActiveDocument.Name
    strDocname = Left(strDocname, InStrRev(strDocname, Chr(46))) & "pdf"
    If FileExists(strPath & strDocname) Then
        lngAsk = MsgBox(strPath & strDocname & " already exists." & vbCr & _
                        "Do you wish to overwrite the file?", vbYesNo)
        If Not lngAsk = vbYes Then
            strDocname = strPath & FileNameUnique(strPath, strDocname, "pdf")
        Else
            strDocname = strPath & strDocname
        End If
    Else
        strDocname = strPath & strDocname
    End If
    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
'Requires the use of the FileExists function
'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 lngF As Long
Dim lngName As Long
    strExtension = Replace(strExtension, Chr(46), "")
    lngF = 1
    lngName = Len(strFileName) - (Len(strExtension) + 1)
    strFileName = Left(strFileName, lngName)
    'If the filename exists, add or increment a number to the filename
    'and keep checking until a unique name is found
    Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
        strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    'Reassemble the filename
    FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(strFullName As String) As Boolean
'Graham Mayor - http://www.gmayor.com
'strFullName is the name with path of the file to check
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(strFullName) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Set FSO = Nothing
    Exit Function
End Function

Private Function BrowseForFolder(Optional strTitle As String) As String
'Graham Mayor - http://www.gmayor.com
'strTitle is the title of the dialog box
Dim fDialog As FileDialog
    On Error GoTo err_handler
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo err_handler:
        BrowseForFolder = fDialog.SelectedItems.Item(1) & Chr(92)
    End With
lbl_Exit:
    Exit Function
err_handler:
    BrowseForFolder = vbNullString
    Resume lbl_Exit
End Function