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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
| Sub ConcatenerFichiersWrd()
Dim FichierEnCours, FichierCourant, FichierEnCoursComplet
Dim FichierTmpName, NewDocName, FichierGlobal
Dim NewDoc As Boolean
Dim Wrd, WrdOuvre As Object
Dim Msg, Style, Title, Help, Ctxt, Response
Dim DocGlobal As Word.Document
Set Wrd = GetObject(, "word.Application")
' Renvoie le nom de fichier .doc trouvé et si plusieurs fichiers existent dans le repertoire, le premier fichier trouvé est renvoyé.
FichierEnCours = Dir("C:/MonRepTemp/*.doc")
Do While Len(FichierEnCours) > 0
MsgBox FichierEnCours
' ouverture du fichier sans le rendre visible
FichierEnCoursComplet = "C:/MonRepTemp/" & 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
' MsgBox "Mon NewDocName : " & NewDocName
Set DocGlobal = Wrd.Documents.Add(DocumentType:=wdNewBlankDocument)
NewDoc = True ' On ne passe ici qu'une fois
End If
'Retour dans le document à copier
Documents(FichierCourant).Activate
Wrd.ActiveDocument.Select
Wrd.Selection.WholeStory
Wrd.Selection.Copy
'Retour dans le nouveau document
'Documents(NewDocName).Activate
Documents(DocGlobal).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
FichierGlobal = ThisWorkbook.path & "\BordereauJustificatif_" & Format(Date, "yyyy-mm-dd") & ".doc"
Wrd.Application.ActiveDocument.SaveAs FichierGlobal
'on ferme le modele & libere
DocGlobal.Close
Set DocGlobal = Nothing
'Wrd.Application.Quit
Set Wrd = Nothing
MsgBox ("Le bordereau justificatif a été crée")
'Pour vider le presse papier
OpenClipboard 0&
EmptyClipboard
CloseClipboard
Msg = "Souhaitez-vous Ouvrir le fichier bordereau ?" ' Définit le message.
Style = vbYesNo ' Définit les boutons.
Title = "Message Important " ' Définit le titre.
' Affiche le message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' L'utilisateur a choisi Oui.
Set WrdOuvre = GetObject(, "word.Application")
'Rendre Word Visible
WrdOuvre.Visible = True
Documents.Open Filename:=FichierGlobal, ReadOnly:=False
End If
End Sub |
