Format adresse mail depuis une formule avec macro VBA pour envoi par mail

[Binif]

Bonjour,

Sur Excel 2007, classeur avec macro pour envois par mail.

Voilà j'ai un petit problème, je suis en train de créer un fichier excel qui sera en liaison avec un dessin Autocad.
Je récupère les informations du dessin pour permettre aux personnes qui ne dessinent pas de visualiser certaines informations.

Si une des personnes qui ne dessinent pas doit apporter des modifications, alors elle utilise le fichier excel "Extraction", feuille "Design", est insère la modification qu'elle veut apporter ensuite elle clique sur le bouton envoyer qui contient une macro d'envois par mail via Outlook qui doit prévenir le dessinateur en charge du projet du dessin correspondant.

La ou ça se complique c'est que dans ma récupération de données, je récupère le nom du dessinateur dans une cellule (Feuille "Design", cellule B7)et en fonction du nom je fais correspondre une adresse mail dans une cellule (Feuille "mail", cellule A1) parmi une liste de trois adresse qui sont listées (Feuille "mail", cellule E1:E3).

Ma macro contenu dans le bouton envois n'arrive pas à reconnaitre qu'il s'agit d'une adresse mail et me mets une erreur lors de l'exécution.

Voici la formule qui récupère les adresses mails :
=LIEN_HYPERTEXTE("mailto:"&(SI(Design!B7="Philippe";E1;SI(Design!B7="Laurent";E2;SI(Design!B7="Mikako";E3;"")))))

Malgré plusieurs tentative infructueuse de modification de celle-ci ainsi que l'utilisation du style de cellule et le format de cellule, le lien hypertexte vers l'adresse mail ne fonctionne pas dans la récupération de la macro d'envois que je vous mets si dessous.

Sub Mail_Range()
'Working in 2000-2007
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim rng As Range
Dim Arr() As String
Dim N As Integer
Dim cell As Range
Set rng = Sheets("Mail").Columns("A").Cells.SpecialCells(xlCellTypeConstants)
ReDim Preserve Arr(1 To rng.Cells.Count)
N = 0
For Each cell In rng
If cell.EntireRow.Hidden = False And cell.Value Like "*@*" Then
N = N + 1
Arr(N) = cell.Value
End If
Next cell
ReDim Preserve Arr(1 To N)

L'erreur apparaît sur la ligne surlignée en bleu.

J'espère avoir était le plus clair possible, et que vous saurez m'apporter une solution qu'elle soit sur la macro ou sur la cellule de la formule d'adresse mail.

Cordialement, Philippe qui galère dur sur ça.....

 

[tototiti2008]

Re : Format adresse mail depuis une formule avec macro VBA pour envoi par mail

Bonjour Binif,

Bienvenue sur XLD,

Les formules LIEN_HYPERTEXTE ne sont pas des constantes (ben non, ce sont de formules ), donc il ne trouve pas de cellules correspondantes à affecter à la variable rng

peut-être comme ça

Set rng = Sheets("Mail").Columns("A").Cells.SpecialCells(xlCellTypeFormulas, 23)

 

[Binif]

Bonjour,

Réveil pour moi heureux en ayant une réponse aussi rapidement et qui plus est JUSTE !!! (Québec)
Seul petite modification pour que cela fonctionne il faut enlever le format "mailto"& dans la formule de cherche pour ne pas créer de format d'adresse mail illisible dans Outlook et même lien_hypertexte n'est pas nécessaire donc pour résumer :

Formule Excel :

=SI(Design!B7="Philippe";E1;SI(Design!B7="Laurent";E2;SI(Design!B7="Mikako";E3;"")))

Macro Excel :

Set rng = Sheets("Mail").Columns("A").Cells.SpecialCells(xlCellTypeFormulas, 23)

Un grand merci pour ton aide, et ta rapidité de compréhension et surtout pour ta réponse précise, juste et expliquée.

Continuez de partager de cette manière, c'est formidable.

Cordialement, Philippe.

 

[Binif]

Bonjour tout le monde,

Je reviens avec mon problème qui a évolué, j'avais pris la macro de "RondeBruin" et modifié à ma sauce car tous le monde dans le bureau utilise Outlook, donc la fonction Sendmail me convenait mais je dois maintenant avoir un corps de mail contenant un lien hypertexte vers le document original.
Je sais que sendmail ne me le permets pas, et j'ai beau tester en remplaçant le sendmail avec une ouverture de l'application outlook mais là impossible de récupérer la liste des destinataires issue des formules ni même le preview.

On Error Resume Next


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "Je voudrais récupérer la liste issue des formules"
.CC = ""
.BCC = ""
.subject = "Preview of "
.attachment = "Je voudrais le preview de la feuille"
.HTMLBody = "Je voudrais le lien vers le fichier original"
.Display 'or use .Send
End With

Pouvez vous m'orienter ou m'aider à tout changer....

 

[Binif]

Bonjour,

Personne ne sais comment insérer une liste d'adresse mail qui sont issue d'une formule dans la partie "To =", je me débrouille pour le reste mais je ne sais vraiment pas récupérer les adresses...

 

[Staple1600]

Re : Re: Format adresse mail depuis une formule avec macro VBA pour envoi par mail

Bonjour

Bonjour tout le monde,

Pouvez vous m'orienter ou m'aider à tout changer....

T'orienter oui

-> vers cet endroit bien utile

EDITION: si je pars de cet exemple
En A1:A5 : des adresses mails
Testes alors cette macro

Sub a()
Dim x, y, mails$
x = Range("A1:A5").Value: y = Application.Transpose(t)
mails = Join(y, ";")
MsgBox mails
End Sub

