Envoi automatisé de fichiers sous Outlook 2003

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