Cela marche parfaitement avec Outlook.Dans Outils/Références cocher OutLook
http://boisgontierjacques.free.fr/Code:Sub envoi_Feuille() répertoireAppli = ActiveWorkbook.Path Sheets("résultats").Copy Application.DisplayAlerts = False ActiveWorkbook.SaveAs répertoireAppli & "\Resultats.xls" ActiveWindow.Close '--- Envoi par mail Dim olapp As [COLOR="Red"]Outlook.Application[/COLOR] Sheets("destinataires").Select Range("A11").Select Do While Not IsEmpty(ActiveCell) Dim msg As MailItem Set olapp = New [COLOR="red"]Outlook.Application[/COLOR] Set msg = olapp.CreateItem(olMailItem) msg.To = ActiveCell.Value msg.Subject = Range("A2").Value msg.Body = Range("A5").Value & Chr(13) & Chr(13) & Range("A8").Value & Chr(13) & Chr(13) msg.Attachments.Add Source:=répertoireAppli & "\Resultats.xls" msg.Send ActiveCell.Offset(1, 0).Select Loop End Sub
Sub OutLookExpress()
'Initialisation des tableaux de touches pour Outlook Express
' Pour une pièce jointe
TouchesPJ(0) = 2 ' Nombre de touches nécessaires
TouchesPJ(1) = "%i" ' Appel du menu Insertion par la touche Alt-i
TouchesPJ(2) = "p" ' appel du sous-menu pièce par la touche p
' Pour l'envoi du mail
TouchesEnvoi(0) = 1 ' Nombre de touches nécessaires
TouchesEnvoi(1) = "%s" ' Envoi du message avec Alt-s
Sub Gmail()
' Pour une pièce jointe [COLOR="red"]'toujours introuvable[/COLOR]
TouchesPJ(0) = ' Nombre de touches nécessaires
TouchesPJ(1) = "" ' Appel du menu Insertion par la touche
' Pour l'envoi du mail
TouchesEnvoi(0) = 1 ' Nombre de touches nécessaires
TouchesEnvoi(1) = "[COLOR="Red"]jesaispascommentlecrire[/COLOR]" ' Envoi du message avec [COLOR="red"]Maj-Enter[/COLOR]
Quand tu parles d'utiliser GMail, tu veux dire passer par IE pour te connecter sur ton compte GMail et envoyer le mail ? Si c'est le cas, il va falloir créer par VBA une instance d'IE et faire de la simulation de touche, ce qui ne sera pas évident et en plus, la moindre modification de l'interface de GMail t'obligera à reprendre ta macro .Seulement voila, Gmail n'est pas du lot. Quelqu'un aurait'il dont les spécificités Gmail à nous faire partager ?
Sub envoigmail()
Const cdoSendUsingPickup = 1 [COLOR="green"]'Send message using the local SMTP service pickup directory.[/COLOR]
Const cdoSendUsingPort = 2 [COLOR="green"]'Send the message using the network (SMTP over the network).[/COLOR]
Const cdoAnonymous = 0 'Do not authenticate
Const cdoBasic = 1 'basic (clear-text) authentication
Const cdoNTLM = 2 'NTLM
Dim statut As Boolean
Dim destinataires As String
Dim sujet As String
Dim corps As String
reponse = MsgBox("Le mail sera directement envoyé. Etes-vous sûr de vouloir continuer ?", vbOKCancel + vbExclamation, "Avertissement")
If reponse = vbOK Then
Else
Exit Sub
End If
destinataires = Range("Feuil2!b11").Value
expediteur = Range("Feuil2!b23").Value
adresseexpediteur = Range("Feuil2!B26").Value
sujet = Range("Feuil2!b2").Value
corps = Range("Feuil2!b5").Value
On Error GoTo SMTPSendMail_Err
Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = sujet
objMessage.From = expediteur
objMessage.To = destinataires
objMessage.TextBody = corps
If Not IsMissing(pj) Then
objMessage.AddAttachment pj
End If
[COLOR="green"]'==This section provides the configuration information for the remote SMTP server.[/COLOR]
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
[COLOR="green"]'Name or IP of Remote SMTP Server[/COLOR]
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
[COLOR="green"]' Type of authentication, NONE, Basic (Base64 encoded), NTLM[/COLOR]
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
[COLOR="green"]'Your UserID on the SMTP server[/COLOR]
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusername") = InputBox("Veuillez saisir votre identifiant (imap)")
[COLOR="green"]'Your password on the SMTP server[/COLOR]
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendpassword") = InputBox("Veuillez saisir votre mot de passe gmail (imap)")
[COLOR="green"]'Server port (typically 25)[/COLOR]
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = [COLOR="Purple"]HIDDEN[/COLOR]
[COLOR="green"]'Use SSL for the connection (False or True)[/COLOR]
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
[COLOR="green"]'Connection Timeout in seconds (the maximum time CDO will try to establish a connection to the SMTP server)[/COLOR]
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
objMessage.Configuration.Fields.Update
[COLOR="Green"]'==End remote SMTP server configuration section==[/COLOR]
objMessage.Send
'Next i
succes = MsgBox(nbmessages & " envoyés avec succès !", vbInformation)
Exit Sub
SMTPSendMail_Err:
'Gestion des erreurs
tmp = MsgBox("Erreur lors de l'envoi de votre message." & Chr(10) & "Détails : " & Err.Description, vbCritical)
End Sub
Erreur lors de l'envoi de votre message.
Détails: Le message n'a pu être envoyé vers le serveur SMTP. Le code d'erreur de transport était 0x80040217. La réponse du serveur était not available.
Dim statut As Boolean
Dim destinataires As String
Dim sujet As String
Dim corps As String
Dim pj As String
Dim expediteur As String
reponse = MsgBox("Le mail sera directement envoyé. Etes-vous sûr de vouloir continuer ?", vbOKCancel + vbExclamation, "Avertissement")
If reponse = vbOK Then
Else
Exit Sub
End If
destinataires = "exempleD@gmail.com"
expediteur = "Dupont"
adresseexpediteur = "exempleE@gmail.com"
sujet = "hello world"
corps = "hello guil how re ya"
On Error GoTo SMTPSendMail_Err
Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = sujet
objMessage.From = expediteur
objMessage.To = destinataires
objMessage.TextBody = corps
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusername") = InputBox("Veuillez saisir votre identifiant")
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendpassword") = InputBox("Veuillez saisir votre mot de passe gmail")
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
objMessage.Configuration.Fields.Update
objMessage.Send
succes = MsgBox(" envoyés avec succès !", vbInformation)
Exit Sub
SMTPSendMail_Err:
'Gestion des erreurs
tmp = MsgBox("Erreur lors de l'envoi de votre message." & Chr(10) & "Détails : " & Err.Description, vbCritical)
End Sub
Aidez moi et je donnerai le code final promis
Attention passage en mod pro.
Mes chers experts Excel
quelqu'un aurait'il l'amabilité de me donner un lien pertinent ?
Public Sub SendMailCDO()
Dim D As String
Dim E As String
Dim S As String
Dim T As String
Dim pj As String
D = Range("B31").Value
E = Range("B26").Value
S = Range("B2").Value
T = Range("B5").Value & Chr(10) & Chr(10) & Range("B8").Value
' pj = Range("B20").Value
Dim Cdo_Message As New CDO.Message
Set Cdo_Message.Configuration = GetSMTPServerConfig()
With Cdo_Message
.To = D
.From = E
.Subject = S
.TextBody = T
' If Not IsMissing(pj) Then
' .AddAttachment pj
' End If
.send
End With
success = MsgBox(nbmessages & " envoyés avec succès !", vbInformation)
Exit Sub
SMTPSendMail_Err:
'Gestion des erreurs
tmp = MsgBox("Erreur lors de l'envoi de votre message." & Chr(10) & "Détails : " & Err.Description, vbCritical)
End Sub
=GAUCHE(SI(B11="";"";B11&";")&SI(B12="";"";B12&";")&SI(B13="";"";B13&";")&SI(B14="";"";B14&";")&SI(B15="";"";B15&";")&SI(B16="";"";B16&";")&SI(B17="";"";B17&";");NBCAR(SI(B11="";"";B11&";")&SI(B12="";"";B12&";")&SI(B13="";"";B13&";")&SI(B14="";"";B14&";")&SI(B15="";"";B15&";")&SI(B16="";"";B16&";")&SI(B17="";"";B17&";"))-1)
Function GetSMTPServerConfig() As Object
Dim Cdo_Config As New CDO.Configuration
Dim Cdo_Fields As Object
Set Cdo_Fields = Cdo_Config.Fields
With Cdo_Fields
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = "smtp.gmail.com"
.Item(cdoSMTPServerPort) = 465
.Item(cdoSendUserName) = InputBox("Veuillez saisir votre identifiant")
.Item(cdoSendPassword) = InputBox("Veuillez saisir votre mot de passe gmail")
.Item(cdoSMTPAuthenticate) = cdoBasic
.Item(cdoSMTPUseSSL) = True
.Update
End With
Set GetSMTPServerConfig = Cdo_Config
Set Cdo_Config = Nothing
Set Cdo_Fields = Nothing
End Function
Workbooks("C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille & ".xls")[COLOR="Red"].Erase[/COLOR]
j'aurai besoin de savoir quelle est la méthode afin de supprimer un classeur.
Kill "C:\Documents and Settings\user\Mes documents\" & NomDeLaFeuille & ".xls"