Option Explicit

Sub ЦЭ()

Dim Имя_файла_без_расширения As String
Имя_файла_без_расширения = CreateObject("Scripting.FileSystemObject").GetBaseName(ActiveDocument.Name)
'отбрасывает дату файла, она находится в 11 последних буквах имени файла
Dim Имя_файла_без_расширения_без_последних_11_букв As String
Имя_файла_без_расширения_без_последних_11_букв = Left$(Имя_файла_без_расширения, (Len(Имя_файла_без_расширения) - 11))

    ChangeFileOpenDirectory ActiveDocument.Path
    ActiveDocument.SaveAs FileName:=Имя_файла_без_расширения_без_последних_11_букв & ".html", FileFormat:=wdFormatHTML, _
    LockComments:=False, _
    Password:="", AddToRecentFiles:=True, _
    WritePassword:="", ReadOnlyRecommended:=False, _
    EmbedTrueTypeFonts:=False, _
    SaveNativePictureFormat:=False, _
    SaveFormsData:=False, _
    SaveAsAOCELetter:=False
    
    MsgBox$ "End"
    
End Sub