VBA Mail erreur 440
Bonjour à tous,
J'ai une procédure VBA qui fonctionnait parfaitement, mais bizarrement Excel de façon aléatoire me semble t-il, m'alerte avec le message d'erreur suivant : "Erreur 440 cet objet ne prends pas en charge cette méthode" sur la ligne de code suivante :
.To = Tableau.Cells(i, "J") 'destinataire mailC'est une procédure qui relance des adresses mails (valides), avec un corps de texte, et des pièces jointes (existantes),
La procédure fonctionne jusqu'à une certain nombre de lignes (la plage étant pourtant bien définie)
For i = 2 To Tableau.Rows.Countmais bloque ensuite sur une ligne pourtant valable (car si je la place au début, la procédure fonctionne pour cette ligne)
Auriez vous une idée?,
Merci d'avance,
Cordialement,
Bonjour
Sans voir le code complet....
Ensuite vérifiez dans le gestionnaire de nom si vous trouver le nom "Tableau" qui, je suppose est un tableau structuré
Cordialement
Bonsoir Dan,
J'ai lancé a procédure ce matin, et le blocage se situé à la ligne 62,
Je relance la procédure et le blocage se fait à la ligne 119 !
Le TS est bien défini dans le gestionnaire de nom, il correspond dans mon fichier à la plage A1:J140
Trés étrange ce comportement, je poste le code complet, qui n'est pas de moi mais d'une aide que j'avais reçu,
' Ce code permet d'intégrer une plage donnée dans le corps d'un mail
Sub EnvoiMails()
Dim Rng As Range, Tableau, Dict, shA
Dim OutApp As Object, OutMail As Object
Dim StrHTML As String, StrSignature As String, sFichier
Set shA = Sheets("Aux") '---->feuille auxiliaire (et cachée) pour copier & coller les lignes visible après le filtre
Set Dict = CreateObject("scripting.dictionary") 'dictionaire pour les NUM CLIENTS "unique"
' Définir la plage des cellules uniquement visibles
Set Tableau = Range("t_Relances_Mails").ListObject.Range 'tableau relance mails
Tableau.AutoFilter 'déactiver le filtre eventuel
With Application
.EnableEvents = False ' Désactiver les évènements
.ScreenUpdating = False ' Désactiver le rafraichissement
End With
For i = 2 To Tableau.Rows.Count 'commencer avec 4 pour le test , plus tard jusqu'à ... tableau.rows.count
If Not Dict.exists(Tableau.Cells(i, 1).Value) And Tableau.Cells(i, "J") <> "" Then 'un nouveau NUM CLIENTS et un emailadres valable
Dict(Tableau.Cells(i, 1).Value) = vbEmpty 'ajouter au dictionaire (ainsi NUM CLIENTS unique !!!)
Tableau.AutoFilter 1, Tableau.Cells(i, 1) 'filtrer le tableau sur ce num
Set Rng = Tableau.Resize(, 8).SpecialCells(xlCellTypeVisible) 'les colonnes A:H, ignorer I:K
If Rng Is Nothing Then
MsgBox "Il ya eu un problème lors de la définition de la plage"
Exit Sub
End If
With shA
.UsedRange.Clear
Rng.Copy .Range("A1") 'copier et coller plage visible
End With
' Avec l'application
' Créer une instance Outllok et Mail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.Display ' Afficher le mail pour la signature (si insertion auto)
' Mémoriser le code HTML avec la signature
StrSignature = .HTMLBody
.To = Tableau.Cells(i, "J") 'destinataire mail
' .CC = Tableau.Cells(i, "K")
' .BCC = "LaCopieCachee@fai.fr"
.Subject = "Relance facture(s) en attente de règlement"
StrHTML = "Bonjour,<br><br>" _
& "Test:<br>"
.HTMLBody = StrHTML & RangetoHTML(Rng) & WorksheetFunction.Rept("<br>", 1) & "Test2.<br><br>" _
& "Cordialement," & StrSignature
'Stop
s = ""
For Each c In shA.Range("A1").CurrentRegion.Columns(1).Cells 'cellules visible (filtré) qu'on a collé dans cette feuille
If c.Row > 1 And c.Cells(1, "D").Value <> "" And c.Cells(1, "E").Value <> "" Then 'Site et Pièce Site ne sont pas vide
sFichier = "P:\CLIENTS\FACTURES CLIENTS\" & c.Cells(1, "D").Value & "\" & c.Cells(1, "E").Value & ".pdf" '>>>> la PJ, c'est sans extension, donc ajouter ".PDF" par exemple ?
If Dir(sFichier) = "" Then
s = s & vbLf & sFichier
Else
.Attachments.Add (sFichier)
End If
End If
Next
'If s <> "" Then MsgBox "erreur, fichier(s) n'existe(nt) pas" & vbLf & Mid(s, 2), vbCritical, Tableau.Cells(i, "A").Value
'.Send 'or use .Display
End With
End If
Next
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
'Effacer les variables objet
Set OutMail = Nothing: Set OutApp = Nothing
End Sub
Function RangetoHTML(Rng As Range)
Dim Fso As Object, Ts As Object
Dim TempFile As String
Dim TempWb As Workbook
' Créer le nom du fichier
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Copier la plage et créer un classeur pour coller les données dedans
Rng.Copy
Set TempWb = Workbooks.Add(1)
With TempWb.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
' Publier la feuille dans un fichier HTML
With TempWb.PublishObjects.Add(SourceType:=xlSourceRange, Filename:=TempFile, Sheet:=TempWb.Sheets(1).Name, Source:=TempWb.Sheets(1).UsedRange.Address, HtmlType:=xlHtmlStatic)
.Publish (True)
End With
' Lire les données du fichier
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Ts = Fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = Ts.readall
Ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
' Fermer le classeur sans sauvegarde
TempWb.Close SaveChanges:=False
' Supprimer le fichier HTML
Kill TempFile
' Effacer les variables objet
Set Ts = Nothing: Set Fso = Nothing: Set TempWb = Nothing
End FunctionMerci d'avance pour une idée du blocage,
Cordialement,
re
hum... il y a des choses bizarres dans le code
Exemple dans la partie sha.usedrange.clear, pourquoi supprime-t-on la plage à chaque valeur de i ?
A cette ligne --> vous avez une adresse mail correcte lorsque i vaut 62 comme mentionné dans votre demande ?
.To = Tableau.Cells(i, "J")C'est juste une remarque mais Il y a aussi des variables non déclarées et des variables mal déclarées.
Bonsoir
A tester
Option Explicit
' Ce code permet d'intégrer une plage donnée dans le corps d'un mail
Sub EnvoiMails()
Dim Rng As Range, Tableau As ListObject
Dim Dict As Object, shA As Worksheet
Dim OutApp As Object, OutMail As Object
Dim StrHTML As String, StrSignature As String
Dim sFichier As String, i As Long
Dim s As String
Dim clientNum As Variant
' Initialisation
Set shA = Sheets("Aux") ' Feuille auxiliaire (et cachée)
Set Dict = CreateObject("Scripting.Dictionary") ' Dictionnaire pour les NUM CLIENTS "uniques"
Set Tableau = Range("t_Relances_Mails").ListObject ' Tableau relance mails
Tableau.AutoFilter ' Désactiver le filtre éventuel
' Désactiver les événements et le rafraîchissement
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
On Error GoTo Cleanup ' Gestion des erreurs
For i = 2 To Tableau.ListRows.Count ' Commencer à la ligne 2
clientNum = Tableau.Cells(i, 1).Value
If Not Dict.exists(clientNum) And Tableau.Cells(i, "J") <> "" Then ' Nouveau NUM CLIENT et un email valide
Dict(clientNum) = vbEmpty ' Ajouter au dictionnaire
' Filtrer le tableau sur ce numéro
Tableau.AutoFilter 1, clientNum
Set Rng = Tableau.Resize(, 8).SpecialCells(xlCellTypeVisible) ' Colonnes A:H
If Rng Is Nothing Then
MsgBox "Il y a eu un problème lors de la définition de la plage"
Exit Sub
End If
With shA
.UsedRange.Clear
Rng.Copy .Range("A1") ' Copier et coller la plage visible
End With
' Créer une instance Outlook et Mail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.Display ' Afficher le mail pour la signature
' Mémoriser le code HTML avec la signature
StrSignature = .HTMLBody
.To = Tableau.Cells(i, "J") ' Destinataire mail
.Subject = "Relance facture(s) en attente de règlement"
StrHTML = "Bonjour,<br><br>Test:<br>"
.HTMLBody = StrHTML & RangetoHTML(Rng) & _
WorksheetFunction.Rept("<br>", 1) & _
"Test2.<br><br>Cordialement," & StrSignature
' Gérer les pièces jointes
s = ""
For Each c In shA.Range("A1").CurrentRegion.Columns(1).Cells
If c.Row > 1 And c.Cells(1, "D").Value <> "" And c.Cells(1, "E").Value <> "" Then
sFichier = "P:\CLIENTS\FACTURES CLIENTS\" & c.Cells(1, "D").Value & "\" & c.Cells(1, "E").Value & ".pdf"
If Dir(sFichier) <> "" Then
.Attachments.Add (sFichier)
Else
s = s & vbLf & sFichier
End If
End If
Next
' Vérifier les fichiers manquants
If s <> "" Then
MsgBox "Erreur, fichier(s) n'existe(nt) pas:" & vbLf & Mid(s, 2), vbCritical, Tableau.Cells(i, "A").Value
End If
' .Send ' ou utiliser .Display
End With
End If
Next
Cleanup:
' Réactiver les événements et le rafraîchissement
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
' Effacer les variables objet
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(Rng As Range) As String
Dim Fso As Object, Ts As Object
Dim TempFile As String
Dim TempWb As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Rng.Copy
Set TempWb = Workbooks.Add(1)
With TempWb.Sheets(1)
.Cells(1).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With TempWb.PublishObjects.Add(SourceType:=xlSourceRange, Filename:=TempFile, _
Sheet:=TempWb.Sheets(1).Name, _
Source:=TempWb.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Ts = Fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = Ts.ReadAll
Ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
TempWb.Close SaveChanges:=False
Kill TempFile
Set Ts = Nothing: Set Fso = Nothing: Set TempWb = Nothing
End FunctionBonsoir Dan,
Je vais tenter de répondre, la plage est supprimer à chaque changement de valeur d'adresse mail , car elle est copié sur un onglet appelé "Aux", puis effacé pour y mettre les données du mail suivant,
Oui j'ai bien une adresse mail valide dans le TS, au matin la procédure s'arrête à la ligne 62 et au soir en faisant une nouvelle tentative sur le même TS, c'est à la ligne 119
Pour la déclaration des variables, qu'elles sont celles qui sont mal ou pas déclarées?,
Je joins un fichier type anonyme pour mieux appréhender la procédure,
Cordialement,
Bonsoir Joco75,
J'ai testé votre procédure modifiée, mais celle ci se bloque également à la ligne avec le code erreur 440 :
.To = Tableau.Cells(i, "J") ' Destinataire mailmais cette fois la ligne 79 du TS,
Merci quand même pour votre proposition,
Cordialement,
Re
Je n'ai pas outllook et votre fichier ne comporte pas assez de lignes pour vérifier
Juste une idée. Avant la ligne qui bloque mettez cette ligne
On error goto finA la fin du code juste avant le End Sub, mettez ceci
fin :
Msgbox Tableau.cells(i, "J")cela devrait vous donner la valeur de la cellule concernée.
Eventuellement peut être ajouter .address derrière
Bonsoir à tous,
J'ai testé la mise en place préconisé par Dan et la cellule en défaut est la cellule J79 correspondant à une adresse mail valide qui est du genre : info.test@test.fr
Je ne vois pas en quoi elle bloque car si je change l'ordre du TS et que cette adresse se trouve au début de celui-ci, le mail est créé !
Je ne peux pas fournir mon fichier étant celui du travail, le fichier joint précédemment vous donne une idée de la structure du TS,
Merci d'avance si vous avez une idée de la raison du blocage lié à l'adresse mail et l'erreur 440 généré,
Cordialement,
Bonjour à tous,
J'ai testé le fichier joint.
La première chose que j'ai faite est de mettre Option Explicit en haut du module. Les variables I, C, S n'étaient pas déclarées.
L'instance Outlook étant en late binding, j'ai eu un problème avec olMailitem qui n'était pas reconnu dans :
Set OutMail = OutApp.CreateItem(olMailItem)J'ai référencé Outlook dans Outils/Références et déclaré les variables Outlook avec les bons types.
J'ai trouvé également que le code n'avait pas sa place dans un module d'onglet. Je l'ai déplacé dans un module standard.
J'ai déplacé l'instanciation de Outlook en dehors de la boucle car on créait une instance à chaque boucle.
Je n'ai pas touché à la fonction.
Chez moi le code fonctionne, je n'ai pu reproduire le problème.
Nb : Si tous les postes informatiques utilisant cet outil ont la même version d'office, vous pouvez rester avec le référencement d'outlook, sinon il faudra repasser en late binding, décocher la référence et déclarer les variables en type Object après avoir fait un essai.
Option Explicit' Ce code permet d'intégrer une plage donnée dans le corps d'un mail
Sub EnvoiMails()
Dim I As Integer
Dim S As String, RepertoireDestination As String
Dim Rng As Range, C As Range, Tableau, Dict
Dim ShA As Worksheet
' Dim OutApp As Object, OutMail As Object
Dim OutApp As Outlook.Application, OutMail As Outlook.MailItem ' Ne pas oublier de référencer OutLook dans Outils/Références
Dim StrHTML As String, StrSignature As String, sFichier
RepertoireDestination = "P:\APEI\SECTEUR TAD\CLIENTS\FACTURES CLIENTS\"
Set ShA = Sheets("Aux") '---->feuille auxiliaire (et cachée) pour copier & coller les lignes visible après le filtre
Set Dict = CreateObject("scripting.dictionary") 'dictionaire pour les NUM CLIENTS "unique"
' Définir la plage des cellules uniquement visibles
Set Tableau = Range("t_Relances_Mails").ListObject.Range 'tableau relance mails
Tableau.AutoFilter 'déactiver le filtre eventuel
' Création de l'instance OutLook
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False ' Désactiver les évènements
.ScreenUpdating = False ' Désactiver le rafraichissement
End With
For I = 2 To Tableau.Rows.Count 'commencer avec 4 pour le test , plus tard jusqu'à ... tableau.rows.count
If Not Dict.exists(Tableau.Cells(I, 1).Value) And Tableau.Cells(I, "J") <> "" Then 'un nouveau NUM CLIENTS et un emailadres valable
Dict(Tableau.Cells(I, 1).Value) = vbEmpty 'ajouter au dictionaire (ainsi NUM CLIENTS unique !!!)
Tableau.AutoFilter 1, Tableau.Cells(I, 1) 'filtrer le tableau sur ce num
Set Rng = Tableau.Resize(, 8).SpecialCells(xlCellTypeVisible) 'les colonnes A:H, ignorer I:K
If Rng Is Nothing Then
MsgBox "Il ya eu un problème lors de la définition de la plage"
GoTo Fin
End If
With ShA
.UsedRange.Clear
Rng.Copy .Range("A1") 'copier et coller plage visible
End With
' Avec l'application
' Créer une instance Mail
Set OutMail = OutApp.CreateItem(olMailItem)
With OutMail
.Display ' Afficher le mail pour la signature (si insertion auto)
' Mémoriser le code HTML avec la signature
StrSignature = .HTMLBody
.To = Tableau.Cells(I, "J") 'destinataire mail
' .CC = Tableau.Cells(i, "K")
' .BCC = "LaCopieCachee@fai.fr"
.Subject = "Relance facture(s) en attente de règlement"
StrHTML = "Bonjour,<br><br>" _
& "Après vérification de votre compte client, sauf erreur de notre part, nous n’avons pas reçu le règlement de la (des) facture(s) suivante(s) ci-jointe(s):<br>"
.HTMLBody = StrHTML & RangetoHTML(Rng) & WorksheetFunction.Rept("<br>", 1) & "Merci d'avance de bien vouloir régulariser cette situation dès réception du présent email et de nous confirmer la date de règlement.<br><br>" _
& "Cordialement," & StrSignature
'Stop
S = ""
For Each C In ShA.Range("A1").CurrentRegion.Columns(1).Cells 'cellules visible (filtré) qu'on a collé dans cette feuille
If C.Row > 1 And C.Cells(1, "D").Value <> "" And C.Cells(1, "E").Value <> "" Then 'Site et Pièce Site ne sont pas vides
sFichier = RepertoireDestination & C.Cells(1, "D").Value & "\" & C.Cells(1, "E").Value & ".pdf" '>>>> la PJ, c'est sans extension, donc ajouter ".PDF" par exemple ?
' Debug.Print sFichier
' Debug.Print Dir(sFichier)
If Dir(sFichier) = "" Then
S = S & vbLf & sFichier
Else
.Attachments.Add (sFichier)
End If
End If
Next
'If s <> "" Then MsgBox "erreur, fichier(s) n'existe(nt) pas" & vbLf & Mid(s, 2), vbCritical, Tableau.Cells(i, "A").Value
'.Send 'or use .Display
End With
Set Rng = Nothing
Set OutMail = Nothing
Tableau.AutoFilter
End If
Next I
GoTo Fin
Fin:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set ShA = Nothing: Set Dict = Nothing: Set Tableau = Nothing
'Effacer les variables objet
Set OutApp = Nothing
End Sub