1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73
| Sub MonExemple()
Dim FichierEnCours, FichierCourant, FichierEnCoursComplet
Dim FichierTmpName, NewDocName
Dim NewDoc As Boolean
Dim Wrd As Object
' Renvoie le nom de fichier .doc trouvé et si plusieurs fichiers existent dans le repertoire, le premier fichier trouvé est renvoyé.
FichierEnCours = Dir("c:/essai/*.doc")
Do While Len(FichierEnCours) > 0
MsgBox FichierEnCours
' suppression temporaire de l'update automatique des links (évite l'apparition d'un warning message à chaque ouverture d'un fichier doc)
Options.UpdateLinksAtOpen = False
' ouverture du fichier sans le rendre visible
FichierEnCoursComplet = "c:/essai/" & FichierEnCours
Documents.Open Filename:=FichierEnCoursComplet, Visible:=True, _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto
FichierCourant = ActiveDocument.Name
If Not NewDoc Then 'Je ne crée un nouveau document au modèle que s'il n'existe pas
'Créer et ouvrir un document en utilisant le modèle attaché au document actif
FichierTmpName = ActiveDocument.AttachedTemplate.FullName
Documents.Add Template:=FichierTmpName, NewTemplate:=True
NewDocName = ActiveDocument.Name
NewDoc = True ' On ne passe ici qu'une fois
End If
'Retour dans le document à copier
Documents(FichierCourant).Activate
' CODE NE FONCTIONNE PAS, REMPLACÉ par GetObject *********
'Sélection de tout le document à copier
'Selection.WholeStory
'Copie de toutes les données
'Selection.Copy
'CODE DE REMPLACEMENT
Set Wrd = GetObject(, "word.Application")
Wrd.ActiveDocument.Select
Wrd.Selection.WholeStory
Wrd.Selection.Copy
'Retour dans le nouveau document
Documents(NewDocName).Activate
'Colle toutes les données sauvegardées dans le document compilé
Wrd.Selection.Paste
'Fermeture du document (copié) sans sauvegarde
Documents(FichierCourant).Close (wdDoNotSaveChanges)
'On va en fin du doc créé pour être en position de recevoir la nouvelle copie
Wrd.Selection.EndKey Unit:=wdLine
'Réactivation de l'option update automatique des liens
Options.UpdateLinksAtOpen = True
' Appelle de nouveau Dir sans argument pour renvoyer le fichier *.doc suivant dans le même dossier.
FichierEnCours = Dir
Loop
'Mise à jour général de toutes les données linkées
Documents.Open Filename:=ThisWorkbook.path & "\MonFichierGlobal.doc", ConfirmConversions:=False _
, ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""
ActiveDocument.Content.Select
Wrd.Selection.Fields.Update
End Sub |
Partager