Bonjour à tous,
On a récemment changé de version d'excel au travail et une macro ne fonctionne plus correctement, ce qui cause beaucoup de problèmes à notre service d'études.
Objet de la macro.
Initialement on clique sur " mise à jour annuaire " sur la première page et on a outlook ouvert.
Une fois transféré sur la nouvelle page, on sélectionne des lignes d'une base de données ( une ligne par entreprise ) en écrivant "x" en face de chaque ligne dans la colonne dédiée.
Elles sont ensuite transférées sur une autre page une fois que l'on a appuyé sur le bouton " annuaire --> études ".
Dans l'onglet "études" on tappe "e" dans la première colonne en face de chaque contact à qui on désire envoyer le mail.
On clique ensuite sur " créer les mails " ou " créer l'ensemble des mails " selon s'il y a un ou plusieurs destinataires.
Résultat.
Normalement une fenêtre outlook souvre par destinataire avec l'adresse mail de chacun ( jusque là pas de problème ).
L'élément important est l'envoi du mail modèle qui est sur la page excel "mail" complété par les informations des destinataires. Le souci est que le mail n'est pas transféré du tout ( rien n'apparaît ).
Je vous colle la macro qui semble concernée, peut être qu'il y a un changement à faire dans le codage, auquel cas n'étant pas un spécialiste je suis bien ennuyé et je fais appel à votre aide. Sinon j'ai essayé plusieurs manips comme l'autorisation des macros ou bien l'enregistrement sous une version plus récente.
Bref si vous avez une solution je suis preneur, ça fait déjà deux jours que je suis dessus, ça commence à faire !
Merci d'avance !
Global send_emails As Integer ' 1 = send emails automatically
' 2 = send manually
' 0 = invalid value (msgbox not yet propted)
Sub Email()
' requires a reference to the Microsoft Outlook Object Library
'creates link to Outlook
Dim objOL As New Outlook.Application
Dim objMail As MailItem
Dim email_objet As String 'email message subjet 'onglet EMAIL'
Dim email_cc As String 'cc receipiant email
Dim email_to As String 'email reciepiant
Dim email_attachement As String 'attachement location
Dim email_message As String 'entire email message (all paragraphs)
Dim email_body As String 'email body - paragraph 1
Dim email_body1 As String 'email body - paragraph 2
Dim email_body2 As String 'email body - paragraph 3
Dim email_body3 As String 'email body - paragraph 4
Dim email_body4 As String 'email body
Dim email_body5 As String 'email body
Dim email_body6 As String 'email body
Dim email_body7 As String 'email body
Dim email_body8 As String 'email body
Dim email_body9 As String 'email body
Dim email_body10 As String 'email body
Dim email_body11 As String 'email body
Dim NomSociete As String 'nom Société destinataire
Dim para As String 'next paragraph html code
response = vbNo
If send_emails = 1 Then
'do nothing
ElseIf send_emails = 2 Then
'do nothing
Else
c = MsgBox("Voulez vous envoyer tout les emails automatiquement?", 4)
If response = vbNo Then
send_emails = 2 'send emails manually
Else
send_emails = 1 'send emails automatically
End If
c = MsgBox(" Attention! " & vbCrLf & vbCrLf & _
"laisser Excel l'accès à Outlook pour quelques minutes : " & vbCrLf & _
"(choisis une durée et clic oui au dialogue que présentera Outlook)")
End If
'--- Prevent screen redraws until the macro is finished.
Application.ScreenUpdating = False
r = Selection.Row
Cells(r, 2).Select '2 = colonne du nom du lot
On Error Resume Next
' *********** Start / Default values ********************************************* :
choix = "EMAIL" ' feuille destination
feuille = ActiveSheet.Name ' ETUDES normalement
' **********************************************************************************
'== set values ============
Sheets(feuille).Select
email_body = ActiveCell.Value 'définir la valeur de paragraphe 1 comme le nom du lot
'Selection.Copy
'Sheets(choix).Select
'Application.Goto reference:="societet"
'Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
' False, Transpose:=False
NomSociete = Cells(r, 5)
Sheets(choix).Select
Range("M17") = NomSociete
email_objet = Range("objet")
email_cc = Range("email_cc")
email_attachement = Range("attachement")
Range("email_body") = "<b>lot : " & email_body & "</b>"
email_body = Range("email_body")
email_body1 = Range("email_body1")
email_body2 = Range("email_body2")
email_body3 = Range("email_body3")
email_body4 = Range("email_body4")
email_body5 = Range("email_body5")
email_body6 = Range("email_body6")
email_body7 = Range("email_body7")
email_body8 = Range("email_body8")
email_body9 = Range("email_body9")
email_body10 = Range("email_body10")
email_body11 = Range("email_body11")
para = "<br><br> </p>" & "<p class=MsoNormal> <font size=2 face=Arial>"
'assemble email message in html format (minus lead <p> tag
email_message = email_body 'first paragraph
Range("B11").Select
For i = 0 To 10
Cells(i, 0).Select
ActiveCell.Offset(1, 0).Select
If ActiveCell = "" Then
Else
email_message = email_message & para & ActiveCell
End If
Next i
' ========================
'get email address
Sheets(feuille).Select
Cells(r, 2).Select
ActiveCell.Offset(0, 9).Select
email_to = ActiveCell
'==========================
Set objOL = New Outlook.Application
Set testsemail = objOL.CreateItem(olMailItem)
'sets charactersitics for email
With testsemail
'requests a read confimeration receipt for the email
.ReadReceiptRequested = True
'sets receipent
.To = email_to
.CC = email_cc
'enters subject
.Subject = email_objet
'If send_emails = 1 Then
'displays email to allow manipulation for comments
.Display
'End If
'enters text for email
strMsg = .HTMLBody 'get blanc email (with signature)
'insert message into html string
strMsg = Replace$(strMsg, "<div class=Section1>", _
"<div class=Section1> <p class=MsoNormal><font size=2 face=Arial>" & _
email_message & "</p>")
'paste new message
.HTMLBody = strMsg
'.Body = strMsg 'non HTML Message
If email_attachement = "" Then
Else
attach1 = .Attachments.Add(email_attachement, , 60)
End If
If send_emails = 0 Then
'displays email to allow manipulation for comments
.Display
End If
If send_emails = 1 Then
.Send '--- Send the message.
End If
'.Body = "This is an automated message from Excel. " & _
"The cost of the item that you inquired about is: " & _
Format(Range("A1").Value, "$ #,###.#0") & "."
'sMsgBody = "HI mjschukas" & vbCr & vbCr
'sMsgBody = sMsgBody & "The vbcr means skip a line, and if " & vbCr
'sMsgBody = sMsgBody & " you place to of them you will skip 2 lines." & vbCr & vbCr
'sMsgBody = sMsgBody & "Thank you," & vbCr & vbCr
'.Body = sMsgBody
End With
'--- Remove the message and Outlook application from memory.
Set objMail = Nothing
Set objOL = Nothing
Application.ScreenUpdating = True
End Sub
' source : Added (jobs): Automating Emails from Excel - VBA Express Forum
' This macro assumes the following:
' * E-mail addresses are in column A.
' * Names are in column B.
' * Cells A1 and B1 contain headers.
Sub MailItNow()
'--- Declare our variables.
Dim X As Integer
Dim TempCustomerAddress As String
'--- Prevent screen redraws until the macro is finished.
Application.ScreenUpdating = False
'--- Sort the addresses and names alphabetically, by the e-mail address.
'--- This is REQUIRED to prevent any duplicate addresses from
' receiving more than one e-mail.
Columns("A:B").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'--- Sets which row to start searching for e-mail addresses and names.
X = 2
'--- Begin looping through all the e-mail addresses in column A until
' a blank cell is hit.
While Range("A" & X).Text <> ""
'--- These variables will be used to search for duplicates.
CustomerAddress = Range("A" & X).Text
TempCustomerAddress = CustomerAddress
'--- Increment X until a different e-mail address is found.
While TempCustomerAddress = CustomerAddress
X = X + 1
CustomerAddress = Range("A" & X).Text
Wend
'--- Add the e-mail address to a global variable.
CustomerAddress = Range("A" & X - 1).Text
'--- Add a message with the user's name to the e-mail.
'--- Customize your own message and closing here.
CustomerMessage = Range("B" & X - 1).Text & "," & vbCrLf & vbCrLf _
& "Thank you for trying our product!" & vbCrLf & vbCrLf & _
"Sincerely," & vbCrLf & "ProductCo Inc."
'--- Run the subroutine to send the message.
Call SendMessage
Wend
End Sub
Sub SendMessage(Optional AttachmentPath)
'--- This is required to prevent a name which does not resolve to
' an e-mail address from hanging the app.
On Error Resume Next
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(CustomerAddress)
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = "Thank You!"
.Body = CustomerMessage
.Importance = olImportanceHigh 'High importance
' Add attachments to the message.
'attach1 = .Attachments.Add("c:temptest.xls", , 60)
If Not IsMissing(AttachmentPath) Then
Set objOutlookAttach = .Attachments.Add(AttachmentPath)
End If
' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
Exit Sub
End If
Next
.Send '--- Send the message.
End With
'--- Remove the message and Outlook application from memory.
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub
On a récemment changé de version d'excel au travail et une macro ne fonctionne plus correctement, ce qui cause beaucoup de problèmes à notre service d'études.
Objet de la macro.
Initialement on clique sur " mise à jour annuaire " sur la première page et on a outlook ouvert.
Une fois transféré sur la nouvelle page, on sélectionne des lignes d'une base de données ( une ligne par entreprise ) en écrivant "x" en face de chaque ligne dans la colonne dédiée.
Elles sont ensuite transférées sur une autre page une fois que l'on a appuyé sur le bouton " annuaire --> études ".
Dans l'onglet "études" on tappe "e" dans la première colonne en face de chaque contact à qui on désire envoyer le mail.
On clique ensuite sur " créer les mails " ou " créer l'ensemble des mails " selon s'il y a un ou plusieurs destinataires.
Résultat.
Normalement une fenêtre outlook souvre par destinataire avec l'adresse mail de chacun ( jusque là pas de problème ).
L'élément important est l'envoi du mail modèle qui est sur la page excel "mail" complété par les informations des destinataires. Le souci est que le mail n'est pas transféré du tout ( rien n'apparaît ).
Je vous colle la macro qui semble concernée, peut être qu'il y a un changement à faire dans le codage, auquel cas n'étant pas un spécialiste je suis bien ennuyé et je fais appel à votre aide. Sinon j'ai essayé plusieurs manips comme l'autorisation des macros ou bien l'enregistrement sous une version plus récente.
Bref si vous avez une solution je suis preneur, ça fait déjà deux jours que je suis dessus, ça commence à faire !
Merci d'avance !
Global send_emails As Integer ' 1 = send emails automatically
' 2 = send manually
' 0 = invalid value (msgbox not yet propted)
Sub Email()
' requires a reference to the Microsoft Outlook Object Library
'creates link to Outlook
Dim objOL As New Outlook.Application
Dim objMail As MailItem
Dim email_objet As String 'email message subjet 'onglet EMAIL'
Dim email_cc As String 'cc receipiant email
Dim email_to As String 'email reciepiant
Dim email_attachement As String 'attachement location
Dim email_message As String 'entire email message (all paragraphs)
Dim email_body As String 'email body - paragraph 1
Dim email_body1 As String 'email body - paragraph 2
Dim email_body2 As String 'email body - paragraph 3
Dim email_body3 As String 'email body - paragraph 4
Dim email_body4 As String 'email body
Dim email_body5 As String 'email body
Dim email_body6 As String 'email body
Dim email_body7 As String 'email body
Dim email_body8 As String 'email body
Dim email_body9 As String 'email body
Dim email_body10 As String 'email body
Dim email_body11 As String 'email body
Dim NomSociete As String 'nom Société destinataire
Dim para As String 'next paragraph html code
response = vbNo
If send_emails = 1 Then
'do nothing
ElseIf send_emails = 2 Then
'do nothing
Else
c = MsgBox("Voulez vous envoyer tout les emails automatiquement?", 4)
If response = vbNo Then
send_emails = 2 'send emails manually
Else
send_emails = 1 'send emails automatically
End If
c = MsgBox(" Attention! " & vbCrLf & vbCrLf & _
"laisser Excel l'accès à Outlook pour quelques minutes : " & vbCrLf & _
"(choisis une durée et clic oui au dialogue que présentera Outlook)")
End If
'--- Prevent screen redraws until the macro is finished.
Application.ScreenUpdating = False
r = Selection.Row
Cells(r, 2).Select '2 = colonne du nom du lot
On Error Resume Next
' *********** Start / Default values ********************************************* :
choix = "EMAIL" ' feuille destination
feuille = ActiveSheet.Name ' ETUDES normalement
' **********************************************************************************
'== set values ============
Sheets(feuille).Select
email_body = ActiveCell.Value 'définir la valeur de paragraphe 1 comme le nom du lot
'Selection.Copy
'Sheets(choix).Select
'Application.Goto reference:="societet"
'Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
' False, Transpose:=False
NomSociete = Cells(r, 5)
Sheets(choix).Select
Range("M17") = NomSociete
email_objet = Range("objet")
email_cc = Range("email_cc")
email_attachement = Range("attachement")
Range("email_body") = "<b>lot : " & email_body & "</b>"
email_body = Range("email_body")
email_body1 = Range("email_body1")
email_body2 = Range("email_body2")
email_body3 = Range("email_body3")
email_body4 = Range("email_body4")
email_body5 = Range("email_body5")
email_body6 = Range("email_body6")
email_body7 = Range("email_body7")
email_body8 = Range("email_body8")
email_body9 = Range("email_body9")
email_body10 = Range("email_body10")
email_body11 = Range("email_body11")
para = "<br><br> </p>" & "<p class=MsoNormal> <font size=2 face=Arial>"
'assemble email message in html format (minus lead <p> tag
email_message = email_body 'first paragraph
Range("B11").Select
For i = 0 To 10
Cells(i, 0).Select
ActiveCell.Offset(1, 0).Select
If ActiveCell = "" Then
Else
email_message = email_message & para & ActiveCell
End If
Next i
' ========================
'get email address
Sheets(feuille).Select
Cells(r, 2).Select
ActiveCell.Offset(0, 9).Select
email_to = ActiveCell
'==========================
Set objOL = New Outlook.Application
Set testsemail = objOL.CreateItem(olMailItem)
'sets charactersitics for email
With testsemail
'requests a read confimeration receipt for the email
.ReadReceiptRequested = True
'sets receipent
.To = email_to
.CC = email_cc
'enters subject
.Subject = email_objet
'If send_emails = 1 Then
'displays email to allow manipulation for comments
.Display
'End If
'enters text for email
strMsg = .HTMLBody 'get blanc email (with signature)
'insert message into html string
strMsg = Replace$(strMsg, "<div class=Section1>", _
"<div class=Section1> <p class=MsoNormal><font size=2 face=Arial>" & _
email_message & "</p>")
'paste new message
.HTMLBody = strMsg
'.Body = strMsg 'non HTML Message
If email_attachement = "" Then
Else
attach1 = .Attachments.Add(email_attachement, , 60)
End If
If send_emails = 0 Then
'displays email to allow manipulation for comments
.Display
End If
If send_emails = 1 Then
.Send '--- Send the message.
End If
'.Body = "This is an automated message from Excel. " & _
"The cost of the item that you inquired about is: " & _
Format(Range("A1").Value, "$ #,###.#0") & "."
'sMsgBody = "HI mjschukas" & vbCr & vbCr
'sMsgBody = sMsgBody & "The vbcr means skip a line, and if " & vbCr
'sMsgBody = sMsgBody & " you place to of them you will skip 2 lines." & vbCr & vbCr
'sMsgBody = sMsgBody & "Thank you," & vbCr & vbCr
'.Body = sMsgBody
End With
'--- Remove the message and Outlook application from memory.
Set objMail = Nothing
Set objOL = Nothing
Application.ScreenUpdating = True
End Sub
' source : Added (jobs): Automating Emails from Excel - VBA Express Forum
' This macro assumes the following:
' * E-mail addresses are in column A.
' * Names are in column B.
' * Cells A1 and B1 contain headers.
Sub MailItNow()
'--- Declare our variables.
Dim X As Integer
Dim TempCustomerAddress As String
'--- Prevent screen redraws until the macro is finished.
Application.ScreenUpdating = False
'--- Sort the addresses and names alphabetically, by the e-mail address.
'--- This is REQUIRED to prevent any duplicate addresses from
' receiving more than one e-mail.
Columns("A:B").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'--- Sets which row to start searching for e-mail addresses and names.
X = 2
'--- Begin looping through all the e-mail addresses in column A until
' a blank cell is hit.
While Range("A" & X).Text <> ""
'--- These variables will be used to search for duplicates.
CustomerAddress = Range("A" & X).Text
TempCustomerAddress = CustomerAddress
'--- Increment X until a different e-mail address is found.
While TempCustomerAddress = CustomerAddress
X = X + 1
CustomerAddress = Range("A" & X).Text
Wend
'--- Add the e-mail address to a global variable.
CustomerAddress = Range("A" & X - 1).Text
'--- Add a message with the user's name to the e-mail.
'--- Customize your own message and closing here.
CustomerMessage = Range("B" & X - 1).Text & "," & vbCrLf & vbCrLf _
& "Thank you for trying our product!" & vbCrLf & vbCrLf & _
"Sincerely," & vbCrLf & "ProductCo Inc."
'--- Run the subroutine to send the message.
Call SendMessage
Wend
End Sub
Sub SendMessage(Optional AttachmentPath)
'--- This is required to prevent a name which does not resolve to
' an e-mail address from hanging the app.
On Error Resume Next
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(CustomerAddress)
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = "Thank You!"
.Body = CustomerMessage
.Importance = olImportanceHigh 'High importance
' Add attachments to the message.
'attach1 = .Attachments.Add("c:temptest.xls", , 60)
If Not IsMissing(AttachmentPath) Then
Set objOutlookAttach = .Attachments.Add(AttachmentPath)
End If
' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
Exit Sub
End If
Next
.Send '--- Send the message.
End With
'--- Remove the message and Outlook application from memory.
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub
