XL 2019 Probleme codage

[Kevin42560]

Bonsoir la communaute voici mon problème
quand j'utilise ce code tout fonctionne mais ma signature outlook ne s'affiche pas

par contre quand je rajoute .Display apres with OuT mail
ma signature s'affiche mais je ne plus utiliser mes boutons pour rajouter du texte a mon corps de mail

merci de vos réponses

Dim EmailBody As String ' Variable globale pour stocker le corps de l'e-mail

Sub OuvrirOutlook()
    ' Créer une nouvelle instance d'Outlook
    Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")

    ' Créer un nouvel e-mail
    Dim OutMail As Object
    Set OutMail = OutApp.CreateItem(0) ' 0 = E-mail

    ' Remplir les destinataires
    With OutMail
        .To = Range("A2")
        .Subject = Range("B2")
        
        ' Ajoutez le corps de l'e-mail ici
        .HTMLBody = "Bonjour, veuillez trouver ci-joint la proposition pour votre entreprise." & " " & .HTMLBody
        .Display
    End With
End Sub


Sub AjouterLigne1()
    If Not IsObject(CreateObject("Outlook.Application")) Then
        MsgBox "Ouvrez d'abord Outlook en appuyant sur le bouton 'Ouvrir Outlook'.", vbExclamation
        Exit Sub
    End If
    AjouterLigne "Feuil2", "A1"
End Sub

Sub AjouterLigne2()
    If Not IsObject(CreateObject("Outlook.Application")) Then
        MsgBox "Ouvrez d'abord Outlook en appuyant sur le bouton 'Ouvrir Outlook'.", vbExclamation
        Exit Sub
    End If
    AjouterLigne "Feuil2", "A2"
End Sub

Sub AjouterLigne3()
    If Not IsObject(CreateObject("Outlook.Application")) Then
        MsgBox "Ouvrez d'abord Outlook en appuyant sur le bouton 'Ouvrir Outlook'.", vbExclamation
        Exit Sub
    End If
    AjouterLigne "Feuil2", "A3"
End Sub
Sub AjouterLigne(nomFeuille As String, nomCellule As String)
    If Not IsObject(CreateObject("Outlook.Application")) Then
        MsgBox "Ouvrez d'abord Outlook en appuyant sur le bouton 'Ouvrir Outlook'.", vbExclamation
        Exit Sub
    End If

    ' Vérifie si Outlook est ouvert
    On Error Resume Next
    Dim OutApp As Object
    Set OutApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    ' Si Outlook est ouvert, ajoutez le texte de la cellule spécifiée au corps de l'e-mail en cours
    If Not OutApp Is Nothing Then
        Dim OutMail As Object
        Set OutMail = OutApp.ActiveInspector.CurrentItem
        Dim ws As Worksheet
        Set ws = ThisWorkbook.Sheets(nomFeuille)
        Dim texte As String
        texte = ws.Range(nomCellule).Value
        Dim htmlText As String
        Dim index As Integer
        Dim inBold As Boolean
        Dim inUnderline As Boolean

        inBold = False
        inUnderline = False
        htmlText = ""

        For index = 1 To Len(texte)
            Dim currentChar As String
            currentChar = Mid(texte, index, 1)

            If currentChar = "*" Then
                inBold = Not inBold
                If inBold Then
                    htmlText = htmlText & "<b>"
                Else
                    htmlText = htmlText & "</b>"
                End If
            ElseIf currentChar = "_" Then
                inUnderline = Not inUnderline
                If inUnderline Then
                    htmlText = htmlText & "<u>"
                Else
                    htmlText = htmlText & "</u>"
                End If
            ElseIf currentChar = vbLf Then
                ' Pour gérer les sauts de ligne dans Excel (utilisez Chr(10) si nécessaire)
                htmlText = htmlText & "<br>"
            Else
                htmlText = htmlText & currentChar
            End If
        Next index

        OutMail.HTMLBody = OutMail.HTMLBody & "<br>" & htmlText
    Else
        MsgBox "Vous devez d'abord ouvrir Outlook en appuyant sur le bouton 'Ouvrir Outlook'.", vbExclamation
    End If
