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
|
Private Sub CommandButton1_Click()
Dim WordApp As Object, WordDoc As Object
Dim chemin As FileDialog
Dim Fichier As String, FichierCopie As String, Titre As String, repertoir 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
Set WordApp = CreateObject("word.application")
Titre = "Convocation VM " & TextBox1 & " du " & Format(TextBox2, "dd mm yyyy")
repertoir = Environ("HOMEPATH")
If cfichier.FileExists(repertoir & 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\Décès Collectif\Convocation VM\model\convocvmuniq.doc"
cfichier.CopyFile Fichier, repertoir & Titre & ".doc", True 'False
FichierCopie = repertoir & Titre & ".doc"
Set cfichier = Nothing
If Dir(Fichier) <> "" Then
Set WordDoc = WordApp.Documents.Open(FichierCopie)
For i = 1 To 13
If 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\Décès Collectif\Convocation VM\model\convocvmulti.doc"
cfichier.CopyFile Fichier, "C:\macros\Production\corporate\Décès Collectif\Convocation VM\copies\" & Titre & ".doc", True 'False
'False
FichierCopie = "C:\macros\Production\corporate\Décès Collectif\Convocation VM\copies\" & Titre & ".doc"
Set cfichier = Nothing
If Dir(Fichier) <> "" Then
Set WordDoc = WordApp.Documents.Open(FichierCopie)
For i = 1 To 11
If i = 6 Then
dform = Cells(17, i)
madate = Format(dform, "dd mmmm yyyy")
WordDoc.Bookmarks("Signet" & i).Range.Text = madate
ElseIf i = 8 Then
dform = Cells(17, i)
nombr = Format(dform, "#,0")
WordDoc.Bookmarks("Signet" & i).Range.Text = nombr
Else
WordDoc.Bookmarks("Signet" & i).Range.Text = Cells(17, 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
'Affiche la boite dialogue de sauvegarde avec la pre-saisie de la réf
Set chemin = WordApp.Dialogs(wdDialogFileSaveAs)
With chemin
.Name = Titre & ".doc"
.Show ' On mémorise la réponse de la boite de dialogue
End With
'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 |
Partager