Envoyer un mail au format html avec images incorporées dans le corps du message, éventuellement avec pièces jointes.

Soyez le premier à donner votre avis sur cette source.

Vue 6 301 fois - Téléchargée 1 800 fois

Description

Bonjour, ce code source illustre de façon non exhaustive, l?utilisation de la librairie Microsoft CDO pour l?envoi de mail.
CDO (Collaboration Data objects) est une des interfaces fournies par Microsoft pour accéder à la couche MAPI. CDO ne fonctionne qu?à partir de Windows 2000.
CDO doit être installé sur le poste client. Dans le cas contraire, un message d?erreur du genre « N?a pas pu créer l?objet CDO.Message », s?affichera.
Pourquoi utiliser CDO, alors qu?Indy est fourni avec Delphi. Tout simplement parce qu?Indy est loin d?être parfait.
- Pour ma part, je n?ai pas pu envoyer une pièce jointe avec Indy (ver. 10.5). Avec une pièce jointe, le message n?arrivait tout simplement pas à destination.
- En cas d?erreur, la plus part des messages sont en anglais et ne sont pas traduits dans les ResourcesStrings.
- Il y a à mon avis beaucoup trop de bugs pour un composant qui se veut professionnel.
- En jetant un ?il sur le code source, il est loin d?être impeccable.
En ce qui concerne l?objet CDO :
- Il est relativement simple à utiliser.
- Les messages d?erreur sont dans la langue de l?OS.
- Il fonctionne et à priori, Il ne plante pas.
Ca fait déjà 3 bonnes raisons de l?utiliser pour l'envoi de mails.
Ceci étant dit, on peut voir que la fonction utilisée pour l?envoi de mails est relativement simple et courte, la fonction la plus complexe a été finalement celle qui analyse le fichier html afin d?y extraire le nom des fichiers image.
L?unité USendMail est l?unité qui utilise CDO.
L?unité UMain n?est là que pour illustrer l?utilisation de la fonction SendEmail.
Le cas des envois de mail à partir de serveur SMTP sécurisés SSL, n?a pas été abordé, mais CDO peut l?implémenter, plus d?info sur le site de Microsoft.
L'unité U2007 ne sert que pour ceux qui veulent compiler avec une version de Delphi antérieure à Delphi 2009

Source / Exemple :


unit USendMail;

interface

