Option Explicit

Sub SaveAsDocX_PDF()
Dim strName As String
Dim strPDF As String
Dim strPath As String
ActiveDocument.Save
If Not ActiveDocument.Path = "" Then
    strName = ActiveDocument.Name
    strPath = ActiveDocument.Path
    strPDF = Format(Date, "yyyymmdd_") & Left(strName, InStrRev(strName, Chr(46)) - 1)
    strPDF = PDFNameUnique(strPath, strPDF)
    ActiveDocument.SaveAs FileName:=strPath & "\" & strPDF, _
                          FileFormat:=wdFormatPDF
Else
    MsgBox "Document not saved!"
End If
End Sub

Private Function PDFNameUnique(strPath As String, _
                               strFilename As String) As String
'Graham Mayor - http://www.gmayor.com - Last updated - 03 Nov 2017
Dim lngF As Long: lngF = 1
Dim lngName As Long: lngName = Len(strFilename)
Dim strExtension As String
    Do Until Right(strPath, 1) = Chr(92)
        strPath = strPath & Chr(92)
    Loop
    strExtension = ".pdf"
    strFilename = Left(strFilename, lngName)
    Do While FileExists(strPath & strFilename & strExtension) = True
        strFilename = Left(strFilename, lngName) & Format(lngF, "00")
        lngF = lngF + 1
    Loop
    PDFNameUnique = strFilename & strExtension
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(strFullName As String) As Boolean
'Graham Mayor
'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