ShareVB
Messages postés
2676
Date d'inscription
vendredi 28 juin 2002
Statut
Membre
Dernière intervention
13 janvier 2016
26
17 sept. 2005 à 10:46
salut,
avec CDO, ça marche bien comme ça :
'CDO (Collaboration Data Objects) est une technologie de Microsoft
'pour développer rapidement des clients de messagerie windows
'renvoie un nom de fichier temporaire
Private Declare Function GetTempFileName Lib "kernel32.dll" Alias
"GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As
String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
'renvoie le chemin du dossier temporaire
Private Declare Function GetTempPath Lib "kernel32.dll" Alias
"GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String)
As Long
'envoi la feuille objSh par mail
'=================================================
'IN objSh : feuille à envoyer
'IN strTo : destinataire
'IN strFrom : émetteur du mail
'IN strSubject : sujet
'OPTIONAL IN strCC : carbon copy : copie à
'OPTIONAL IN strBCC : black carbon copy : copie cachée à
'renvoie 0 en cas de succès ou un numéro d'erreur
Public Function CDO_Send_Sheet_Body(objSh As Worksheet, _
strTo As String, strFrom As String, strSubject As String, _
Optional strCC As String "", Optional strBCC As String "") As Long
' Cet exemple utilise la liaison tardive (late binding),
' vous n'avez donc pas de référence à ajouter
' Vous devez être connecté pour envoyer un mail avec cet function
'gestion d'erreur
On Error GoTo Erreur
'un objet message
Dim iMsg As Object
'un objet configuration
Dim iConf As Object
'un nouveau message
Set iMsg = CreateObject("CDO.Message")
'une configuration de messagerie
Set iConf = CreateObject("CDO.Configuration")
'le message
'contenu HTML : format obligatoire pour envoyer une feuille proprement
SheetToHTML objSh, iMsg
With iMsg
'sa config messagerie
Set .Configuration = iConf
'destinataire
.To = strTo
'CC
.CC = strCC
'BCC
.BCC = strBCC
'émetteur
.From = strFrom
'sujet
.Subject = strSubject
'on envoie le message
.Send
End With
'on libère les instances d'objets
Set iMsg = Nothing
Set iConf = Nothing
'pas d'erreur
CDO_Send_Sheet_Body = 0
Exit Function
Erreur:
'si erreur
MsgBox Err.Description, vbCritical
'erreur
CDO_Send_Sheet_Body = Err.Number
End Function
'convertion d'une feuille en HTML
Private Function SheetToHTML(sh As Worksheet, message As Object) As String
'Function from Dick Kusleika his site
'http://www.dicks-clicks.com/excel/sheettohtml.htm
'Changed by Ron de Bruin 04-Nov-2003
'Changed by ShareVB 28-Mai-2005
Dim TempFile As String
Dim Nwb As Workbook
'on copie la feuille
On Error GoTo SheetToHTML_Error
sh.Copy
'on récupère le classeur résultat
Set Nwb = ActiveWorkbook
'on génère un nom de fichier aléatoirement
TempFile = GetTempFile
'on enregistre le fichier en HTML
Nwb.SaveAs TempFile, xlHtml
'on ferme le classeur sans enregistrement pour gagner du temps
Nwb.Close False
'création du message HTML
message.CreateMHTMLBody ("file:\" & TempFile)
'on le supprime
Kill TempFile
On Error GoTo 0
Exit Function
SheetToHTML_Error:
MsgBox "Erreur " & Err.Number & " (" &
Err.Description & ") à la ligne " & Erl & " dans la
procédure SheetToHTML de Module modMail"
End Function
'renvoie un nom de fichier temporaire
Public Function GetTempFile() As String
Dim buff As String 'tampon pour les chaines
'on alloue de l'espace pour le chemin du dossier temporaire
On Error GoTo GetTempFile_Error
10 buff = Space(260)
'on demande ce chemin
20 GetTempPath 260, buff
'on supprime l'espace inutile
30 buff = Mid$(buff, 1, InStr(buff, vbNullChar) - 1)
'on alloue de l'espace pour le chemin et nom du fichier temporaire
40 GetTempFile = Space(260)
'on demande un nom de fichier temporaire
50 GetTempFileName buff, "cer", 0&, GetTempFile
'on supprime l'espace inutile
60 GetTempFile = Mid$(GetTempFile, 1, InStr(GetTempFile, vbNullChar) - 1)
'on supprime lme fichier créé par la fonction
70 Kill GetTempFile
'on remplace .tmp par .htm pour avoir le bon format
80 GetTempFile = Replace(GetTempFile, ".tmp", ".htm")
On Error GoTo 0
Exit Function
GetTempFile_Error:
MsgBox "Erreur " & Err.Number & " (" &
Err.Description & ") à la ligne " & Erl & " dans la
procédure GetTempFile de Module modMail"
End Function
ShareVB