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
|
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 cfichier As New Scripting.FileSystemObject
'Application.DisplayAlerts = False
Lign = 21
While (ActiveSheet.Cells(Lign, 1) <> "")
Lign = Lign + 1
Wend
If Lign = 21 Then
'Adhérent Unique
Fichier = "D:\macros\Production\Bancassaurance1\Model\ModelUnique.doc"
Titre = "BIA Accèpté de " & TextBox1 & " du " & Format(TextBox2, "dd-mm-yyyy")
'MsgBox Titre
If cfichier.FileExists("D:\macros\Production\Bancassaurance1\Copies\" & Titre & ".doc") Then
MsgBox "Ce nom de fichier existe déjà, veuillez essayer un autre nom!"
End
End If
cfichier.CopyFile Fichier, "D:\macros\Production\Bancassaurance1\Copies\" & Titre & ".doc", True 'False
'False
FichierCopie = "D:\macros\Production\Bancassaurance1\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 25
If i = 5 Or i = 14 Then
dform = Cells(6, i)
madate = Format(dform, "dd mmmm yyyy")
WordDoc.Bookmarks("Signet" & i).Range.Text = madate
ElseIf i = 8 Or i = 20 Or i = 21 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 = "D:\macros\Production\Bancassaurance1\Model\ModelMulti.doc"
Titre = "BIA Accèpté de " & TextBox1 & " du " & Format(TextBox2, "dd-mm-yyyy")
'MsgBox Titre
If cfichier.FileExists("D:\macros\Production\Bancassaurance1\Copies\" & Titre & ".doc") Then
MsgBox "Ce nom de fichier existe déjà, veuillez essayer un autre nom!"
End
End If
cfichier.CopyFile Fichier, "D:\macros\Production\Bancassaurance1\Copies\" & Titre & ".doc", True 'False
'False
FichierCopie = "D:\macros\Production\Bancassaurance1\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 18
If i = 5 Or i = 14 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
For Cel = 2 To (NbLign + 1)
WordDoc.tables(1).Rows.Add
WordDoc.tables(1).Columns(1).Cells(Cel).Range.Text = Range("A" & NvLign)
WordDoc.tables(1).Columns(2).Cells(Cel).Range.Text = Range("B" & NvLign)
WordDoc.tables(1).Columns(3).Cells(Cel).Range.Text = Range("C" & NvLign)
WordDoc.tables(1).Columns(4).Cells(Cel).Range.Text = Format(Range("D" & NvLign), "#,0")
WordDoc.tables(1).Columns(5).Cells(Cel).Range.Text = Format(Range("E" & NvLign), "#,0")
NvLign = NvLign + 1
Next Cel
WordDoc.tables(1).Rows(1).shading.backgroundpatterncolor = RGB(160, 160, 160)
Else
MsgBox "Fichier introuvable"
End
End If
Range("A21:E" & (Lign - 1)).ClearContents
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
End Sub |
Partager