Sub SaveAs()
'
' SaveAs Macro
'
'

Dim sName As String, aCC As ContentControl, iSpacePos As Integer
Dim sFilename As String, sNow As String, sPath As String
Dim i As Integer
    sPath = Environ("USERPROFILE") & Chr(92) & "Desktop\"
    For Each aCC In ActiveDocument.ContentControls
        If aCC.Title = "Subject" Then
            i = i + 1
            Exit For
        End If
    Next aCC
    If i = 0 Then
        MsgBox "The 'Subject' Content Control is missing", vbCritical
        Exit Sub
    End If
    For Each aCC In ActiveDocument.ContentControls
        If aCC.Title = "Subject" Then
            If aCC.ShowingPlaceholderText = True Then
                MsgBox "Complete the 'Subject' field!", vbCritical
                aCC.Range.Select
                Exit Sub
            End If
            sName = Trim(aCC.Range.Text)
        End If
        iSpacePos = InStr(sName, " ")
        If iSpacePos > 0 Then
            sName = Mid(sName, iSpacePos) & "," & Left(sName, iSpacePos)
            sName = Replace(sName, " ", "")
        End If
        sNow = Format(Now, "dd-mm-yy_HHMMSS")
        sFilename = sName & "_" & sNow & ".docm"

        ActiveDocument.SaveAs2 FileName:=sPath & sFilename, FileFormat:=wdFormatXMLDocumentMacroEnabled
    Next aCC
    Set aCC = Nothing
End Sub