Bonjour à tous,
Je me permets de vous solliciter car je suis bloqué avec une macro.
Dans la macro « mail » présent dans le module 4 du fichier ci-joint, je souhaiterais intégrer l’ajout de ma signature aux mails généré par excel mais je bloque complètement.
Voici les quelques points utiles à mentionner :
- Ma signature a une mise en forme particulière (couleur particulière, police etc) et je souhaite impérativement la conserver
- Ma signature comporte une image
Dans la macro ci-dessous, est-il possible de demander à excel d’insérer ma signature comme elle se présente dans outlook ?
Si non, est-il possible que je reproduisse ma signature dans excel et qu’elle soit insérée dans le mail généré par la macro ? (texte sous forme de texte comme je l’aurai mis en forme + image)
Sub EnregistrerPDF()
On Error Resume Next
chemin = Sheets("Adresse+Chemin pour OM").Columns("A:A").Find(What:=Range("Q22"), After:=Sheets("Adresse+Chemin pour OM").Range("A1"), LookIn:=xlValues, LookAt:=xlWhole).Offset(0, 2).Value
If chemin = "" Then
MsgBox ("le code " & Range("Q22") & " est inexistant onglet Adresse+Chemin pour OM colonne A !!!")
Exit Sub
End If
lignesousdossier = 0
lignesousdossier = Sheets("Contact prestataires").Columns("A:A").Find(What:=Range("Q22"), After:=Sheets("Contact prestataires").Range("A1"), LookIn:=xlValues, LookAt:=xlWhole).Row
If lignesousdossier = 0 Then
MsgBox ("le code " & Range("Q22") & " est inexistant onglet Contact prestataires colonne A !!!")
Exit Sub
End If
If Sheets("Contact prestataires").Range("G" & lignesousdossier).Value = Range("Q13").Value Then
sousdossier = Sheets("Contact prestataires").Range("C" & lignesousdossier).Value
adrmail = Sheets("Contact prestataires").Range("I" & lignesousdossier).Value
Else
Do While lignesousdossier < Sheets("Contact prestataires").Range("G" & Rows.Count).End(xlUp).Row + 1
If Sheets("Contact prestataires").Range("G" & lignesousdossier).Value = Range("Q13").Value And Sheets("Contact prestataires").Range("A" & lignesousdossier).Value = Range("Q22").Value Then
sousdossier = Sheets("Contact prestataires").Range("C" & lignesousdossier).Value
adrmail = Sheets("Contact prestataires").Range("I" & lignesousdossier).Value
Exit Do
End If
lignesousdossier = lignesousdossier + 1
Loop
End If
If sousdossier = "" Then
MsgBox ("Attention aucun sous dossier correspondant au code site " & Range("Q22") & " pour l'entreprise " & Range("Q13") & " onglet Contact prestataires colonne A avec colonne G !!!")
Exit Sub
End If
If Dir(chemin & "\" & sousdossier, vbDirectory) = "" Then
MkDir chemin & "\" & sousdossier
End If
If Range("BB21") = 1 Then
typeordre = "D"
Else
typeordre = "T"
End If
jour = Replace(Format(Date, "YYYYMMDD"), "/", "")
nomfichier = "Ordre de mission " & Range("Q13") & " " & jour & "_" & typeordre & Range("Q22")
Fichier = Dir(chemin & "\" & sousdossier & "\**", vbDirectory)
Do While Fichier <> ""
If Fichier = nomfichier & ".pdf" Then
If MsgBox("Attention le fichier " & nomfichier & " est déjà présent dans le sous dossier " & sousdossier & " voulez vous le remplacer ???", vbYesNo) = vbNo Then
nomfichier = nomfichier & "-2"
End If
Exit Do
End If
Fichier = Dir
Loop
ActiveSheet.Columns("A:AS").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
chemin & "\" & sousdossier & "\" & nomfichier, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Range("AY23") = ""
Range("AY25") = ""
Range("AY23") = chemin & "\" & sousdossier & "\" & nomfichier & ".pdf"
Range("AY25") = adrmail
End Sub
Sub mail()
Dim ol As New Outlook.Application
Dim olmail As MailItem
Dim CurrFile As String
Set ol = New Outlook.Application
Set olmail = ol.CreateItem(olMailItem)
If Range("BB21") = 1 Then
typeordre = "D"
Else
typeordre = "T"
End If
If typeordre = "D" Then
If Range("AY25") = "" Or Range("AY23") = "" Then
MsgBox ("Attention une ou plusieurs données manquantes en cellules AY25/AY23 !!!")
Exit Sub
End If
Else
If Range("AY25") = "" Or Range("AY23") = "" Then
MsgBox ("Attention une ou plusieurs données manquantes en cellules AY25/AY23 !!!")
Exit Sub
End If
End If
Copie = ""
If typeordre = "D" Then
Destinataire = Range("AY25")
Copie = Range("BA35")
Sujet = Range("AX34")
Contenu = Range("AW36")
Else
Destinataire = Range("AY25")
Copie = Range("BA43")
Sujet = Range("AX42")
Contenu = Range("AW44")
End If
fichierpdf = Range("AY23")
With olmail
.To = Destinataire
If Copie <> "" Then
.CC = Copie
End If
.Subject = Sujet 'le sujet
.Body = Contenu 'le contenu
.Attachments.Add fichierpdf 'si piéce jointe
.Display
'On peut switcher entre .send et .display selon que l'on veut envoyer le mail (send) ou seulement le préparer et le vérifier(display)
End With
'ol.Quit 'si l'on veut fermer l'application Outlook
End Sub
J’espère que je suis clair dans ma demande et que vous aurez une solution pour moi !
Merci à vous tous par avance !
Exemple 1 EMAIL.xlsm (1,3 Mo)
