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
|
Private Sub CommandButton1_Click()
Dim WordApp As Object, WordDoc As Object
Dim Fichier As String, FichierCopie As String, Titre As String
Dim i As Byte, Lign As Byte, NbLign As Byte, Cel As Byte, NvLign As Byte
Dim nbpage As Byte, cptpage As Byte
Dim cfichier As New Scripting.FileSystemObject
Application.DisplayAlerts = False
Lign = 21
While (ActiveSheet.Cells(Lign, 1) <> "")
Lign = Lign + 1
Wend
Titre = "Transmission Avt N° " & TextBox1 & " du " & Format(TextBox2, "dd mm yyyy")
If cfichier.FileExists("C:\macros\Production\corporate\word\transmisBiaAcp\copies\" & Titre & ".doc") Then
MsgBox "Ce nom de fichier existe déjà, veuillez essayer un autre nom!"
End
End If
If Lign = 21 Then
'Adhérent Unique
Fichier = "C:\macros\Production\corporate\word\transmisBiaAcp\model\transbiaaptuniq.doc"
cfichier.CopyFile Fichier, "C:\macros\Production\corporate\word\transmisBiaAcp\copies\" & Titre & ".doc", True 'False
'False
FichierCopie = "C:\macros\Production\corporate\word\transmisBiaAcp\copies\" & Titre & ".doc"
Set cfichier = Nothing
If Dir(Fichier) <> "" Then
Set WordApp = CreateObject("word.application")
Set WordDoc = WordApp.Documents.Open(FichierCopie)
For i = 1 To 17
If i = 2 Then
If Cells(6, i) = 0 Then
WordDoc.Bookmarks("Signet" & i).Range.Text = ""
End If
ElseIf i = 6 Then
dform = Cells(6, i)
madate = Format(dform, "dd mmmm yyyy")
WordDoc.Bookmarks("Signet" & i).Range.Text = madate
ElseIf i = 8 Then
dform = Cells(6, i)
nombr = Format(dform, "#,0")
WordDoc.Bookmarks("Signet" & i).Range.Text = nombr
Else
WordDoc.Bookmarks("Signet" & i).Range.Text = Cells(6, i)
End If
Next i
Else
MsgBox "Fichier introuvable"
End
End If
ElseIf Lign > 21 Then
'Adhérents Multiples
Fichier = "C:\macros\Production\corporate\word\transmisBiaAcp\model\transbiaaptmulti.doc"
cfichier.CopyFile Fichier, "C:\macros\Production\corporate\word\transmisBiaAcp\copies\" & Titre & ".doc", True 'False
'False
FichierCopie = "C:\macros\Production\corporate\word\transmisBiaAcp\copies\" & Titre & ".doc"
Set cfichier = Nothing
If Dir(Fichier) <> "" Then
Set WordApp = CreateObject("word.application") 'ouvre une session Word
Set WordDoc = WordApp.Documents.Open(FichierCopie)
For i = 1 To 15
If i = 2 Then
If Cells(6, i) = 0 Then
WordDoc.Bookmarks("Signet" & i).Range.Text = ""
End If
ElseIf i = 6 Then
dform = Cells(6, i)
madate = Format(dform, "dd mmmm yyyy")
WordDoc.Bookmarks("Signet" & i).Range.Text = madate
ElseIf i = 8 Then
dform = Cells(6, i)
nombr = Format(dform, "#,0")
WordDoc.Bookmarks("Signet" & i).Range.Text = nombr
Else
WordDoc.Bookmarks("Signet" & i).Range.Text = Cells(6, i)
End If
Next i
'Gestion du tableau
NbLign = Lign - 21
NvLign = 21
y = 1
For Cel = 2 To (NbLign + 1)
WordDoc.Tables(1).Rows.Add
WordDoc.Tables(1).Columns(1).Cells(Cel).Range.Text = y
WordDoc.Tables(1).Columns(2).Cells(Cel).Range.Text = Range("A" & NvLign)
NvLign = NvLign + 1
y = y + 1
Next Cel
WordDoc.Tables(1).Rows(1).shading.backgroundpatterncolor = RGB(160, 160, 160)
WordDoc.Tables(1).Columns(1).shading.backgroundpatterncolor = RGB(160, 160, 160)
WordDoc.Tables(1).Rows(1).HeadingFormat = True
'Vide la liste des adhérents
Range("A21:A" & (Lign - 1)).ClearContents
Else
MsgBox "Fichier introuvable"
End
End If
End If
WordDoc.Save
WordApp.Visible = True 'affiche le document Word
'WordDoc.PrintOut 'Pour imprimer le doc obtenu
'WordDoc.Close True 'ferme le document word en sauvegardant les données
'WordApp.Quit 'ferme la session Word
Unload Me
MsgBox ("Courrier générer avec succès !")
End Sub
Private Sub TextBox1_Change()
TextBox2.Value = Date
End Sub |
