Re : commandbutton pour envoyer userform sur outlook ?
Bonjour Le Forum
, Bonjour Martial
,
Ca fonctionne nickel mais quand je vœux répéter la macro de Yaloo dans un autre userform ca plante
je colle ci-dessous la macro de Martial qui fonctionne bien pour l'userform3 et en dessous la même macro adaptée pour l'userform9 qui plante toujours au même endroit :
Private Sub CommandButton2_Click()
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
Dim Ws As Worksheet, F4
Dim OutApp As Object, OutMail As Object
Dim Debut$, Fin$, i&
F4 = Array("C2", "C3", "C4", "C5", "C6", "C7", "C8", "C9", "C10", "C11", "C12", "C13", "C14", "C15", "C16", "C17", "C18", "C19", "C20")
For i = 1 To 19
Feuil18.Range(F4(i)) = Controls("TextBox" & i)
Next
Feuil18.Copy
ActiveWorkbook.SaveAs "D:\Anomalie.xlsx"
ActiveWorkbook.Close
'Envoi Mail
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
Debut = "Messieurs, <BR><BR><BR>Veuillez trouver en pièce jointe un rapport d'anomalie,<BR><BR>"
Fin = "<BR> <BR> <BR> <BR>Cordialement. <BR> <BR> <BR>Service de sécurité et de protection incendie <BR> <BR>ASC <BR> <BR>(Message automatique)"
On Error Resume Next
With OutMail
.To = "T@ing.com"
.CC = "ch@rite.fr;" & _
"g@live.fr"
.Subject = "Rapport d'anomalie N°" & TextBox4 & " Daté du " & TextBox1
.Attachments.Add "D:\Anomalie.xlsx"
.HTMLBody = Debut & Fin
.Display 'pour voir
'.Send 'pour envoyer directement
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
'Suppression du fichier image JPG
Kill "D:\Anomalie.xlsx"
'Suppression des données en Feuil4
For i = 1 To 19
Feuil18.Range(F4(i)) = ""
Next
Unload Me
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
End Sub
Private Sub CommandButton3_Click()
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
Dim Ws As Worksheet, F4
Dim OutApp As Object, OutMail As Object
Dim Debut$, Fin$, i&
F4 = Array("C2", "C3", "C4", "C5", "C6", "C7", "C8", "C9", "C10", "C11", "C12", "C13", "C14", "C15", "C16", "C17", "C18", "C19", "C20")
For i = 1 To 19
Feuil18.Range(F4(i)) = Controls("TextBox" & i)
Next
Feuil18.Copy
ActiveWorkbook.SaveAs "D:\Anomalie.xlsx"
ActiveWorkbook.Close
'Envoi Mail
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
Debut = "Madame lidieu, <BR><BR><BR>Veuillez trouver en pièce jointe un rapport d'anomalie,<BR><BR>"
Fin = "<BR> <BR> <BR> <BR>Cordialement. <BR> <BR> <BR>Service de sécurité et de protection incendie <BR> <BR>ASC <BR> <BR>(Message automatique)"
On Error Resume Next
With OutMail
.To = "lidieu@ra.com"
.CC = "h@rite.fr;" & _
"g@live.fr"
.Subject = "Rapport d'anomalie N°" & TextBox4 & " Daté du " & TextBox1
.Attachments.Add "D:\Anomalie.xlsx"
.HTMLBody = Debut & Fin
.Display 'pour voir
'.Send 'pour envoyer directement
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
'Suppression du fichier image JPG
Kill "D:\Anomalie.xlsx"
'Suppression des données en Feuil4
For i = 1 To 19
Feuil18.Range(F4(i)) = ""
Next
Unload Me
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
End Sub
Macro sur userform 9 qui plante:
Private Sub CommandButton2_Click()
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
Dim Ws As Worksheet, F19
Dim OutApp As Object, OutMail As Object
Dim Debut$, Fin$, i&
F19 = Array("C2", "C3", "C4", "C5", "C6", "C7", "C8", "C9", "C10", "C11", "C12", "C13", "C14", "C15", "C16", "C17", "C18", "C19", "C20", "C21")
For i = 1 To 20
Feuil19.Range(F19(i)) = Controls("TextBox" & i) = Erreur l'indice n'appartient pas à la sélection
Next
Feuil19.Copy
ActiveWorkbook.SaveAs "D:\IPS.xlsx"
ActiveWorkbook.Close
'Envoi Mail
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
Debut = "Messieurs, <BR><BR><BR>Veuillez trouver en pièce jointe un rapport d'anomalie,<BR><BR>"
Fin = "<BR> <BR> <BR> <BR>Cordialement. <BR> <BR> <BR>Service de sécurité et de protection incendie <BR> <BR>ASC <BR> <BR>(Message automatique)"
On Error Resume Next
With OutMail
.To = "MT@ing.com"
.CC = "h@rite.fr;" & _
"g@live.fr"
.Subject = "Facteur IPS Daté du " & TextBox1
.Attachments.Add "D:\IPS.xlsx"
.HTMLBody = Debut & Fin
.Display 'pour voir
'.Send 'pour envoyer directement
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
'Suppression du fichier image JPG
Kill "C:\IPS.xlsx"
'Suppression des données en Feuil19
For i = 1 To 20
Feuil19.Range(F19(i)) = ""
Next
Unload Me
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
End Sub
Private Sub CommandButton3_Click()
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
Dim Ws As Worksheet, F19
Dim OutApp As Object, OutMail As Object
Dim Debut$, Fin$, i&
F19 = Array("C2", "C3", "C4", "C5", "C6", "C7", "C8", "C9", "C10", "C11", "C12", "C13", "C14", "C15", "C16", "C17", "C18", "C19", "C20", "C21")
For i = 1 To 20
Feuil19.Range(F19(i)) = Controls("TextBox" & i)
Next
Feuil19.Copy
ActiveWorkbook.SaveAs "D:\IPS_rapport.xlsx"
ActiveWorkbook.Close
'Envoi Mail
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
Debut = "Madame lidieu, <BR><BR><BR>Veuillez trouver en pièce jointe un rapport d'anomalie,<BR><BR>"
Fin = "<BR> <BR> <BR> <BR>Cordialement. <BR> <BR> <BR>Service de sécurité et de protection incendie <BR> <BR>ASC <BR> <BR>(Message automatique)"
On Error Resume Next
With OutMail
.To = "lidieu@ra.com"
.CC = "h@rite.fr;" & _
"g@live.fr"
.Subject = "IPS N°" & TextBox4 & " Daté du " & TextBox1
.Attachments.Add "D:\IPS.xlsx"
.HTMLBody = Debut & Fin
.Display 'pour voir
'.Send 'pour envoyer directement
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
'Suppression du fichier image JPG
Kill "D:\IPS_rapport.xlsx"
'Suppression des données en Feuil19
For i = 1 To 20
Feuil19.Range(F19(i)) = ""
Next
Unload Me
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
End Sub
Quelqu'un à une idée pour ca plante ?
Merci
