Récupération de champs d'un formulaire avec macro excel

bonjour,

j'ai créer une fiche de renseignements avec word (sous forme de formulaire) que des étudiants doivent remplir. Les champs renseignés sont récupérer grâce à une macro dans un fichier excel.
ma macro fonctionne bien avec excel 2003 mais ne fonctionne plus avec excel 2010.
J'ai un message qui m'indique que le fichier word est vérouillé pour modification (ce qui est normal pour les formulaire).

J'avoue que je ne trouve pas de solutions, si un aimable internaute peut jeter un coup d'oeil et m'aider a contourner ce probleme.

ci après le code vba

Dim NumCol As Integer
Sub Recup_Infos_Etudiant()

'
' Recup_Infos_Etudiant Macro
' Macro enregistrée le 05/07/2012 par MP Infal
' Charge la feuille "BD" à partir des champs de tous les documents ".doc" se
' trouvant dans le même répertoire que le document Excel

On Error GoTo Trt_Err

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim abookmark As Bookmark
Dim NomRep As String, VarFic As String
Dim ChListe As FormField
Dim CtrCol As Integer

NomRep = ThisWorkbook.Path
Application.Cursor = xlWait
VarFic = Dir(NomRep & "\*.doc")
Set wrdApp = CreateObject("Word.Application")
CtrFic = 0
'msgbox ("Lancement winword==")
Do While Len(VarFic) > 0
'msgbox ("fic : " & VarFic & "==")
wrdApp.Visible = False
VarDoc = NomRep & "\" & VarFic
CtrFic = CtrFic + 1
Set wrdDoc = wrdApp.Documents.Open(VarDoc)
i = 1
Worksheets("BD").Cells(CtrFic + 1, 1).Value = VarFic

If ActiveDocument.FormFields.Count >= 1 Then
For Each ChListe In ActiveDocument.FormFields
appel = Boucle_Nom_Champs(ActiveDocument.FormFields(i).Name)
Worksheets("BD").Cells(1, NumCol).Value = ActiveDocument.FormFields(i).Name
Worksheets("BD").Cells(CtrFic + 1, NumCol).Value = ActiveDocument.FormFields(i).Result
i = i + 1
Next ChListe
End If
ActiveDocument.Close
VarFic = Dir()
Loop
Application.Cursor = xlDefault
wrdApp.Quit
'Affichage du message de fin correcte

msg = "Chargement terminé correctement" ' Définit le message.
Style = vbYesOnly ' Définit les boutons.
Titre = "BD_Prepa " ' Définit le titre.
Reponse = msgbox(msg, Style, Titre)
Exit Sub

Trt_Err: ' Routine de gestion d'erreur.

Application.Cursor = xlDefault
If Err.Number = 462 Then
wrdApp.Quit
End If
'Affichage du message de fin incorrecte

msg = "Erreur - l'application Excel va quitter, vous devez relancer votre classeur Excel" ' Définit le message.
Style = vbYesOnly ' Définit les boutons.
Titre = "BD_Prepa " ' Définit le titre.
Style = vbYesOnly + vbCritical + vbDefaultButton2 ' Définit les boutons.
Title = "BD_Prepa : Erreur - Fin prématurée du programme " ' Définit le titre.
Reponse = msgbox(msg, Style, Titre)
Application.Quit
ThisWorkbook.Close SaveChanges:=False

End Sub
Function Boucle_Nom_Champs(NomChamp)

Dim NomRep As String, VarFic As String

For i = 2 To 110
If Worksheets("Nom_Signet").Cells(i, 1).Value = NomChamp Then
NumCol = i
Exit Function
End If
Next


End Function
Sub test()

' Macro1 Macro
' Macro enregistrée le 05/07/2012 par MP Infal
' Boucle sur les signets


Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim abookmark As Bookmark
Dim NomRep As String, VarFic As String
Dim ChListe As FormField
Dim CtrCol As Integer

NomRep = ThisWorkbook.Path

VarFic = Dir(NomRep & "\*.doc")
Set wrdApp = CreateObject("Word.Application")
CtrFic = 0
Do While Len(VarFic) > 0
wrdApp.Visible = False
VarDoc = NomRep & "\" & VarFic
CtrFic = CtrFic + 1
Set wrdDoc = wrdApp.Documents.Open(VarDoc)
i = 1
Worksheets("BD").Cells(CtrFic + 1, 1).Value = VarFic

If ActiveDocument.Bookmarks.Count >= 1 Then
ReDim aMarks(ActiveDocument.Bookmarks.Count - 1)
i = 0
Worksheets("BD").Cells(CtrFic + 1, 1).Value = VarFic
For Each abookmark In ActiveDocument.Content.Bookmarks
CtrCol = i + 1
Worksheets("BD").Cells(1, CtrCol + 1).Value = abookmark.Name
Worksheets("BD").Cells(CtrFic + 1, CtrCol + 1).Value = abookmark.Range.Text
If abookmark.Name = "Texte16" Or abookmark.Name = "Texte22" Then
Debug.Print ("Fichier : " & VarFic & "numéro " & i & "nom : " & abookmark.Name & " = " & abookmark.Range.Text & " ==")
End If
i = i + 1
Next abookmark
' Debug.Print ("nb bookmars " & i & "==")
End If
ActiveDocument.Close
VarFic = Dir()
Loop
wrdApp.Quit

End Sub

MERCI BEAUCOUP

ANNAROL