Private Sub Image56_Click() ' Valider la saisie pour courrier au départ
Dim X$, s, Y$
Dim u As String
Dim txt As String
Dim traitementTexte As Word.Application
Dim section As Word.section
Dim Word As Word.Application
Dim objet As Variant
Dim STDprinter As String
Dim strName As String
Application.ScreenUpdating = False
Set traitementTexte = New Word.Application
traitementTexte.Visible = True
Dte = CDate(UserForm8.TextBox3.Value)
MyStr = SansAccent(UCase(Format(CDate(Dte), "dddd dd mmmm yyyy")))
Set Ledoc = traitementTexte.Documents.Open(ActiveWorkbook.Path & "/DOC/SYSTEM/TA.doc")
For Each Ma_Forme In Feuil3.Shapes
Feuil3.Select
If Ma_Forme.Name = "Image61" Then
Feuil3.Shapes("Image61").Copy
For Each objet In Ledoc.Shapes
zone = (objet.Name)
Next objet
Ledoc.Shapes(zone).Select
With Ledoc.Shapes(zone)
Ledoc.Shapes(zone).TextFrame.TextRange.Paste
Application.CutCopyMode = False
End With
Exit For
Else
End If
Next Ma_Forme
Ledoc.Content.Find.Execute findtext:="<BALISE1>", ReplaceWith:="" & "" & Feuil3.Range("A1").Value, Replace:=wdReplaceAll
Ledoc.Content.Find.Execute findtext:="<BALISE2>", ReplaceWith:="" & "" & UserForm8.Label35.Caption, Replace:=wdReplaceAll
Ledoc.Content.Find.Execute findtext:="<BALISE3>", ReplaceWith:="" & "" & UserForm8.ComboBox1.Value, Replace:=wdReplaceAll
Ledoc.Content.Find.Execute findtext:="<BALISE4>", ReplaceWith:="" & "" & Feuil3.Range("A6").Value, Replace:=wdReplaceAll
Ledoc.Content.Find.Execute findtext:="<BALISE5>", ReplaceWith:="" & "" & Feuil3.Range("A7").Value, Replace:=wdReplaceAll
Ledoc.Content.Find.Execute findtext:="<BALISE6>", ReplaceWith:="" & "" & Feuil3.Range("A1").Value, Replace:=wdReplaceAll
Ledoc.Content.Find.Execute findtext:="<BALISE7>", ReplaceWith:="" & "" & LCase(MyStr), Replace:=wdReplaceAll
If UserForm8.TextBox7.Enabled = True Then
message = UCase(UserForm8.TextBox7.Value)
Else
message = UCase(UserForm8.ComboBox7.Value)
End If
If UserForm8.TextBox6.Enabled = True Then
message = UserForm8.TextBox6.Enabled
Else
For Ij = 0 To UserForm8.ListBox1.ListCount - 1
mess2 = UserForm8.ListBox1.List(Ij)
Message2 = Message2 & " " & mess2 & vbCrLf
Next
End If
mess = message & vbCrLf & Message2
Ledoc.Content.Find.Execute findtext:="<BALISE8>", ReplaceWith:="" & "" & mess, Replace:=wdReplaceAll
Ledoc.Content.Find.Execute findtext:="<BALISE9>", ReplaceWith:="" & "" & UserForm8.TextBox2.Value, Replace:=wdReplaceAll
Ledoc.Content.Find.Execute findtext:="<BALISE10>", ReplaceWith:="" & "" & UserForm8.TextBox4.Value, Replace:=wdReplaceAll
Ledoc.Content.Find.Execute findtext:="<BALISE11>", ReplaceWith:="" & "" & Feuil3.Range("A2").Value & " " & UCase(Feuil3.Range("C2").Value), Replace:=wdReplaceAll
If UserForm8.TextBox5.Enabled = True Then
sms = UserForm8.TextBox5.Value
Else
For iA = 1 To UserForm8.ListView4.ListItems.Count
liaison1 = UserForm8.ListView4.ListItems(iA).ListSubItems(2)
If iA = 1 Then
sms = sms & "" & liaison1
Else
sms = sms & " - " & liaison1
End If
Next
End If
Ledoc.Content.Find.Execute findtext:="<BALISE12>", ReplaceWith:="" & "" & sms, Replace:=wdReplaceAll
Mod1 = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" & " - " & Feuil3.Range("A5").Value
With Ledoc
.PageSetup.DifferentFirstPageHeaderFooter = True
.Sections(1).Footers(wdHeaderFooterFirstPage) _
.Range.Text = Mod1
End With
With Ledoc.Sections(1).Footers(wdHeaderFooterFirstPage)
.Range.Font.Name = "optimum"
.Range.Font.Size = 5
End With
Ret = imp1
STDprinter = traitementTexte.ActivePrinter
With Dialogs(wdDialogFilePrintSetup)
.Printer = imp1
.DoNotSetAsSysDefault = True
.Execute
End With
Ledoc.PrintOut , Copies:=UserForm8.ComboBox6.Value
With Dialogs(wdDialogFilePrintSetup)
.Printer = STDprinter
.DoNotSetAsSysDefault = True
.Execute
End With
'------------------------------------------------------>
strName = ActiveWorkbook.Path & "/DOC/" & UserForm8.Label35.Caption & " " & "TA.doc"
Ledoc.SaveAs (strName)
Ledoc.Close
SetAttr strName, vbReadOnly
traitementTexte.Quit
Set Ledoc = Nothing
End If