Envoi automatisé de fichiers sous Outlook 2003

[hesiode23]

Bonjour à tous les forumeurs/euses,
Cela fait maintenant 1 an que je lis et que je progresse sur Excel grâce à ED, et j'ai toujours trouvé les réponses à mes questions dans des fils déjà crée.
Mais je bloque sur un problème depuis maintenant 2 semaines et je ne trouve pas de réponses malgré une recherche assidue.

Nous y voilà :
J'ai un fichier nommé "final" dans lequel j'ai un questionnaire (feuil "Form"), les réponses du futur répondant (feuil "Answ"), la feuille des "paramètres" (du même nom) et la feuille qui contiendra tous les noms et adresses de mes destinataires ("mails").

Je duplique le fichier "final", je l'enregistre au nom pioché dans la feuil "mails" du fichier "final" puis je supprime la feuill "mails" (du fichier nouvellement crée) : une fois cela fait, je souhaite que le fichier nouvellement crée soit inséré en pièce jointe d'un mail que j'enverrai à l'adresse mail correspondante à chacun de mes destinataires (eux mêmes toujours contenu dans la feuill "mails" de mon fichier "final", mais vous aviez compris!!! ). L'application sollicitée pour l'envoi des mails est Outlook 2003.

Or, tout marche comme sur des roulettes jusqu'à l'envoi de mon mail : en effet, j'ai utilisé la méthode sendkey pour simuler les touches, mais je l'ai fait initialement pour Outlook Express. Or, même en adaptant mes sendkey, cela ne fonctionne pas sur Outlook 2003:
1/ l'import du fichier texte (nommé "Corpsmail.txt") ne fonctionne pas (au lieu de cela, il vient en pj)
2/ le mail n'est pas envoyé
3/ le mail n'est pas rempli



Voiçi le code en entier (je vous laisse mes commentaires):

Sub QuestGx()
Suppr
GenerationQuestionnairesGeneraux
SendEmail
End Sub

Sub CopierEtEnvoyer()

Dim classeurActuel As Workbook
Dim nouveauClasseur As Workbook
Dim nomNouveauClasseur$
Dim repertoireSauv$ 'represente le chemin dans lequel je veux sauvegarder tes fichiers excel

'infos recuperees dans la feuille "mails"
Dim matricule$
Dim nomPers$
Dim mail$


Dim ligne As Integer 'numero de la ligne en cours de traitement
Dim nb As Integer 'nombre de fichiers traites

Dim feuilleASupprimer$ 'nom de l'onglet a supprimer dans les nouveaux classeurs


repertoireSauv = "D:\Documents and Settings\S592058\Desktop\Questionnaires généraux par destinataire"
'on teste ici si le dossier se termine par \ (sinon ca plante) si ce n'est pas le cas je le rajoute
If Strings.Right(repertoireSauv, 1) <> "\" Then
repertoireSauv = repertoireSauv & "\"
End If

Application.ScreenUpdating = False

On Error Resume Next
ChDir (repertoireSauv)
If Err <> 0 Then
MsgBox "Le repertoire " & repertoireSauv & " n'existe pas, il sera crée."
FileSystem.MkDir (repertoireSauv)
End If


' on initialise les variables
feuilleASupprimer = "mails"
ligne = 2
nb = 0

Sheets(feuilleASupprimer).Select

While ActiveSheet.Cells(ligne, 1) <> ""
matricule = ActiveWorkbook.ActiveSheet.Cells(ligne, 1)
nomPers = ActiveWorkbook.ActiveSheet.Cells(ligne, 2)
mail = ActiveWorkbook.ActiveSheet.Cells(ligne, 3)

nomNouveauClasseur = repertoireSauv & matricule & "_" & Strings.Replace(nomPers, " ", "") & ".xls"

Set classeurActuel = ThisWorkbook
classeurActuel.SaveCopyAs (nomNouveauClasseur)
Set nouveauClasseur = Workbooks.Open(nomNouveauClasseur)

