Bug 1004 Erreur définie par l'application ou l'objet
Bonjour
J'ai un problème avec ma macro.
Elle fait tous mes tests mes à un moment le message d'erreur 1004 s'affiche
Avec erreur définie par l'application ou l'objet.
Je ne comprends pas ce qu'il y a de mal fait.
Je voulais que dans mon code il bloque toute création de mail si l'adresse mail ou le nom de la personne n'existe pas dans l'onglet mapping.
J'ai donc mis une fonction If, qui bloque si les conditions ne sont pas respectées mais par quand elles sont respectées la macro ne continue pas ;(
Help please
Le code qui bloque ci-dessous et le fichier joint
Sub Mail_Every_Worksheet()
'Working in Excel 2000-2016
'For Tips see:
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
'Sauvegare la nouvelle classeur; envoie l'email; efface le classeur créé
TempFilePath = Environ$("temp") & "\"
'Determine la version Excel et le type de fichier/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
'Determine la valeur en cellule B1 si correct pour le mailling
For Each sh In ThisWorkbook.Worksheets
If Application.WorksheetFunction.VLookup(sh.Range("B1").Value, ThisWorkbook.Sheets("Mapping").Range("A1:D20"), 4, False) Like "" Then
MsgBox "Tab " & sh.Name & " incorrect " & vbLf & _
"Possible error :" & vbLf & _
"1) Username not fill out in the mapping tab." & vbLf & _
"2) Email not fill out in the mapping tab" & vbLf & _
" Please correct and try again. "
Exit Sub
ElseIf Application.WorksheetFunction.VLookup(sh.Range("B1").Value, ThisWorkbook.Sheets("Mapping").Range("A1:D20"), 4, False) Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
'Nom du fichier à envoyer
TempFileName = "Réception PO " & Format(Now, "dd-mmm-yy")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
'Destinataire du mail
.to = Application.WorksheetFunction.VLookup(sh.Range("B1").Value, ThisWorkbook.Sheets("Mapping").Range("A1:D20"), 4, False)
'Mettre quelqu'un en copie
.CC = ""
.BCC = ""
'Choisir l'objet du mail
.Subject = "Relance MIGO"
.BodyFormat = olFormatHTML
'Corps du texte
'<br /> : saut de ligne
'<b>WORD</b> : Mettre un mot en gras
'<U>WORD</U> : Sousligner un mot
'<FONT COLOR=COLOR>WORD</FONT>= Mettre un mot en couleur en remplacant =COLOR par la couleur voulue
.HTMLBody = "<HTML><body>Bonjour,<br /><br />" & _
"Voici le détail de vos commandes non réceptionnées et/ou non validées avec une date de réception sur le mois en cours. Pouvez-vous les faire valider et les réceptionner au plus vite SVP ?<br />" & _
"<FONT COLOR=RED><b><u>Deadline : Dernier jour ouvré du mois en cours au plus tard.</u></b></FONT><br /><br />" & _
"<b><u>Rappel 1 :</u></b> la prestation est à réceptionner que si elle a été réalisée. Si elle n'a pas encore été réalisée, il faut décaler la date de réception et ne pas réceptionner la commande.<br /><br />" & _
"<b><u>Rappel 2 :</u></b> La <b>ligne et la marque</b> doivent être <b>obligatoirement saisies</b> dans les PO.<br />" & _
"Merci de modifier vos PO et de rajouter la ligne et la marque, SVP. Pour que la marque se renseigne, il faut d'abord renseigner la ligne, faire Entrée et la marque se dérivera automatiquement<br /><br />" & _
"Je reste à votre disposition pour tous compléments d'informations.<br /><br />" & _
"Cordialement,<br /><br /><br /><br />" & _
"Hello everyone,<br /><br />" & _
"Kind reminder, there's still non validated and non receipt PO on February. See the extraction attached.<br />" & _
"Can you please make the necessary with your team to validate and receipt or postpone <FONT COLOR=RED><b>ASAP ?</b></FONT><br /><br />" & _
"<b><u>Recall n°1 :</u></b> The service is to be <FONT COLOR=RED>receipt only if it has been carried out</FONT>. If it has not been done yet, it is necessary to postpone the date of reception and not to receive the order.<br />" & _
"<FONT COLOR=RED><b><u>Deadline : ASAP</u></b></FONT><br /><br />" & _
"<b><u>Recall n°2 :</u></b> The line and the brand must be entered in POs. There's still PO's without brand and line.<br /><br />" & _
"If you have any questions don't hesitate to come back to me,<br /><br />" & _
"Regards,"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt").Send
'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Set OutMail = Nothing
'Efface le fichier que vous avez envoyé
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'Une boite de dialogue pour confirmer que l'email a bel et bien été envoyé
MsgBox Application.UserName & "," & vbCr & "Ce classeur: " & ", a été envoyée par email.", _
vbOKOnly + vbInformation, ActiveWorkbook.Name & " - Envoie d'email"
End Sub
Bonjour,
as-tu ajouté la référence à Outlook ?
C'est à dire ?
Ça fonctionnait très bien avant que j'ajoute mon "if"
Je pense qu'elle y est
regarde ici: https://www.rondebruin.nl/win/s1/outlook/account.htm
1) Go to the VBA editor, Alt -F11
2) Tools>References in the Menu bar
3) Place a Checkmark before Microsoft Outlook ? Object Library
re,
aussi remplace ElseIf par Else