ENVOYER UN MAIL AU FORMAT HTML AVEC IMAGES INCORPORÉES DANS LE CORPS DU MESSAGE,

Signaler
Messages postés
490
Date d'inscription
dimanche 5 décembre 2004
Statut
Membre
Dernière intervention
6 avril 2009
-
Messages postés
7
Date d'inscription
lundi 1 mars 2004
Statut
Membre
Dernière intervention
16 mai 2013
-
Cette discussion concerne un article du site. Pour la consulter dans son contexte d'origine, cliquez sur le lien ci-dessous.

https://codes-sources.commentcamarche.net/source/55141-envoyer-un-mail-au-format-html-avec-images-incorporees-dans-le-corps-du-message-eventuellement-avec-pieces-jointes

Messages postés
7
Date d'inscription
lundi 1 mars 2004
Statut
Membre
Dernière intervention
16 mai 2013

Bonjour,

Comme l'a fait Cincap :
Vous pouvez supprimer la ligne : _BodyParse(HTMLFileName, RelatedBodyPart);
Ceci ne fait en fait que rajouter en pièces jointes les images du fichier html.
Ce n'est pas nécessairement utile.
Dans ce cas vous pouvez
- supprimer les 2 fonctions _BodyParse de l'unité U2007 et USendMail
- supprimer le type TRelatedBodyPart
- supprimer les lignes suivantes dans la fonction SendEMail:
> for Index := 0 to Length(RelatedBodyPart) - 1 do
> begin
> iMsg.AddRelatedBodyPart(
> RelatedBodyPart[Index, 0],
> RelatedBodyPart[Index, 1],
> cdoRefTypeId);
> end;

la fonction SendEmail sera alors comme ça :