For i = 1 To nouveauClasseur.Sheets.Count
If nouveauClasseur.Sheets(i).Name = feuilleASupprimer Then
'MsgBox "on supprime la feuile '" & nouveauClasseur.Sheets(i).Name & "' dans le classeur " & nomNouveauClasseur
Application.DisplayAlerts = False
nouveauClasseur.Sheets(i).Delete
GoTo Sauvegarde
Application.DisplayAlerts = False
End If
Next

Sauvegarde:

nouveauClasseur.Save
nouveauClasseur.Close True

' MsgBox "on envoie a " & mail & " le classeur " & nomNouveauClasseur
ligne = ligne + 1
nb = nb + 1

Wend

Application.ScreenUpdating = True

MsgBox "Traitement terminé : " & nb & " fichiers envoyés."

End Sub

Function SendEmail()
Dim Subj, repertoireSauv$, EmailAddr, Corps, HLink As String

i = 2
k = 2

While Not Feuil1.Cells(i, 1).Value = ""
While Feuil1.Cells(k + 1, 1).Value = Feuil1.Cells(i, 1).Value
k = k + 1
Wend

'-------------------------------------------------définir les données
Subj = "De la part d'XXXXXXXX : audit 2008"

EmailAddr = Feuil1.Cells(i, 3).Value

Corps = ThisWorkbook.Path & "\CorpsMail.txt"

'--------------------------------------------------Construire lien hypertexte
HLink = "mailto:" & EmailAddr & "?"
HLink = HLink & "subject=" & Subj

'--------------------------------------------------Transmettre le message
ActiveWorkbook.FollowHyperlink HLink

Emplacement2 = ThisWorkbook.Path & "\Questionnaires généraux par destinataire\" & Feuil1.Cells(i, 2).Value & ".xls"
Application.Wait (Now + TimeValue("0:00:01"))

SendKeys "%i", True
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "f", True
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys Emplacement2, True
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{enter}", True

'ATTENTION : le nombre de {Tab} dépend de la présence ou non de la ligne d'adresse Cci (copies cachées)
SendKeys "{Tab}{Tab}{Tab}{Tab}", True
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "%i", True
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "f", True
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys Corps, True
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "{enter}", True
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "^{s}", True
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "%{F4}", True
i = k + 1
k = k + 1


Wend
End Function




Je sais qu’Outlook 2003 me demandera à chaque fois l'autorisation d'envoyer, mais ce n'est pas grave si chacun des mails est bien généré automatiquement.

Si il y avait une âme charitable dans la communauté d'experts d'ED pour m'aider, je vous en serai fort reconnaissant..

1000 mercis d'avance à vous, j'en peux plus de cette macro...

Hesiode23

 

[mcj1997]

Re : Envoi automatisé de fichiers sous Outlook 2003

Merci, mais je voulais aussi avec la combobox afin de préselectionner des adresses.

Merci d'avance,

 

[Roland_M]

Re : Envoi automatisé de fichiers sous Outlook 2003

bonjour à tous

vu la demande j'ai fais vite fait ce matin un petit classeur qui peut être utile à certains !?
très clair et simple d'utilisation (surtout pour débutants)

Envoi de feuilles de données par Mail directement (procédé CDO) ou par Outlook express


Roland

Edit: j'avais oublié le fichier !

 

[hesiode23]

Re : Envoi automatisé de fichiers sous Outlook 2003

Messieurs, je vous remercie de vos nombreuses réponses et pardonnez le retard de ma réponse, cela ne m'a pas pris 2 minutes pour trouver la solution..

Un merci tout particulier à BERRACHED, Roland_M, tonton29610 et MikeBelgique. Vos fichiers m'ont été d'une grande aide.

Afin de cloturer ce fil (concernant mon problème tout du moins!!), je vous livre le code final (et qui bien entendu fonctionne) :

