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
| Private Sub CommandButton1_Click()
Dim WordApp As Object, WordDoc As Object
Const wdDialogFileSaveAs = 84
Dim Fichier 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
Application.DisplayAlerts = False
Lign = 21
While (ActiveSheet.Cells(Lign, 1) <> "")
Lign = Lign + 1
Wend
Titre = "Transmission Réclam KX " & TextBox1 & " du " & Format(TextBox2, "dd mm yyyy")
repertoir = Environ("HOMEPATH") & "\"
If Lign = 21 Then
'Adhérent Unique
Fichier = "C:\macros\Production\corporate\Décès Collectif\Transmission Réclam KX\model\transrclkxuniq.doc"
If Dir(Fichier) <> "" Then
Set WordApp = CreateObject("word.application")
Set WordDoc = WordApp.Documents.Open(Fichier)
For i = 1 To 14
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\Transmission Réclam KX\model\transrclkxmulti.doc"
If Dir(Fichier) <> "" Then
Set WordApp = CreateObject("word.application") 'ouvre une session Word
Set WordDoc = WordApp.Documents.Open(Fichier)
For i = 1 To 12
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
With WordApp.Dialogs(wdDialogFileSaveAs)
.Name = repertoir & Titre & ".doc"
.Show
End With
WordApp.Visible = True 'affiche le document Word
Unload Me
End Sub |
Partager