Sub SaveAsBM()
    Dim sPath As String: sPath = "C:\server"
    Dim bmName As String: bmName = "CodiPacient"
  
    Dim bm As Bookmark
    Dim bmValue As String
    Dim rng_bm As Range
      
    If ActiveDocument.Bookmarks.Exists(bmName) Then
        Set rng_bm = bm.Range
        If rng_bm.Start = rng_bm.End Then
            rng_bm.MoveEndWhile cset:="0123456789"
            bmValue = rng_bm.Text
        End If
        sPath = (sPath & "\" & bmValue & "\")
        Debug.Print ("Creating folder: " & sPath)
        CreateFolders sPath
        ActiveDocument.SaveAs sPath & "recepte" & Format(Now, "yyyymmdd hhnnss") & ".pdf"
    Else
        Call MsgBox(prompt:=("Unable to find bookmark, " & bmName), buttons:=vbCritical)
    End If
End Sub
Private Function CreateFolders(strPath As String)
Dim strTempPath As String
Dim lng_Path As Long
Dim VPath As Variant
Dim oFSO As Object
Dim i As Integer
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    VPath = Split(strPath, "\")
    If Left(strPath, 2) = "\\" Then
        strPath = "\\" & VPath(2) & "\"
        For lng_Path = 3 To UBound(VPath)
            strPath = strPath & VPath(lng_Path) & "\"
            If Not oFSO.FolderExists(strPath) Then MkDir strPath
        Next lng_Path
    Else
        strPath = VPath(0) & "\"
        For lng_Path = 1 To UBound(VPath)
            strPath = strPath & VPath(lng_Path) & "\"
            If Not oFSO.FolderExists(strPath) Then MkDir strPath
        Next lng_Path
    End If
lbl_Exit:
    Set oFSO = Nothing
    Exit Function
End Function