
| auteurs : SilkyRoad, Random, cavo789 |
Si vous disposez d'Excel2002, ou ultérieur:
Vba |
Sub envoiPlageCellules_Excel2002 ()
ActiveSheet. Range (" A1:B5 " ). Select
ActiveWorkbook. EnvelopeVisible = True
With ActiveSheet. MailEnvelope
. Introduction = " bonjour , ci joint les données ... "
. Item . To = " destinataire@dvp.fr "
. Item . Subject = " le sujet "
. Item . Send
End With
End Sub
|
Sinon, vous pouvez utiliser:
Vba |
Sub PlageDeCellulesDansCorpsDuMessage ()
Dim iMsg As Object, iConf As Object
Dim strHTML As String
Dim i As Byte, j As Byte
Set iMsg = CreateObject (" CDO.Message " )
Set iConf = CreateObject (" CDO.Configuration " )
strHTML = " "
strHTML = strHTML & " <HEAD> "
strHTML = strHTML & " <BODY> "
strHTML = strHTML & " Bonjour , <BR>vous trouverez ci joint le tableau demandé<BR><BR> "
strHTML = strHTML & " <B><SPAN STYLE='background-color:green;font-size:6mm'>Résultats : </SPAN></B><BR><BR> "
strHTML = strHTML & " <TABLE BORDER> "
For i = 1 To 5
strHTML = strHTML & " <TR halign='middle'nowrap> "
For j = 1 To 2
strHTML = strHTML & " <TD bgcolor='yellow'align='center'><FONT COLOR='blue'SIZE=3> " _
& Cells (i, j) & " </FONT></TD> "
Next j
strHTML = strHTML & " </TR> "
Next i
strHTML = strHTML & " </TABLE> "
strHTML = strHTML & " <BR><BR>Cordialement<BR> " & Environ (" username " )
strHTML = strHTML & " </BODY> "
strHTML = strHTML & " "
With iMsg
Set . Configuration = iConf
. To = " destinataire@dvp.fr "
. Subject = " Test Envoi Tableau par mail "
. HTMLBody = strHTML
. Send
End With
End Sub
|
La fonction suivante permet la mise forme d'une plage de cellules dans la chaîne de caractères, pour ensuite
l'insérer dans le corps du message:
Vba |
Function corps (x As Range) As Variant
Dim ligne As Integer
Dim col As Integer
Dim moncorps As Variant
ligne = x. Rows . Count
col = x. Columns . Count
For ligne = 1 To x. Rows . Count
For col = 1 To x. Columns . Count
moncorps = moncorps & " " & x. Cells (ligne, col)
Next col
moncorps = moncorps & Chr (10 )
Next ligne
corps = moncorps
End Function
|
Ce code permet depuis Excel de sélectionner une plage de cellules dans une feuille et d'envoyer
cette plage vers un nouvel E-mail d'Outlook.
ATTENTION :
Ce code doit être placé dans un module d'Excel. Ne pas omettre de cocher la
référence 'Microsoft Outlook xx.x Object Library.
Vba |
Option Explicit
Public Function ReadFile (sFileName) As String
Dim fso As Object, fFile As Object
Dim sTemp As String
Set fso = CreateObject (" Scripting.FileSystemObject " )
Set fFile = fso. OpenTextFile (sFileName, 1 , False )
sTemp = fFile. ReadAll
fFile. Close
Set fFile = Nothing
ReadFile = sTemp
End Function
Sub PrepareOutlookMail (ByVal sFileName As String )
Dim appOutlook As Outlook. Application
Dim oMail As Outlook. MailItem
Set appOutlook = CreateObject (" Outlook.Application " )
If Not (appOutlook Is Nothing ) Then
Set oMail = appOutlook. CreateItem (olMailItem)
oMail. HTMLBody = ReadFile (sFileName)
oMail. Display
Set oMail = Nothing
Set appOutlook = Nothing
End If
End Sub
Sub SendRangeByMail ()
Dim rngeSend As Range
With Application
On Error Resume Next
Set rngeSend = . InputBox (Prompt:= " Please select range you wish to send. " , Type:= 8 , Default := . Selection . Address )
If rngeSend Is Nothing Then Exit Sub
On Error GoTo 0
. ActiveWorkbook . PublishObjects . Add (4 , " C:\Temp\XLRange.htm " , rngeSend. Parent . Name , rngeSend. Address , 0 , " " , " " ). Publish True
Call PrepareOutlookMail (" C:\Temp\XLRange.htm " )
Kill " C:\Temp\XLRange.htm "
End With
End Sub
|
|
| auteur : Kiki29 |
Via CDO, en cochant sous VBE Outils / Références "Microsoft CDO for Exchange xxxx Library".
A adapter à votre contexte, ici envoi de fichier Pdf:
Vba |
Sub Envoi_CDO1 ()
Dim CdoMessage As CDO. Message
Dim Fichier As Variant
ChDir " C:\Documents and Settings\UserName\Mes documents\PdfOut "
Fichier = Application. GetOpenFilename (" Fichiers PDF (*.pdf), *.pdf " )
If Fichier = False Then Exit Sub
Set CdoMessage = New CDO. Message
With CdoMessage
. Subject = " Exemple "
. From = " xxxxx@wanadoo.fr "
. To = " yyyyy@orange.fr "
. CC = " "
. BCC = " "
. TextBody = " Texte dans le corps de message "
. AddAttachment Fichier
. Send
End With
Set CdoMessage = Nothing
End Sub
|
Ou sans cocher de référence:
Vba |
Sub Envoi_CDO2 ()
Dim CdoMessage As Object
Dim Fichier As Variant
ChDir " C:\Documents and Settings\UserName\Mes documents\PdfOut "
Fichier = Application. GetOpenFilename (" Fichiers PDF (*.pdf), *.pdf " )
If Fichier = False Then Exit Sub
Set CdoMessage = CreateObject (" CDO.Message " )
With CdoMessage
. Subject = " Exemple "
. From = " xxxxx@wanadoo.fr "
. To = " yyyyy@orange.fr "
. CC = " "
. BCC = " "
. TextBody = " Texte dans le corps de message "
. AddAttachment Fichier
. Send
End With
Set CdoMessage = Nothing
End Sub
|
Pour envoyer la feuille active:
Vba |
Option Explicit
Sub Tst ()
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim Temp As String
Dim CdoMessage As Object
Dim Fichier As String
Set Sourcewb = ActiveWorkbook
ActiveSheet. Copy
Set Destwb = ActiveWorkbook
Temp = ThisWorkbook. Path & Application. PathSeparator & " Toto.xls "
With Application
. ScreenUpdating = False
. DisplayAlerts = False
End With
Destwb. SaveAs Temp
Fichier = Destwb. Path & Application. PathSeparator & Destwb. Name
Destwb. Close
Application. DisplayAlerts = True
Set CdoMessage = CreateObject (" CDO.Message " )
With CdoMessage
. Subject = " Exemple "
. From = " xxxxx@wanadoo.fr "
. To = " yyyyy@hotmail.fr "
. CC = " "
. BCC = " "
. TextBody = " Texte dans le corps de message "
. AddAttachment Fichier
. Send
End With
Application. ScreenUpdating = True
Set CdoMessage = Nothing
Kill Fichier
End Sub
|
Pour le classeur complet:
Vba |
Option Explicit
Sub Tst_Wb ()
Dim SourceWb As Workbook
Dim CdoMessage As Object
Dim Fichier As String
Set SourceWb = ActiveWorkbook
Fichier = ThisWorkbook. Path & Application. PathSeparator & " Toto.xls "
SourceWb. SaveCopyAs Fichier
Set CdoMessage = CreateObject (" CDO.Message " )
With CdoMessage
. Subject = " Exemple "
. From = " xxxxx@wanadoo.fr "
. To = " yyyyy@orange.fr "
. CC = " "
. BCC = " "
. TextBody = " Texte dans le corps de message "
. AddAttachment Fichier
. Send
End With
Set CdoMessage = Nothing
End Sub
|
On pourra dans ce cas envisager d'envoyer le Classeur complet sans le code VBA.
|
| auteur : SilkyRoad | Vba |
Sub CreationMailEtLienHypertexte ()
Dim OlApp As Outlook. Application
Dim OlItem As Outlook. MailItem
Set OlApp = New Outlook. Application
Set OlItem = OlApp. CreateItem (olMailItem)
With OlItem
. To = " NomPrenom@mail.fr "
. Subject = " Le titre du message "
. Body = " Découvrez Microsoft Office sur le site Developpez " & _
vbLf & " http://www.developpez.com " & vbLf & vbLf & _
" Cordialement " & vbLf & " mailto:emetteur@mail.fr "
. Display
. Save
. Send
End With
Set OlItem = Nothing
Set OlApp = Nothing
End Sub
|
Un autre exemple en utilisant la méthode CDO.
Vba |
Sub liensDansCorpsDuMessage_CDO ()
Dim iMsg As Object, iConf As Object
Dim strHTML As String
Set iMsg = CreateObject (" CDO.Message " )
Set iConf = CreateObject (" CDO.Configuration " )
strHTML = " "
strHTML = strHTML & " <HEAD> "
strHTML = strHTML & " <BODY> "
strHTML = strHTML & " Bonjour , <BR>Découvrez Microsoft Office sur le site Developpez<BR><BR> "
strHTML = strHTML & " <A href='http://www.developpez.com'>Cliquez ici.</A> "
strHTML = strHTML & " <BR><BR>Cordialement<BR> " & Environ (" UserName " ) & " <BR> "
strHTML = strHTML & " <A href=mailto:emetteur@mail.fr>Mon adresse mail</A> "
strHTML = strHTML & " </BODY> "
strHTML = strHTML & " "
With iMsg
Set . Configuration = iConf
. To = " NomPrenom@mail.fr "
. Subject = " Test Envoi liens par mail "
. HTMLBody = strHTML
. Send
End With
End Sub
|
|
| auteur : SilkyRoad |
La liste des destinataires doit être spécifiée sous forme de tableau. Vous pouvez aussi utiliser les listes de distribution.
Vba |
Sub EnvoiClasseur_MultiDestinataires ()
ActiveWorkbook. SendMail _
Recipients:= Array (" MaListeDeDistribution " , _
" AutreDestinataire01@mail.com " , " AutreDestinataire02@mail.com " ), _
Subject:= " Rapport hebdomadaire " & ActiveWorkbook. Name , _
ReturnReceipt:= True
End Sub
|
|
| auteur : SilkyRoad |
Les différentes adresses doivent être spécifiées dans un tableau Array:
Vba |
Dim MailTab As Variant
MailTab = Array (" mimi@test.fr " , " riri@test.fr " , " fifi@test.fr " )
Application. Dialogs (xlDialogSendMail). Show MailTab
|
|
| auteur : SilkyRoad | Vba |
Sub MailOutlookExpress ()
Dim Adresse As String , Sujet As String , Texte As String
Adresse = " Destinataire01@mail.fr;Destinataire02@mail.fr "
Sujet = " Le sujet "
Texte = " Bonjour, " & vbCrLf & vbCrLf _
& " Vous trouverez ci joint les infos demandées " & vbCrLf & vbCrLf & _
" Cordialement " & vbCrLf & Environ (" UserName " )
Shell " C:\Program Files\Outlook Express\msimn.exe " & " /mailurl:mailto: " & _
Adresse & " ?subject= " & Sujet & " &Body= " & Texte
End Sub
|
|
| auteur : SilkyRoad |
Cet exemple (testé avec Office 2007) extrait la liste des contacts Outlook et toutes leurs propriétés.
Nécessite d'activer la référence "Microsoft Outlook xx.x Object Library".
Dans l'éditeur de macros:
Menu Outils
Références
Vba |
Sub ExtraireContactsOutlook ()
Dim olApp As Outlook. Application
Dim dossierContacts As Outlook. MAPIFolder
Dim Contact As Outlook. ContactItem
Dim i As Integer, j As Integer
Set olApp = New Outlook. Application
Set dossierContacts = olApp. GetNamespace (" MAPI " ). GetDefaultFolder (olFolderContacts)
If dossierContacts. Items . Count = 0 Then Exit Sub
j = 1
For i = 0 To dossierContacts. Items (1 ). ItemProperties . Count - 1
Cells (j, i + 1 ) = dossierContacts. Items (1 ). ItemProperties . Item (i). Name
Next i
On Error Resume Next
For Each Contact In dossierContacts. Items
j = j + 1
For i = 0 To Contact. ItemProperties . Count - 1
Cells (j, i + 1 ) = Contact. ItemProperties . Item (i). Value
Next i
Next Contact
Columns. AutoFit
MsgBox " Opération terminée. "
End Sub
|
Pour récupérer quelques informations spécifiques, utilisez la procédure suivante.
(Exemple: extraire les numéros de téléphone)
Vba |
Sub numeroTelephone_contactsOutlook ()
Dim olApp As Outlook. Application
Dim Cible As Outlook. ContactItem
Dim dossierContacts As Outlook. MAPIFolder
Set olApp = New Outlook. Application
Set dossierContacts = olApp. GetNamespace (" MAPI " ). GetDefaultFolder (olFolderContacts)
For Each Cible In dossierContacts. Items
Debug. Print Cible. HomeTelephoneNumber & vbTab & Cible. LastNameAndFirstName
Next
End Sub
|
|
| auteur : SilkyRoad | Vba |
Sub NouveauRDV_Calendrier ()
Dim OkApp As New Outlook. Application
Dim Rdv As Outlook. AppointmentItem
Set Rdv = OkApp. CreateItem (olAppointmentItem)
With Rdv
. MeetingStatus = olMeeting
. Subject = " le site DVP "
. Body = " ...description .... "
. Location = " sur le forum Office "
. Start = #10 / 20 / 2007 9 :30 :00 PM#
. Duration = 30
. Categories = " Amis "
. Save
End With
Set OkApp = Nothing
End Sub
|
|
| auteur : SilkyRoad | Vba |
Dim myOlApp As Outlook. Application
Dim myItem As Outlook. TaskItem
Set myOlApp = New Outlook. Application
Set myItem = myOlApp. CreateItem (olTaskItem)
With myItem
. Status = olTaskInProgress
. Importance = olImportanceHigh
. DueDate = DateValue (" 10/23/07 " )
. Body = " Rendez vous sur le forum "
. TotalWork = 40
. ActualWork = 20
. Subject = " le titre "
. Assign
. Recipients . Add (" leNom lePrenom " )
. Save
. Send
End With
|
|
Consultez les autres F.A.Q's
Les sources présentés sur cette pages sont libre de droits,
et vous pouvez les utiliser à votre convenance. Par contre cette page de présentation de ces sources constitue une oeuvre intellectuelle protégée par les droits d'auteurs.
Copyright ©2008
Developpez LLC. Tout droits réservés Developpez LLC.
Aucune reproduction, même partielle, ne peut être faite de ce site et de
l'ensemble de son contenu : textes, documents et images sans l'autorisation
expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à 3 ans
de prison et jusqu'à 300 000 E de dommages et intérets.
Cette page est déposée à la SACD.
|