ub Decoupage(format As String, SendMail As Boolean)
 
' Désactiver le rafraîchissement d'écran
Application.ScreenUpdating = False
MonApplication.ScreenUpdating = False
MonApplication.Visible = False
 
' Déclaration des variables
Dim iR As Long
Dim i As Long
Dim oDoc As Document
Dim xx As Document
Dim DocName As String
Dim RepName As String
Dim rep As String
Dim oDS As MailMergeDataSource
Dim destin As String
 
Dim appword As Object, lesdocuments As Object, ledoc As Object
 
' <<< AJOUT : Récupération de l’étiquette du document source >>>
Dim srcLabel As Object
'Set srcLabel = ThisDocument.SensitivityLabel
' <<< FIN AJOUT >>>
 
Set oDoc = DocWord
Set oDS = oDoc.MailMerge.DataSource
Set srcLabel = oDoc.SensitivityLabel  ' héritage automatique
 
iR = oDoc.MailMerge.DataSource.RecordCount
 
For i = PremPage To DerPage
    With oDoc.MailMerge
        .DataSource.FirstRecord = i
        .DataSource.LastRecord = i
        .Destination = wdSendToNewDocument
        .Execute
        .DataSource.ActiveRecord = i
 
        If NumColRep > 0 Then
            RepName = .DataSource.DataFields(NumColRep).Value
        Else
            RepName = ""
        End If
 
        DocName = .DataSource.DataFields(NumColFic).Value
        If SendMail Then destin = .DataSource.DataFields(NumColMail).Value
    End With
 
    If Len(RepName) > 0 Then
        If Right(RepName, 1) <> "\" Then RepName = RepName & "\"
        fic = Racine & RepName & DocName
        rep = Racine & RepName
    Else
        fic = Racine & DocName
        rep = Racine
    End If
 
    Set lesdocuments = MonApplication.Documents
 
    If CreerDossier(rep) Then
        If format = "PDF" Then
 
            fic = fic & ".pdf"
            With lesdocuments.Item(1)
                .ExportAsFixedFormat _
                    OutputFileName:=fic, _
                    ExportFormat:=wdExportFormatPDF, _
                    OpenAfterExport:=False, _
                    OptimizeFor:=wdExportOptimizeForPrint, _
                    Range:=wdExportAllDocument
                .Close SaveChanges:=wdDoNotSaveChanges
            End With
 
 
ElseIf format = "DOC" Then
 
    fic = fic & ".docx"
 
    Dim newDoc As Document
    Set newDoc = Application.ActiveDocument
 
    With newDoc
 
        ' --- Application correcte et stable de l’étiquette de sensibilité ---
        On Error Resume Next   ' au cas où MIP n’est pas chargé
        .SetLabel LabelId:=srcLabel.LabelId, _
                  Justification:="Héritage automatique"
        On Error GoTo 0
        ' -------------------------------------------------------------------
 
        .SaveAs fic
        .Close SaveChanges:=wdDoNotSaveChanges
    End With
 
End If
 
 
        If SendMail Then
            If AdresseEmailValide(destin) Then
                Call EnvoyerEmail(MailObject, destin, MailBody, fic)
            Else
                MsgBox "Adresse mail incorrecte : " & destin
            End If
        End If
 
    Else
        MsgBox "Impossible de créer le dossier : " & Racine & RepName
    End If
 
Next i
 
Fin:
Application.ScreenUpdating = True
MonApplication.ScreenUpdating = True
MonApplication.Visible = True
 
End Sub

 Sub AfficherPanneau()
    CommandBars.ExecuteMso ("StylesPane")
End Sub

 
Sub remplircellule(Cellule As Cell, resultat As Single)
 
    Dim arrondi As Single
    Dim note As Selection
    arrondi = Round(resultat, 1)
    Cellule.Range.Text = arrondi & " %"
 
    Select Case arrondi
        Case Is < 50
        Set note = Cellule.Range.MoveEnd(wdCharacter, -2)
        note.Font.Color = wdColorRed
        Case Is >= 51
 
 
        Case 50 To 50, 9
 
        note = Cellule.Range.MoveEnd(wdCharacter, -2)
        note.Font.Underline = wdUnderlineSingle
        note.Font.UnderlineColor = wdColorRed
 
 
    End Select
 
End Sub

 
  Dim Data As New DataObject
  Data.GetFromClipboard
  Resultat = Data.GetText(1)
  Set Data = Nothing