Ligne de Code qui Bug sous Word

[MuscatMimi]

Bonjour a tous

J'ai découvert le site de Ron, presque en même temps
que Staple, m'en ai parlé
Voici un Code de Ron, que j'ai adapté poour Word
Mais ça bug aux lignes notée en couleur

Option Explicit

'--Code de Ron de Bruin
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

'--Code de Ron de Bruin
Sub Zip_ActiveWorkbook()
    Dim DefPath As String '
    'Dim strDate As String
    Dim FileNameZip, FileNameDoc
    Dim oApp As Object
    Dim FileExtStr As String
    Dim Nom As String '*****
    Nom = "Ter12589"
    DefPath = ActiveDocument.path & "\" & Nom ' &  'Nom" '"F:\Mes Documents Cat\Formation logiciels\Classeur en Cours\A\zaza\"    '<< Change
    If Right(DefPath, 1) <> "\" Then
    DefPath = DefPath & "\"
    End If

    '--Create date/time string and the temporary xl* and Zip file name
    If Val(Application.Version) < 12 Then
        FileExtStr = ".doc"
    Else
        Select Case ActiveDocument.FileFormat
        Case 51: FileExtStr = ".doc"
        Case 52: FileExtStr = ".rtf"
        Case 56: FileExtStr = ".txt"
        Case 50: FileExtStr = ".docx"
        Case Else: FileExtStr = "notknown"
        End Select
        If FileExtStr = "bonjour" Then
            MsgBox "Désolé "
            Exit Sub
        End If
    End If

    'strDate = Format(Now, "dd-mm-yyyy-hh-mm-ss")
    
    FileNameZip = DefPath & Left(ActiveDocument.Name, _
    Len(ActiveDocument.Name) - Len(FileExtStr)) & ".zip"
    
    FileNameDoc = DefPath & Left(ActiveDocument.Name, _
    Len(ActiveDocument.Name) - Len(FileExtStr)) & FileExtStr

    If Dir(FileNameZip) = "" And Dir(FileNameDoc) = "" Then

        '--Make copy of the activeworkbook
        ActiveDocument.SaveCopyAs FileNameDoc [COLOR="Red"] '''ça bug a cette Ligne[/COLOR]

        '--Create empty Zip File
        NewZip (FileNameZip)

        'Copy the file in the compressed folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere FileNameDoc

        'Keep script waiting until Compressing is done
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).items.Count = 1
            Application.Wait (Now + TimeValue("0:00:01"))[COLOR="Red"] '''ça bug a cette Ligne[/COLOR]


        Loop
        On Error GoTo 0
        'Delete the temporary xls file
        Kill FileNameDoc

        MsgBox "Classeur Sauvegarder dans: " & FileNameZip

    Else
        MsgBox "Le nom du Dossier Zip Existe ou Le Nom du Fichier .xls Existe"

    End If
End Sub

Quelqu'un aurait'il la solution???

merci a tous de votre aide

Bonne journée

Cordialement