Sub creationQuestionnaire_et_EnvoiMail()
Dim Cell As Range
Dim Wb As Workbook
Dim nomFichier As String
'------------
'necessite d'activer la reference Microsoft Outlook xx.x Object Library
'dans l'editeur de macros
'menu Outils
'references
'coches la ligne :'Microsoft Outlook xx.x Object Library'
'cliques sur OK pour valider
Dim Ol As New Outlook.Application
Dim olMail As MailItem
Application.ScreenUpdating = False
'creation du support pour les classeurs questionnaires
Sheets(Array('utilisateur FR', 'utilisateur GB')).Copy
Set Wb = ActiveWorkbook
'boucle sur les cellules de la colonne C dans la feuille 'liste utilisateur'
For Each Cell In ThisWorkbook.Sheets('liste utilisateur').Range('C2:C' _
& ThisWorkbook.Sheets('liste utilisateur').Range('C65536').End(xlUp).Row)
'adapter l'index des feuilles Sheets(1) et Sheets(2)
'en fonction de la position des noms d'onglet dans le classeur
With Wb
.Sheets(1).Name = Cell & ' FR'
.Sheets(2).Name = Cell & ' GB'
End With
nomFichier = 'C:\\' & Cell & '.xls'
'copie de sauvegarde des classeurs questionnaire
Wb.SaveCopyAs nomFichier
'-------- envoi mail ---------------------------
Set Ol = New Outlook.Application
Set olMail = Ol.CreateItem(olMailItem)
With olMail
.To = Cell.Offset(0, -1) 'recupere l'adresse mail dans la colonne B
.Subject = 'le questionnaire'
.Body = 'Bonjour ,' & vbLf & vbLf & 'Comme convenu , vous trouverez le questionnaire ' & _
'à remettre pour le 30/10/2005 au plus tard .' & vbLf & vbLf & 'Cordialement' & vbLf & 'mimi'
.Attachments.Add nomFichier 'pour joindre les classeurs questionnaires au message
.Send 'envoi message
End With
DoEvents
Kill nomFichier 'suppression des classeurs questionnaires apres l'envoi
Next
'fermeture sans sauvegarde du classeur qui a servi à creer les questionnaires
Wb.Close False
Application.ScreenUpdating = True
End Sub