Il suffit alors de l'adapter à ton existant
Remplace

.To = "Je voudrais récupérer la liste issue des formules"

par

.To= mails

 

[Binif]

Merci de m'orienter vers la fonction recherche du forum mais si je demande c'est que je n'ai pas trouvé ce que je demande, en gros j'ai besoin de récupérer une liste d'adresse mail dans une feuille qui sont issue d'une formule dans cette même feuille, avec la fonction .Sendmail de la première macro tout fonctionnait mais maintenant je dois injecter un corps de mail, donc la fonction .Sendmail ne fonctionne plus.

Je viens de me débrouiller pour insérer un lien et récupérer les données mais je n'arrive pas à récupérer les adresses mails...

Sub Mail_Range()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim Rcp As Range
Dim Arr() As String
Dim N As Integer
Dim cell As Range

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

strbody = "<font size=""3"" face=""Calibri"">" & _
"Ctrl + Click on this link to open the file : " & _
"<A HREF=""file://" & ActiveWorkbook.FullName & _
""">Link to the file</A>"

Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Design").Range("A1:H50").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Set Rcp = Sheets("Mail").Columns("A").Cells.SpecialCells(xlCellTypeFormulas, 23)

ReDim Preserve Arr(1 To Rcp.Cells.Count)
N = 0
For Each cell In Rcp
If cell.EntireRow.Hidden = False And cell.Value Like "*@*" Then
N = N + 1
Arr(N) = cell.Value
End If
Next cell
ReDim Preserve Arr(1 To N)

On Error Resume Next
With OutMail
.To = Arr 'Ca marche pas.... ^^
.CC = ""
.BCC = ""
.subject = "Latest modification of " & ActiveWorkbook.Name
.HTMLBody = "Hi, This is the preview of the design and production log." & "<br>" & _
"To open the source file, please follow the link at the bottom of the page." & _
RangetoHTML(rng) & strbody
.Display 'or use .Send
End With
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Merci à "RondeBruin" surtout.

 

[Staple1600]

Re : Format adresse mail depuis une formule avec macro VBA pour envoi par mail

Re

Tu as vu que j'avais ajouté une macro dans mon message (je l'ai édité)

Si je te conseille d'utiliser le moteur de recherche du forum c'est que tu n'as pas spécifié que tu avais cherché des fils de discussions relatifs à ton problème.

 

[Binif]

Je te remercie de m'aider, en me relisant je me suis apercu que j'etais tres froid dans ma reponse, mais se n'etait pas voulu.
Je n'arrive pas a integrer ta solution dans le code, et je ne sais pas non plus si en transposant les adresses qui sont issue d une formule vers outlook cela peut fonctionner.

Via mon essais
Je galere a savoir quoi mettre To = Arr(....) si je mets (1) cela me conserve la premiere adresse mail et si je mets (N) cela me mets la derniere adresse mail.

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Set Rcp = Sheets("Mail").Columns("A").Cells.SpecialCells(xlCellTypeFormulas, 23)

ReDim Preserve Arr(1 To Rcp.Cells.Count)
N = 0
For Each cell In Rcp
If cell.EntireRow.Hidden = False And cell.Value Like "*@*" Then
N = N + 1
Arr(N) = cell.Value
End If
Next cell
ReDim Preserve Arr(1 To N)

On Error Resume Next
With OutMail
.to = Arr(1)
.CC = ""
.BCC = ""
.subject = "Latest modification of " & ActiveWorkbook.Name
.HTMLBody = "Hi, This is the preview of the design and production log." & "<br>" & _
"To open the source file, please follow the link at the bottom of the page." & _
RangetoHTML(rng) & strbody
.Display 'or use .Send
End With
On Error GoTo 0

 

[Binif]

Personne pour m'aider...

 

[Staple1600]

Re : Format adresse mail depuis une formule avec macro VBA pour envoi par mail

Bonsoir


Qu'est ce que tu ne comprends pas dans l'exemple que j'ai posté précédemment ?

Sub a()
Dim x, y, mails$
x = Range("A1:A5").Value: y = Application.Transpose(t)
mails = Join(y, ";")
MsgBox mails
End Sub

Tu l'as testé ?

 

[Binif]

Salut,

J'ai tenté d'intégrer ta sub dans la mienne mais même en conservant la sub et en la décomposant pour la mettre dans la mienne mais j'ai une erreur sur la ligne dans les deux cas.

mails = Join(y, ";")

Erreur d'execution '13' :
incompatibilité de type.

Sub Recup()
Dim x, y, mails$
x = Sheets("Mail").Range("A1:A8").Value: y = Application.Transpose(t)
mails = Join(y, ";")
MsgBox mails
End Sub

 

[Staple1600]

Re : Format adresse mail depuis une formule avec macro VBA pour envoi par mail

Bonjour

Set Rcp = Sheets("Mail").Columns("A").Cells.SpecialCells(xlC  ellTypeFormulas, 23)
MailArr=Rcp.Value

mails=Join(Application.Transpose(MailArr),";")

With OutMail
    .To = mails

Je te laisse agencer et tester sinon mon repas va être froid

PS: ma macro n'était un exemple illustratif de la fonction Join

 

[Binif]

Salut,

Je te remercie sincèrement, j'avais tenté de modifier la macro mais je n'avais pas réussi, tu me sauve la vie !!!

J'ai enfin, grâce à vous tous, réussi à créer, lors de la création d'un dessin Autocas, un fichier Excel qui récupère toutes les informations contenu dans une zone du dessin, les traitent et à la fermeture de ce fichier Excel, une demande d'envois par mail des modifications pour prévenir les personnes concernées.

Grosse job mais je suis content que cela fonctionne !

Encore merci !!!