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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
| Sub PayeGM()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim chemin As String
Dim sqlA As String, sqlS As String, sqlB As String, sqlC As String
Dim rsA As DAO.Recordset, rsS As DAO.Recordset, rsB As DAO.Recordset, rsC As DAO.Recordset
Dim db As DAO.Database
Dim dbNumeroRupt As Double ' pour mémoriser le N° adhérent en cours
Dim cptLigneAdr As Long
Set db = CurrentDb
sqlA = "SELECT * FROM R_Publipostage_adherents ORDER BY nom_adhe;"
'sqlA = "SELECT * FROM R_Publipostage_Adherents" & _
'WHERE Nz([addresse2],0)<>0;
'LEFT JOIN R_Publipostage_Indemnisations ON R_Publipostage_Adherents.numero = R_Publipostage_Indemnisations.numero" & _
'WHERE Nz([a_percevoir],0)<>0;"
Set rsA = db.OpenRecordset(sqlA)
Set wApp = New Word.Application
' wApp.Visible = True
chemin = CurrentProject.Path
While Not rsA.EOF
cptLigneAdr = 0
Set wDoc = wApp.Documents.Open(chemin & "\Modèle-Bourse-aux-Circuits.docx")
cptLigneAdr = cptLigneAdr + 1
wDoc.Bookmarks("LigneAdr" & Format(cptLigneAdr, "00")).Range.Text = rsA.Fields("civilite") & " " & UCase(rsA.Fields("nom_adhe")) & " " & rsA.Fields("prenom")
cptLigneAdr = cptLigneAdr + 1
wDoc.Bookmarks("LigneAdr" & Format(cptLigneAdr, "00")).Range.Text = rsA.Fields("adresse")
If rsA.Fields("addresse2") <> " " Then
cptLigneAdr = cptLigneAdr + 1
wDoc.Bookmarks("LigneAdr" & Format(cptLigneAdr, "00")).Range.Text = rsA.Fields("addresse2")
End If
cptLigneAdr = cptLigneAdr + 1
wDoc.Bookmarks("LigneAdr" & Format(cptLigneAdr, "00")).Range.Text = rsA.Fields("CodePostal") & " " & UCase(rsA.Fields("ville"))
sqlB = "SELECT * FROM R_Publipostage_NombrePR_frais_reels WHERE numero=" & rsA.Fields("numero")
Set rsB = db.OpenRecordset(sqlB)
If Not rsB.EOF Then wDoc.Bookmarks("Total").Range.Text = rsB.Fields("Nbr_PR")
If Not rsB.EOF Then wDoc.Bookmarks("Total1").Range.Text = rsB.Fields("Nbr_Pr")
'--- tableau
sqlS = "SELECT * FROM R_Publipostage_Circuits_frais_reels WHERE numero=" & rsA.Fields("numero")
Set rsS = db.OpenRecordset(sqlS)
While Not rsS.EOF
wDoc.Tables(1).Rows.Add
wDoc.Tables(1).Rows.Last.Cells(1).Range.Text = rsS.Fields("secteur_balirando")
wDoc.Tables(1).Rows.Last.Cells(2).Range.Text = UCase(rsS.Fields("code"))
wDoc.Tables(1).Rows.Last.Cells(3).Range.Text = rsS.Fields("nom_pr")
wDoc.Tables(1).Rows.Last.Cells(4).Range.Text = UCase(rsS.Fields("depart"))
wDoc.Tables(1).Rows.Last.Cells(5).Range.Text = rsS.Fields("AR_circuit") & " Kms"
wDoc.Tables(1).Rows.Last.Cells(6).Range.Text = rsS.Fields("balisage")
wDoc.Tables(1).Rows.Last.Cells(7).Range.Text = rsS.Fields("annee_attribution")
If dbNumeroRupt <> rsA.Fields("numero") Then
dbNumeroRupt = rsA.Fields("numero")
sqlC = "SELECT * FROM R_Publipostage_Indemnisations_frais_reels WHERE numero=" & rsA.Fields("numero")
Set rsC = db.OpenRecordset(sqlC)
wDoc.Bookmarks("TotaldistAR").Range.Text = UCase(rsC.Fields("AR_Adhe")) & " Kms"
wDoc.Bookmarks("Retenus").Range.Text = rsC.Fields("Retenus") & " Kms"
wDoc.Bookmarks("Montant").Range.Text = UCase(rsC.Fields("Montant")) & " €"
wDoc.Bookmarks("Cheque").Range.Text = rsC.Fields("A percevoir") & " €"
End If
rsS.MoveNext
Wend
dbNumeroRupt = 0
'sauvegarde du fichier
wDoc.SaveAs CurrentProject.Path & "\Temp" & Format(Date, "yyyy_mm_dd") & "_" & rsA.Fields("nom_adhe") & " " & rsA.Fields("prenom") & ".docx"
wDoc.Close (wdDoNotSaveChanges)
rsA.MoveNext
Wend
rsS.Close: Set rsS = Nothing
rsA.Close: Set rsA = Nothing
db.Close: Set db = Nothing
wApp.Quit
Set wApp = Nothing
Dim wDoc1 As Object
Dim stFicDocs As String
Dim stRepDocs As String
Set wApp = CreateObject("Word.Application")
stRepDocs = (CurrentProject.Path)
'wApp.Visible = True
wApp.Documents.Add
Set wDoc1 = wApp.Documents(1)
' définition des marges, Nombre de points multiplié(x) par 0.0352778, égal(=): Nombre de centimètre
wDoc1.PageSetup.BottomMargin = 39.7 '1.4 cm
wDoc1.PageSetup.LeftMargin = 42.55 '1.5 cm
wDoc1.PageSetup.RightMargin = 42.55 '1.5 cm
wDoc1.PageSetup.TopMargin = 28.35 '1 cm
stRepDocs = CurrentProject.Path
' lecture du répertoire contenant les documents
ChDir stRepDocs
stFicDocs = Dir(stRepDocs & "\Temp" & Format(Date, "yyyy_mm_dd") & "*.docx")
While stFicDocs <> ""
With wApp.Selection
.InsertFile FileName:=stRepDocs & "\" & stFicDocs, ConfirmConversions:=False
.InsertBreak Type:=wdSectionBreakNextPage
.Collapse Direction:=wdCollapseEnd
End With
stFicDocs = Dir()
Wend
'changer le format intervalle des paragraphes du document
wApp.Selection.WholeStory
With wApp.Selection.ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.LineUnitAfter = 0
End With
' sauvegarde du fichier définitif et quitte Word
wDoc1.SaveAs stRepDocs & "\Publipostage\Lettre Publipostage Bourse Circuits" & ".docx"
wDoc1.Close (wdSaveChanges)
wApp.Quit
' destruction des fichiers temporaires
Dim oFso As Object
Set oFso = CreateObject("Scripting.FileSystemObject")
oFso.deletefile stRepDocs & "\Temp" & Format(Date, "yyyy_mm_dd") & "*.docx"
Set oFso = Nothing
' Ouverture du fichier word après fusion
Dim wdapp As Word.Application
' Démarrer Word
Set wdapp = CreateObject("Word.application")
With wdapp
.Visible = True
' Ouvrir le document
.Documents.Open stRepDocs & "\Publipostage\Lettre Publipostage Bourse Circuits" & ".docx"
' Diriger le publipostage vers un nouveau document
'.ActiveDocument.MailMerge.Execute
End With
' Fermer et libérer les objets
Set wdapp = Nothing
End Sub |
Publipostage à l'aide de Recordsets et de signets
Répondre avec citation
Partager