uses
  System.Classes, System.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;

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 _BodyParse(BodyStream: TStringStream; var RelatedBodyPart: TRelatedBodyPart): string; overload;
{
  Cette fonction analyse un fichier html pour en extraire la valeur des attributs src et id
  des balises <img
  RelatedBodyPart récupère dans un tableau :
    - La valeur de l'attribut src de l'image. (chemin complet)
    - La valeur de l'attribut id de l'image (identifiant unique de l'image)
  Les paramètres :
    - BodyStream: Un flux contenant le texte du fichier html
    - RelatedBodypart Un tableau de string à 2 dimensions récupérant
      les chemins complets et id des images
  La valeur de retour de la fonction est une chaine vide en cas de succès ou le message
  d'erreur en cas d'échec.
}
type
  TSearchAttrib = (saUrl, saId);
const
  {Liste des balises et attributs image}
  TagOpen = '<img ';
  TagClose = '>';
  AttrUrl = ' src';
  AttrId = ' id';
  SymChar = '=';
var
  Index, CurPos, BodySize, RemStrSize, MaxLen, NewLength: Integer;
  SymPos, TagOpenPos, AttrSearchPos: Integer;
  ParseStr, SRead, SearchStr: string;
  FindValue: array[0..1] of string;
  Quote: Char;
  SearchAttrib: TSearchAttrib;
begin
  {Initialise La valeur de retour}
  Result := '';
  if not Assigned(BodyStream) then
  begin
    {En cas d'erreur, on quitte}
    Result := ER_STREAM_NOT_ASSIGNED;
    Exit;
  end;
  {Initialise le tableau}
  SetLength(RelatedBodyPart, 0, 2);
  {Récupère la taille du flux}
  BodySize := BodyStream.Size;
  {Affecte sa taille à la taille de la chaine restant à analyser}
  RemStrSize := BodySize;
  if BodySize = 0 then
  begin
    {En cas d'erreur, on quitte}
    Result := ER_STREAM_EMPTY;
    Exit;
  end;
  {On se positionne au début du flux}
  BodyStream.Seek(0, soFromBeginning);
  {On récupère la position en cours}
  CurPos := BodyStream.Position;
  while BodyStream.Position < BodySize do
  try
    {Lit la chaine restante complète}
    SRead := BodyStream.ReadString(RemStrSize);
    {On convertit la chaine en minuscule}
    SRead := AnsiLowerCase(SRead);
    {On recherche la balise '<img' dans la chaine}
    TagOpenPos := Pos(TagOpen, SRead);
    {Si aucune balise '<img' n'est trouvée, on quitte}
    if TagOpenPos = 0 then Break;
    {On se positionne au début de la balise image}
    BodyStream.Seek(CurPos + TagOpenPos - 1, soFromBeginning);
    {On recalcule la taille de la chaine restante}
    RemStrSize := BodySize - BodyStream.Position;
    {Lit le reste de la chaine}
    SRead := BodyStream.ReadString(RemStrSize);
    {On convertit la chaine en minuscule}
    SRead := AnsiLowerCase(SRead);
    {Initialise le tableau des valeurs d'attribut 'src' et 'id'}
    FindValue[0] := ''; FindValue[1] := '';
    {Détermine la longuer maximum de la balise <img}
    MaxLen := Pos(TagClose, SRead);
    for Index := 0 to 1 do
    begin
      if Index = 0 then SearchAttrib := saUrl else SearchAttrib := saId;
      case SearchAttrib of
        saUrl: SearchStr := AttrUrl;
        saId: SearchStr := AttrId;
      end;
      {On initialise le séparateur pour les valeurs d'attributs à #0}
      Quote := #0;
      {On recherche l'attribut SearchStr dans la chaine}
      AttrSearchPos := Pos(SearchStr, Copy(SRead, 1, MaxLen));
      {Si l'attribut SearchStr de l'image n'existe pas, on quitte}
      if AttrSearchPos = 0 then Break;
      {Si le caractère qui suit SearchStr n'est ni un espace ni un signe =, on quitte}
      if (Length(SRead) > Length(SearchStr) + AttrSearchPos) then
        if not CharInSet(SRead[AttrSearchPos + Length(SearchStr)], [' ', '=']) then Break;
      {On récupère la chaine à partir de l'attribut SearchStr}
      ParseStr := Copy(SRead, AttrSearchPos, length(SRead));
      {On recherche le caractère '='}
      SymPos := Pos(SymChar, ParseStr);
      if SymPos <> 0 then
      begin
        {On récupère la chaine à partir du symbole '='}
        ParseStr := Copy(ParseStr, SymPos + 1, length(ParseStr));
        {On supprime les espaces de début}
        ParseStr := TrimLeft(ParseStr);
        {On récupère le caractère quote " ou '}
        if Length(ParseStr) > 0 then Quote := ParseStr[1];
        {On supprime le caractère quote de gauche}
        Delete(ParseStr, 1, 1);
        {Vérifie s'il s'agit d'une image intégrée au fichier}
        if Pos('data:', AnsiLowerCase(TrimLeft(ParseStr))) = 1 then Break;
        {On recherche le 2ème caractère quote}
        SymPos := Pos(Quote, ParseStr);
        if SymPos <> 0 then
        begin
          {On récupère la chaine correspondant à l'url}
          ParseStr := Copy(ParseStr, 1, SymPos - 1);
          if (SearchAttrib = saUrl) and (Quote <> '"') then
          begin
            {Le délimiteur de la valeur d'attribut src doit être un guillemet double}
             Result := Format(ER_BAD_DELIMITER_SRC, [ParseStr]);
             Exit;
          end else if SearchAttrib = saUrl then
          begin
            {Récupère le chemin complet s'il s'agit d'un chemin relatif}
            ParseStr := GetFullPathName(ParseStr);
          end;
          FindValue[Ord(SearchAttrib)] := ParseStr;
        end else Quote := #0;
      end;
    end;
    if Quote = #0 then
    begin
      {Le délimiteur de valeur d'attribut n'a pas été trouvé}
      Result := ER_BAD_DELIMITER;
      Exit;
    end;
    if (FindValue[0] <> '') and (FindValue[1] <> '') then
    begin
      {On redimensionne le tableau ImgBodyPart}
      NewLength := Length(RelatedBodyPart) + 1;
      SetLength(RelatedBodyPart, NewLength, 2);
      {On insère les valeurs url et id dans le tableau}
      RelatedBodyPart[NewLength - 1, 0] := FindValue[0];
      RelatedBodyPart[NewLength - 1, 1] := FindValue[1];
    end;
    {On se positionne après la balise image}
    BodyStream.Seek(CurPos + TagOpenPos + Length(TagOpen) - 1, soFromBeginning);
    {On recalcule la taille de la chaine restante}
    RemStrSize := BodySize - BodyStream.Position;
    {On récupère la position en cours}
    CurPos := BodyStream.Position;
  except
    Result := ER_READ_ERROR;
  end;
end;

function _BodyParse(HtmlFileName: string; var RelatedBodyPart: TRelatedBodyPart): string; overload;
{
  Cette fonction analyse un fichier html pour en extraire la valeur des attributs src et id
  des balises <img
  RelatedBodyPart récupère dans un tableau :
    - La valeur de l'attribut src de l'image. (chemin complet)
    - La valeur de l'attribut id de l'image (identifiant unique de l'image)
  Les paramètres :
    - HtmlFileName: le nom et chemin du fichier html à analyser.
    - RelatedBodypart Un tableau de string à 2 dimensions récupérant
      les chemins complets et id des images
  La valeur de retour de la fonction est une chaine vide en cas de succès ou le message
  d'erreur en cas d'échec.
}
var
  BodyStream: TStringStream;
begin
    Result := '';
    BodyStream := TStringStream.Create;
    try
      if not FileExists(HtmlFileName) then
        Result := Format(ER_NOT_FILE_EXIST, [htmlFileName]) else
        begin
          BodyStream.LoadFromFile(HtmlFileName);
          Result := _BodyParse(BodyStream, RelatedBodyPart);
        end;
    except
      on e: Exception do
        Result := e.Message;
    end;
    BodyStream.Free;
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<adresse@fai.fr>')
      - 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.: <img src="c:\image.jpg" id="id001" alt="image" /> 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.

Conclusion :


Le programme a été testé sur XP, Vista et Seven. L?exécutable fourni a été compilé avec Delphi 2007(moins lourd qu?avec XE), il est fourni pour ceux qui auraient des problèmes pour compiler le source. Le source a été créé à partir de Delphi XE2.
Lire Notes.txt pour compiler avec des versions antérieures jusqu?à Delphi 2007 et peut-être Delphi 2005.

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

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
460
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
Messages postés
78
Date d'inscription
lundi 23 août 2004
Statut
Membre
Dernière intervention
19 novembre 2008

Bonjour , et merci pour cette source , je suis sous delphi7 et j'ai pas compris comment Supprimer les espaces de nommage dans les unités, pouvez-vous m’éclaircir svp ou nous donner une version pour D7

encore merçiiii
Afficher les 10 commentaires

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.