Sub SaveUnicode()
Dim strName As String
Const strFont As String = "Times New Roman"    'the font to apply
    If Len(ActiveDocument.Path) > 0 Then
        strName = Left(ActiveDocument.FullName, InStrRev(ActiveDocument.FullName, ".") - 1) & ".txt"
    Else
        strName = Options.DefaultFilePath(wdDocumentsPath) & "\MyDocument.txt"
    End If
    ActiveDocument.Range.Font.Name = strFont
    ActiveDocument.SaveAs2 FileName:=strName, FileFormat:=wdFormatUnicodeText
End Sub