Sub SaveAsPDF()
    Dim sPrinter As String
    Dim strDocName As String
    Dim strPath As String
    Dim intPos As Integer
    'Find position of extension in filename
    strDocName = ActiveDocument.Name
    strPath = ActiveDocument.Path & "\"
    intPos = InStrRev(strDocName, ".")
    strDocName = Left(strDocName, intPos - 1)
    strDocName = strPath & strDocName & ".pdf"
    On Error GoTo lbl_Exit
    sPrinter = Application.ActivePrinter
    ActivePrinter = "Microsoft Print to PDF"
    Application.DisplayAlerts = False
    ActiveDocument.PrintOut _
        OutputFileName:=strDocName, _
        PrintToFile:=True
lbl_Exit:
    Application.DisplayAlerts = True
    Application.ActivePrinter = sPrinter
    Exit Sub
End Sub