function SendEmail(AddrTo: string; SendCfg: TSendCfg; SendMsg: TSendMsg): string;
{
Fonction simplifiée d'envoi de mail depuis un fournisseur standard (Free, sfr, orange etc.)
Envoi un mail au format html avec images en ligne et pièces jointes
Envoi sans authentification, sans nom d'utilisateur et sans mot de passe
L'envoi à partir de serveur smtp avec utilisateur et mot de passe type yahoo est possible
également, voir l'objet CDO sur le site Microsoft.
La fonction utilise l'objet OLE CDO.Message de Microsoft (OS mini: Windows 2000)
Plus d'info sur cette objet à l'adresse :
http://msdn.microsoft.com/en-us/library/ms527568(v=exchg.10).aspx
Paramètres :
AddrTo: adresse mail pour l'envoi
SendCfg: enregistrement de type TSendCfg
- SendCfg.AddrFrom: adresse mail de l'expéditeur (peut être: 'nom usuel')
- SendCfg.SMTPServer: nom du serveur smtp (ex: smtp.orange.fr)
- SendCfg.PrioriTy: Priorité du message (cdoLow, cdoNormal, cdoHight)
- SendCfg.MDNRequested: Spécifie si un accusé de lecture est demandé
SendMsg: enregistrement de type TSendMsg:
- SendMsg.Subject: Objet du message
- SendMsg.HTMLFileName: Nom complet du fichier html à envoyer
- SendMsg.Attachments: tableau contenant le nom complet des fichiers joints
A NOTER dans le fichier html l'attribut id est obligatoire et doit contenir un
identifiant unique pour cette image. Les délimiteurs pour la valeur
de l'attribut src doivent être des guillemets doubles et non pas simples.
}
const
CdoMailImportance = 'urn:schemas:httpmail:importance';
CdoHeaderXPriority = 'urn:schemas:mailheader:X-Priority';
CdoMailPriority = 'urn:schemas:httpmail:priority';
CdoConfiguration = 'http://schemas.microsoft.com/cdo/configuration/';
CdoSMTPServer = CdoConfiguration + 'smtpserver';
CdoSMTPServerPort = CdoConfiguration + 'smtpserverport';
CdoSMTPAuthenticate = CdoConfiguration + 'smtpauthenticate';
CdoSMTPUseSSL = CdoConfiguration + 'smtpusessl';
CdoSendUsing = CdoConfiguration + 'sendusing';
cdoSendUsingPort = 2;
cdoRefTypeId = 0;
cdoRefTypeLocation = 1;
CdoSuppressNone = 0;
CdoAnonymous = 0;
var
iMsg: OleVariant;
Index: Integer;
begin
Result := '';
with SendMsg do
if not (FileExists(HTMLFileName)) then
begin
Result := Format(ER_NOT_FILE_EXIST, [HTMLFileName]);;
Exit;
end;
{Instancie l'objet ole}
Imsg := CreateOleObject('CDO.Message');
with SendCfg, SendMsg do
try
iMsg.configuration.fields.item(CdoSMTPServer) := SMTPServer;
iMsg.configuration.fields.item(CdoSMTPServerPort) := SMTPServerPort;
iMsg.configuration.fields.item(CdoSendUsing) := cdoSendUsingPort;
iMsg.configuration.fields.item(CdoSMTPAuthenticate) := CdoAnonymous;
iMsg.configuration.fields.item(CdoSMTPUseSSL) := False;
iMsg.configuration.fields.Update;
iMsg.fields.item(CdoMailImportance) := PrioriTy;
if SendCfg.PrioriTy < cdoHigh then
iMsg.fields.item(CdoHeaderXPriority) := -1 else
iMsg.fields.item(CdoHeaderXPriority) := 0;
iMsg.fields.item(CdoMailPriority) := ord(PrioriTy) - 1;
iMsg.fields.Update;
iMsg.From := SendCfg.AddrFrom;
iMsg.To := AddrTo;
iMsg.Subject := Subject;
iMsg.MDNRequested := MDNRequested;
iMsg.CreateMHTMLBody(HTMLFileName, CdoSuppressNone);
for Index := 0 to High(Attachments) do
iMsg.AddAttachment(Attachments[Index]);
iMsg.Send;
except
on e: Exception do
Result := e.Message;
end;
{Libère la mémoire allouée à l'objet ole}
iMsg := VarNull;
end;

@+
jjgone
Messages postés
78
Date d'inscription
lundi 23 août 2004
Statut
Membre
Dernière intervention
19 novembre 2008

merci a vous !!
Messages postés
490
Date d'inscription
dimanche 5 décembre 2004
Statut
Membre
Dernière intervention
6 avril 2009
2
Bonjour à toutes et à tous,

Pour D6, voici la source modifiée unité par unité :

*********************

program SendMail;

uses
Forms,
UMain in 'UMain.pas' {Form1},
USendMail in 'USendMail.pas';

{$R *.res}

begin
Application.Initialize;
//Application.MainFormOnTaskbar := True;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

*************************
unit UMain;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls, ExtCtrls, Buttons, Grids,
OleCtrls, USendMail, SHDocVw_TLB;

type
TForm1 = class(TForm)
Label1: TLabel;
E_From: TEdit;
Label2: TLabel;
E_ISPName: TComboBox;
E_SMTPServer: TEdit;
Label3: TLabel;
Label4: TLabel;
E_SMTPServerPort: TEdit;
CB_MDNRequested: TCheckBox;
Label5: TLabel;
E_Priority: TComboBox;
Bevel1: TBevel;
Label7: TLabel;
E_To: TEdit;
Label6: TLabel;
E_Subject: TEdit;
Label8: TLabel;
E_Attachments: TEdit;
B_Attachments: TSpeedButton;
OpenDialog1: TOpenDialog;
Label9: TLabel;
E_HtmlFileName: TEdit;
B_HtmlFileName: TSpeedButton;
B_SendMail: TBitBtn;
B_Close: TBitBtn;
WebBrowser1: TWebBrowser;
B_Refresh: TSpeedButton;
B_Home: TSpeedButton;
B_GoBack: TSpeedButton;
B_GoForward: TSpeedButton;

function GetMDNRequested: Boolean;
function GetPriority: TCdoPriority;
function GetISPName: string;
function GetSMTPServer: string;
function GetServerPort: Word;
function GetFrom: string;
function GetTo: string;
function GetSubject: string;
function GetHtmlFileName: string;
function GetAttachments: TAttachments;

procedure SetSMTPServer(ISPName: string);

procedure B_HtmlFileNameClick(Sender: TObject);
procedure B_AttachmentsClick(Sender: TObject);
procedure B_CloseClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure E_ISPNameChange(Sender: TObject);
procedure E_SMTPServerPortKeyPress(Sender: TObject; var Key: Char);
procedure B_SendMailClick(Sender: TObject);
procedure B_RefreshClick(Sender: TObject);
procedure B_HomeClick(Sender: TObject);
procedure B_GoBackClick(Sender: TObject);
procedure B_GoForwardClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure WebBrowser1NavigateComplete2(ASender: TObject; const pDisp: IDispatch;
const URL: OleVariant);
private
{ Déclarations privées }
public
{ Déclarations publiques }
end;

var
Form1: TForm1;

implementation

Uses U2007;

var
HomeUrl: string;

{$R *.dfm}

function IsHtmlValid(url: string): Boolean;
{Renvoie True si url est un fichier html et qu'il est local}
var
Msg, ext: string;
begin
Msg := '';
ext := AnsiLowerCase(ExtractFileExt(url));
if Pos('http://', AnsiLowerCase(Url)) > 0 then
Msg := 'Le programme ne peut envoyer que des pages html locales.';
if Msg = '' then
if (ext <> '.html') and (ext <> '.htm') then
Msg := 'Le programme ne peut envoyer que des fichiers au format html';
Result :Msg '';
if not Result then
ShowMessage(Msg);
end;

function TForm1.GetMDNRequested: Boolean;
begin
Result := CB_MDNRequested.Checked;
end;

function TForm1.GetPriority: TCdoPriority;
begin
with E_Priority do
case ItemIndex of
0: Result := cdoHigh;
1: Result := cdoNormal
else Result := cdoLow;
end;
end;

function TForm1.GetISPName: string;
begin
with E_ISPName do
Result := Items[ItemIndex];
end;

function TForm1.GetSMTPServer: string;
begin
Result := Trim(E_SMTPServer.Text);
end;

function TForm1.GetServerPort: Word;
begin
{Retourne 25 si la zone est vide}
try
Result := StrToInt(E_SMTPServerPort.Text);
except
Result := 25;
end;
end;

function TForm1.GetFrom: string;
begin
Result := E_From.Text;
end;

function TForm1.GetTo: string;
begin
Result := E_To.Text;
end;

function TForm1.GetSubject: string;
begin
Result := E_Subject.Text;
end;

function TForm1.GetHtmlFileName: string;
begin
if E_HtmlFileName.Text <> '' then
Result := trim(E_HtmlFileName.Text)
else
Result := ExtractFilePath(Application.ExeName) + 'accueil.html';
end;

function TForm1.GetAttachments: TAttachments;
var
S: string;
AList: TStringList;
SepPos, Index: Integer;
begin
AList := TStringList.Create;
S := E_Attachments.Text;
try
while Length(S) > 0 do
begin
SepPos := Pos(';', S);
if SepPos > 1 then
{Ajoute la chaine située avant le ';' à la liste}
AList.Add(Copy(S, 1, SepPos - 1));
{Supprime la chaine jusqu'au ';'}
Delete(S, 1, SepPos);
end;
SetLength(Result, AList.Count);
for Index := 0 to AList.Count - 1 do
Result[Index] := AList[Index];
finally
AList.Free;
end;
end;

procedure TForm1.SetSMTPServer(ISPName: string);
var
SMTPServer: string;
begin
ISPName := LowerCase(ISPName);
if ISPName = 'alice' then SMTPServer := 'smtp.aliceadsl.fr' else
if ISPName = 'bouygues bbox' then SMTPServer := 'smtp.bbox.fr' else
if ISPName = 'cegetel' then SMTPServer := 'mail.sfr.fr' else
if ISPName = 'club internet' then SMTPServer := 'mail.sfr.fr' else
if ISPName = 'free' then SMTPServer := 'smtp.free.fr' else
if ISPName = 'neuf' then SMTPServer := 'mail.sfr.fr' else
if ISPName = 'orange' then SMTPServer := 'smtp.orange.fr' else
if ISPName = 'sfr' then SMTPServer := 'smtp.sfr.fr' else
SMTPServer := '';
E_SMTPServer.Text := SMTPServer;
end;

procedure TForm1.WebBrowser1NavigateComplete2(ASender: TObject; const pDisp:

IDispatch;
const URL: OleVariant);
begin
E_HtmlFileName.Text := URL;
end;

procedure TForm1.B_GoBackClick(Sender: TObject);
begin
try
WebBrowser1.GoBack;
except
{Une exception est levée s'il n'y a pas de page précédente, dans ce cas ne fait rien}
end;
end;

procedure TForm1.B_GoForwardClick(Sender: TObject);
begin
try
WebBrowser1.GoForward;
except
{Une exception est levée s'il n'y a pas de page suivante, dans ce cas ne fait rien}
end;
end;

procedure TForm1.B_CloseClick(Sender: TObject);
begin
Close;
end;

procedure TForm1.B_AttachmentsClick(Sender: TObject);
var
Index: Integer;
begin
with OpenDialog1 do
begin
Filter := 'Tous les fichiers(*.*)|*.*';
Options := Options + [ofAllowMultiSelect];
if not Execute then Exit;
for Index := 0 to Files.Count - 1 do
E_Attachments.Text := E_Attachments.Text + Files[Index] + ';';
end;
end;

procedure TForm1.B_HomeClick(Sender: TObject);
begin
WebBrowser1.Navigate(HomeUrl);
end;

procedure TForm1.B_HtmlFileNameClick(Sender: TObject);
begin
with OpenDialog1 do
begin
Options := Options - [ofAllowMultiSelect];
Filter := 'Fichiers html(*.htm, *.html)|*.htm;*.html';
if not Execute then Exit;
WebBrowser1.Navigate(FileName);
E_HtmlFileName.Text := FileName;
end;
end;

procedure TForm1.B_RefreshClick(Sender: TObject);
begin
WebBrowser1.Navigate(GetHtmlFileName);
end;

procedure TForm1.B_SendMailClick(Sender: TObject);
var
Msg, AddrTo: string;
SendCfg: TSendCfg;
SendMsg: TSendMsg;
WaitUrl, CurUrl: string;
begin
AddrTo := GetTo;
CurUrl := GetHtmlFileName;
if not IsHtmlValid(CurUrl) then Exit;
WaitUrl := ExtractFilePath(Application.ExeName) + 'waiting.html';
if FileExists(WaitUrl) then
WebBrowser1.Navigate(WaitUrl);
SendCfg := SetSendCfg(GetFrom, GetSMTPServer, GetServerPort, GetPriority,

GetMDNRequested);
SendMsg := SetSendMsg(GetSubject, CurUrl, GetAttachments);
Screen.Cursor := crHourGlass;
Msg := SendEmail(AddrTo, SendCfg, SendMsg);
Screen.Cursor := crDefault;
WebBrowser1.Navigate(CurUrl);
if Msg = '' then
ShowMessage('Le message a été envoyé')
else
MessageDlg(Msg, mtError, [mbOK], 0);
end;

procedure TForm1.E_ISPNameChange(Sender: TObject);
begin
with E_ISPName do
SetSMTPServer(Items[ItemIndex]);
end;

procedure TForm1.E_SMTPServerPortKeyPress(Sender: TObject; var Key: Char);
begin
if not CharInSet(Key, ['0'..'9', #8]) then Key := #0;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
OpenDialog1.InitialDir := ExtractFileDir(Application.ExeName);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
Height := Screen.WorkAreaHeight;
Top := Screen.WorkAreaTop;
Left := (Screen.WorkAreaWidth - Width) div 2;
with E_ISPName do
ItemIndex := Items.Count - 1;
HomeUrl := ExtractFilePath(Application.ExeName) + 'Accueil.html';
if FileExists(HomeUrl) then
begin
B_Home.Enabled := True;
WebBrowser1.Navigate(HomeUrl);
E_HtmlFileName.Text := HomeUrl;
end;
end;

initialization
{$IFDEF DEBUG}
ReportMemoryleaksOnSHutdown := True;
{$ENDIF}

end.

************************

unit USendMail;

interface

uses
Classes, SysUtils;

type
TRelatedBodyPart = array of array of string;
TAttachments = array of string;
TCdoPriority = (cdoLow, cdoNormal, cdoHigh);

TSendMsg = record
Subject: string;
HTMLFileName: string;
Attachments: TAttachments;
end;

TSendCfg = record
SMTPServer: string;
SMTPServerPort: Word;
AddrFrom: string;
PrioriTy: TCdoPriority;
MDNRequested: Boolean;
end;


function SetSendMsg(Subject, HtmlFileName: string; Attachments: TAttachments):

TSendMsg;
function SetSendCfg(AddrFrom, SMTPServer: string; SMTPServerPort: Word=25;
Priority: TCdoPriority=cdoNormal; MDNRequested: Boolean=False): TSendCfg;
function SendEmail(AddrTo: string; SendCfg: TSEndCfg; SendMsg: TSendMsg): string;

implementation

Uses
ComObj, U2007;

resourcestring
{Messages d'erreur}
ER_STREAM_NOT_ASSIGNED = 'Le flux à analyser n''est pas assigné.';
ER_STREAM_EMPTY = 'Le flux à analyser est vide';
ER_BAD_DELIMITER = 'La valeur de l''attribut "src" ou "id" d''une image est mal délimitée';
ER_BAD_DELIMITER_SRC = 'Le délimiteur de valeur pour l''attribut SRC doit être un

guillemet double.'
+ #$A#$D + 'Url de l''image en cause : %s';
ER_READ_ERROR = 'Une erreur s''est produite pendant la lecture du Flux';
ER_NOT_FILE_EXIST = 'Le fichier %s est introuvable.';

function GetFullPathName(FileName: string): string;
begin
{Si Filename est un chemin relatif, le converti en chemin complet}
Result := FileName;
try
if Copy(Result, 2, 1) <> ':' then
Result := ExpandFileName(FileName);
except
end;
end;



function SetSendMsg(Subject, HtmlFileName: string; Attachments: TAttachments):

TSendMsg;
begin
{Retourne un enregistrement de type TSendMsg}
Result.Subject := Subject;
Result.HTMLFileName := HtmlFileName;
Result.Attachments := Attachments;
end;

function SetSendCfg(AddrFrom, SMTPServer: string; SMTPServerPort: Word;
Priority: TCdoPriority; MDNRequested: Boolean): TSendCfg;
begin
{Retourne un enregistrement de type TSendCfg}
Result.AddrFrom := AddrFrom;
Result.SMTPServer := SMTPServer;
Result.SMTPServerPort := SMTPServerPort;
Result.PrioriTy := Priority;
Result.MDNRequested := MDNRequested;
end;

function SendEmail(AddrTo: string; SendCfg: TSendCfg; SendMsg: TSendMsg): string;
{
Fonction simplifiée d'envoi de mail depuis un fournisseur standard (Free, sfr, orange etc.)
Envoi un mail au format html avec images en ligne et pièces jointes
Envoi sans authentification, sans nom d'utilisateur et sans mot de passe
L'envoi à partir de serveur smtp avec utilisateur et mot de passe type yahoo est possible
également, voir l'objet CDO sur le site Microsoft.
La fonction utilise l'objet OLE CDO.Message de Microsoft (OS mini: Windows 2000)
Plus d'info sur cette objet à l'adresse :
http://msdn.microsoft.com/en-us/library/ms527568(v=exchg.10).aspx
Paramètres :
AddrTo: adresse mail pour l'envoi
SendCfg: enregistrement de type TSendCfg
- SendCfg.AddrFrom: adresse mail de l'expéditeur (peut être: 'nom

usuel')
- SendCfg.SMTPServer: nom du serveur smtp (ex: smtp.orange.fr)
- SendCfg.PrioriTy: Priorité du message (cdoLow, cdoNormal, cdoHight)
- SendCfg.MDNRequested: Spécifie si un accusé de lecture est demandé
SendMsg: enregistrement de type TSendMsg:
- SendMsg.Subject: Objet du message
- SendMsg.HTMLFileName: Nom complet du fichier html à envoyer
- SendMsg.Attachments: tableau contenant le nom complet des fichiers joints
- SendMsg.RelatedBodyParts: tableau de chaines contenant les médias inclus
dans le fichier html
Sous la forme : nom du fichier|identification de la ressource
ex.: donne : c:\image.jpg|id001
A NOTER dans le fichier html l'attribut id est obligatoire et doit contenir un
identifiant unique pour cette image. Les délimiteurs pour la valeur
de l'attribut src doivent être des guillemets doubles et non pas simples.
}
const
CdoMailImportance = 'urn:schemas:httpmail:importance';
CdoHeaderXPriority = 'urn:schemas:mailheader:X-Priority';
CdoMailPriority = 'urn:schemas:httpmail:priority';
CdoConfiguration = 'http://schemas.microsoft.com/cdo/configuration/';
CdoSMTPServer = CdoConfiguration + 'smtpserver';
CdoSMTPServerPort = CdoConfiguration + 'smtpserverport';
CdoSMTPAuthenticate = CdoConfiguration + 'smtpauthenticate';
CdoSMTPUseSSL = CdoConfiguration + 'smtpusessl';
CdoSendUsing = CdoConfiguration + 'sendusing';
cdoSendUsingPort = 2;
cdoRefTypeId = 0;
cdoRefTypeLocation = 1;
CdoSuppressNone = 0;
CdoAnonymous = 0;
var
iMsg: OleVariant;
Index: Integer;
RelatedBodyPart: TRelatedBodyPart;
begin
Result := '';
with SendMsg do
if not (FileExists(HTMLFileName)) then
begin
Result := Format(ER_NOT_FILE_EXIST, [HTMLFileName]);;
Exit;
end else
// _BodyParse(HTMLFileName, RelatedBodyPart);
{Instancie l'objet ole}
Imsg := CreateOleObject('CDO.Message');
with SendCfg, SendMsg do
try
iMsg.configuration.fields.item(CdoSMTPServer) := SMTPServer;
iMsg.configuration.fields.item(CdoSMTPServerPort) := SMTPServerPort;
iMsg.configuration.fields.item(CdoSendUsing) := cdoSendUsingPort;
iMsg.configuration.fields.item(CdoSMTPAuthenticate) := CdoAnonymous;
iMsg.configuration.fields.item(CdoSMTPUseSSL) := False;
iMsg.configuration.fields.Update;
iMsg.fields.item(CdoMailImportance) := PrioriTy;
if SendCfg.PrioriTy < cdoHigh then
iMsg.fields.item(CdoHeaderXPriority) := -1 else
iMsg.fields.item(CdoHeaderXPriority) := 0;
iMsg.fields.item(CdoMailPriority) := ord(PrioriTy) - 1;
iMsg.fields.Update;
iMsg.From := SendCfg.AddrFrom;
iMsg.To := AddrTo;
iMsg.Subject := Subject;
iMsg.MDNRequested := MDNRequested;
iMsg.CreateMHTMLBody(HTMLFileName, CdoSuppressNone);
for Index := 0 to Length(RelatedBodyPart) - 1 do
begin
iMsg.AddRelatedBodyPart(
RelatedBodyPart[Index, 0],
RelatedBodyPart[Index, 1],
cdoRefTypeId);
end;
for Index := 0 to High(Attachments) do
iMsg.AddAttachment(Attachments[Index]);
iMsg.Send;
except
on e: Exception do
Result := e.Message;
end;
{Libère la mémoire allouée à l'objet ole}
iMsg := VarNull;
end;

end.

***********************
@+,

Cincap
Messages postés
7
Date d'inscription
lundi 1 mars 2004
Statut
Membre
Dernière intervention
16 mai 2013

@DELPHINAIT

Bonjour,
Sous Delphi XE, les clauses uses comprennent des espaces de nommage, par exemple SysUtils devient System.SysUtils, il faut retirer System. . En fait il ne faut garder que la dernière unité devant le point pour toutes les unités dans les clauses uses.
Pour Delphi 7, il faut supprimer les 2 fonctions _BodyParse de l'unité USendMail, il faut ajouter l'unité U2007.pas au projet et enfin ajouter U2007 à la clause uses des unités UMain et USendMain.

jjgone
Afficher les 10 commentaires