Автоматизация снятия пароля в Word (массовая операция для множества файлов)

Option Explicit
Dim OldPwd As String, NewPwd As String
 
Sub pass1()
    Dim fd As FileDialog, vrtSelectedItem As Variant, sFolder As String, s As String
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    fd.AllowMultiSelect = False
    
    If fd.Show = -1 Then
        OldPwd = InputBox("Введите Ваш старый пароль:", , "")
        NewPwd = InputBox("Введите Ваш новый пароль:", , "")
        Application.ScreenUpdating = False
        For Each vrtSelectedItem In fd.SelectedItems
            sFolder = vrtSelectedItem
            If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
            Call RecureiveSearch(sFolder)
        Next vrtSelectedItem
        Application.ScreenUpdating = True
    End If
End Sub
 
Private Sub RecureiveSearch(MyPath As String)
    Dim MyName As String, PS As String, DirList() As String
    Dim i As Long, n As Long
    
    PS = Application.PathSeparator
    ReDim DirList(0 To 0) As String
    
    MyName = Dir(MyPath, vbDirectory)
    Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
            n = GetAttr(MyPath & MyName)
            If (n And vbDirectory) = vbDirectory Then
                ReDim Preserve DirList(0 To UBound(DirList) + 1) As String
                DirList(UBound(DirList)) = MyPath & MyName & PS
            Else
                If MyName Like "*.doc" Then
                    Call EnumDocumentsProc(MyPath & MyName)
                End If
            End If
        End If
        MyName = Dir
    Loop
    If UBound(DirList) > 0 Then
        For i = 1 To UBound(DirList)
            RecureiveSearch DirList(i)
        Next i
    End If
End Sub
 
Private Sub EnumDocumentsProc(FullPath As String)
    Dim dct As Document
    
    Set dct = Documents.Open(FileName:=FullPath, PasswordDocument:=OldPwd)
    dct.WritePassword = ""
    dct.Password = NewPwd
    dct.WritePassword = ""
    dct.Save
    dct.Close
    Set dct = Nothing
End Sub