Macro de recupération de données word
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
Bonsoir,
peut-être le paramètre Readonly peut-il aider ?
Set wrdDoc = wrdApp.Documents.Open(VarDoc,,ReadOnly)bonsoir ami internaute,
je vais tenter cette piste dès demain et vous tiendrai au courant.
En tout cas merci de vous interesser au sujet
annarol