Sub QuestGx()
GenerationQuestionnairesGeneraux
SendEmail
End Sub

Function GenerationQuestionnairesGeneraux()

Dim classeurActuel As Workbook
Dim nouveauClasseur As Workbook
Dim nomNouveauClasseur$
Dim repertoireSauv$ 'chemin de sauvegarde

'infos recuperees dans la feuille "mails"
Dim matricule$
Dim nomPers$
Dim mail$


Dim ligne As Integer 'numero de la ligne en cours de traitement
Dim nb As Integer 'nombre de fichiers traites

Dim feuilleASupprimer$ 'nom de l'onglet a supprimer dans les nouveaux classeurs


repertoireSauv = "chemin"
'on teste ici si le dossier se termine par \ (sinon ca plante) si ce n'est pas le cas je le rajoute
If Strings.Right(repertoireSauv, 1) <> "\" Then
repertoireSauv = repertoireSauv & "\"
End If

Application.ScreenUpdating = False

On Error Resume Next
ChDir (repertoireSauv)
If Err <> 0 Then
MsgBox "Le repertoire " & repertoireSauv & " n'existe pas, il sera crée."
FileSystem.MkDir (repertoireSauv)
End If


' on initialise les variables
feuilleASupprimer = "mails"
ligne = 2
nb = 0

Sheets(feuilleASupprimer).Select

While ActiveSheet.Cells(ligne, 1) <> ""
matricule = ActiveWorkbook.ActiveSheet.Cells(ligne, 1)
nomPers = ActiveWorkbook.ActiveSheet.Cells(ligne, 2)
mail = ActiveWorkbook.ActiveSheet.Cells(ligne, 3)

nomNouveauClasseur = repertoireSauv & Feuil4.Cells(ligne, 2).Value & ".xls"

Sheets(Feuil1).Select
Feuil1.TextBox27.Value = nomPers
Sheets(feuilleASupprimer).Select

Set classeurActuel = ThisWorkbook
classeurActuel.SaveCopyAs (nomNouveauClasseur)
Set nouveauClasseur = Workbooks.Open(nomNouveauClasseur)

For i = 1 To nouveauClasseur.Sheets.Count
If nouveauClasseur.Sheets(i).Name = feuilleASupprimer Then
'MsgBox "on supprime la feuile '" & nouveauClasseur.Sheets(i).Name & "' dans le classeur " & nomNouveauClasseur
Application.DisplayAlerts = False
nouveauClasseur.Sheets(i).Delete
GoTo Sauvegarde
Application.DisplayAlerts = False
End If
Next

Sauvegarde:

nouveauClasseur.Save
nouveauClasseur.Close True

' MsgBox "on envoie a " & mail & " le classeur " & nomNouveauClasseur
ligne = ligne + 1
nb = nb + 1

Wend

Application.ScreenUpdating = True

MsgBox "Traitement terminé : " & nb & " fichiers envoyés."

End Function

Function SendEmail()
Dim Subj, Emplacement2, EmailAddr, Corps As String

Dim Appli As New Outlook.Application

Dim XMAIL As Outlook.MailItem

i = 2

While Not Feuil4.Cells(i, 1).Value = ""

Subj = "objet du mail"

EmailAddr = Feuil4.Cells(i, 3).Value

Corps = Feuil3.Cells(29, 2).Value

Emplacement2 = ThisWorkbook.Path & "\nom du dossier\" & Feuil4.Cells(i, 2).Value & ".xls"
Set XMAIL = Appli.CreateItem(olMailItem)

With XMAIL

.To = EmailAddr

.SentOnBehalfOfName = "prenom.nom@societe.fr"

.Subject = Subj

.Body = Corps

.Attachments.Add Emplacement2

.Send
End With
i = i + 1
Wend

End Function


Encore un grand merci à tous,
et longue vie à ED,
Cordialement,

Hesiode23