End Sub

Private Sub CommandButton1_Click()
    If Not IsObject(CreateObject("Outlook.Application")) Then
        MsgBox "Ouvrez d'abord Outlook en appuyant sur le bouton 'Ouvrir Outlook'.", vbExclamation
        Exit Sub
    End If
    AjouterLigne "Feuil2", "A4"
End Sub

 

[fanch55]

Salut,
Pour obtenir la signature par défaut, il faut d'abord faire un display du message .
Ci-dessous une proposition pour intégrer la signature et simplifier le codage:
( passer par le SendMail pour envoyer effectivement le message, la signature sera insérée à ce moment là )

Dim Signature   As String
Dim OutMail     As Object
Sub OuvrirOutlook()
    ' Créer une nouvelle instance d'Outlook
    Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")

    ' Créer un nouvel e-mail
    Set OutMail = OutApp.CreateItem(0) ' 0 = E-mail

    ' Remplir les destinataires
    Signature = "Moi Gmail" ' <-- laisser à vide pour la sinature par défaut
    With OutMail
        .To = Range("A2")
        .Subject = Range("B2")
        .display
         Signature = GetSig(Signature)
         If Signature = "" Then Signature = .htmlbody
        .htmlbody = "Bonjour,<br>" & _
                    "Veuillez trouver ci-joint la proposition pour votre entreprise."
    End With
End Sub
Sub SendMail()
    If Not OutMail Is Nothing Then
        With OutMail
            .htmlbody = .htmlbody & _
                       "<p>Bien cordialement,</p>" & _
                        Signature
            .send
        End With
    End If
End Sub
Function GetSig(ByVal Signature As String) As String
Dim Fso As Object, File As String
    If Signature <> "" Then
        Set Fso = CreateObject("Scripting.FileSystemObject")
        File = Environ("appdata") & "\Microsoft\Signatures\" & Signature & ".htm"
        If Fso.FileExists(File) Then
            With Fso.GetFile(File).OpenAsTextStream(1, -2)
                GetSig = .ReadAll
                .Close
            End With
        End If
        Set Fso = Nothing
    End If
End Function
Sub AjouterLigne1()
    AjouterLigne "Feuil2", "A1"
End Sub

Sub AjouterLigne2()
    AjouterLigne "Feuil2", "A2"
End Sub

Sub AjouterLigne3()
    AjouterLigne "Feuil2", "A3"
End Sub
Sub AjouterLigne(nomFeuille As String, nomCellule As String)
    If OutMail Is Nothing Then OuvrirOutlook
        
        Dim ws As Worksheet
        Set ws = ThisWorkbook.Sheets(nomFeuille)
        Dim texte As String
        texte = ws.Range(nomCellule).Value
        Dim htmlText As String
        Dim index As Integer
        Dim inBold As Boolean
        Dim inUnderline As Boolean

        inBold = False
        inUnderline = False
        htmlText = ""

        For index = 1 To Len(texte)
            Dim currentChar As String
            currentChar = Mid(texte, index, 1)

            If currentChar = "*" Then
                inBold = Not inBold
                If inBold Then
                    htmlText = htmlText & "<b>"
                Else
                    htmlText = htmlText & "</b>"
                End If
            ElseIf currentChar = "_" Then
                inUnderline = Not inUnderline
                If inUnderline Then
                    htmlText = htmlText & "<u>"
                Else
                    htmlText = htmlText & "</u>"
                End If
            ElseIf currentChar = vbLf Then
                ' Pour gérer les sauts de ligne dans Excel (utilisez Chr(10) si nécessaire)
                htmlText = htmlText & "<br>"
            Else
                htmlText = htmlText & currentChar
            End If
        Next index

        OutMail.htmlbody = OutMail.htmlbody & "<br>" & htmlText
        OutMail.display
End Sub

Private Sub CommandButton1_Click()
    AjouterLigne "Feuil2", "A4"
End Sub

 

[Kevin42560]

merci beaucoup de votre réponse
effectivement en passant par le send mail la signature apparait