Este codigo no me funcionaba. Despues de muchas vueltas he editado en WORD lo que queria enviar, lo he grabado con formato "pagina web filtrada" el cual graba un fichero htm y un directorio "nombre"_archivos donde estan las imagenes .
La función de envio
Código Delphi
[-]procedure emailhtml(host: string; nombre: string; password: string; port: integer; desde: string; hasta: string; asunto: string; cuerpo: string; adjunto: string; bcc: string);
var
IDSMTP1: TIDSMTP;
email: TIdMessage;
htmpart, txtpart: TIdText;
html: TStrings;
mfic, mfichero: string;
bmppart: TIdAttachmentfile;
begin
screen.cursor := crhourglass;
IDSMTP1 := TIDSMTP.Create(nil);
IDSMTP1.UserNAME := nombre;
IDSMTP1.password := password;
IDSMTP1.host := host;
IDSMTP1.port := port;
html := TStringList.Create();
html.Add(cuerpo);
email := TIdMessage.Create(nil);
with email do
begin
From.Text := desde;
Recipients.EMailAddresses := hasta;
Subject := asunto;
CCList.EMailAddresses := '';
BccList.EMailAddresses := bcc;
ContentType := 'multipart/related; type="text/html"';
txtpart := TIdText.Create(email.MessageParts);
txtpart.ContentType := 'multipart/related; type="multipart/alternative"';
txtpart := TIdText.Create(email.MessageParts);
txtpart.ContentType := 'multipart/alternative';
txtpart := TIdText.Create(email.MessageParts);
txtpart.ContentType := 'text/plain';
txtpart.ParentPart := 1;
htmpart := TIdText.Create(email.MessageParts, html);
htmpart.ContentType := 'text/html';
htmpart.ParentPart := 1;
if adjunto <> '' THEN
begin
mfichero := adjunto;
if pos(';', mfichero) > 0 then
begin
while pos(';', mfichero) > 0 do
begin
mfic := copy(mfichero, 1, pos(';', mfichero) - 1);
bmppart := TIdAttachmentfile.Create(email.MessageParts, mfic);
bmppart.ContentType := 'image/jpg';
bmppart.FileIsTempFile := true;
bmppart.ContentDisposition := 'inline';
bmppart.ContentID := '<' + extractfilename(mfic) + '>';
bmppart.FileName := mfic;
mfichero := copy(mfichero, pos(';', mfichero) + 1, 1000);
end;
end
else
TIdAttachmentfile.Create(email.MessageParts, mfichero);
end;
end;
with IDSMTP1 do
begin
try
if Connected then
Disconnect;
Connect;
except
raise Exception.Create('Error al conectar con el servidor.');
end;
if Connected then
begin
try
Send(email);
except
on E: Exception do
begin
raise Exception.Create(E.classname + ' ' + E.message);
end;
end;
try
Disconnect;
except
raise Exception.Create('Error al desconectar del servidor.');
end;
end;
end;
html.Free;
IDSMTP1.Free;
email.Free;
screen.cursor := crdefault;
end;
Con la llamada para el fichero email.htm
Código Delphi
[-] TS2 := tstringlist.Create;
TS2.LoadFromFile(extractfilepath(application.ExeName) + 'email.htm');
TS2.Text := strreplace(TS2.Text, 'email_archivos/', 'cid:');
mrut := extractfilepath(application.ExeName) + 'email_archivos\';
if FindFirst(mrut + '*.*', faAnyFile, SearchRec) = 0 then
begin
REPEAT
IF (SearchRec.Name <> '.') AND (SearchRec.Name <> '..') THEN
mfic := mfic + mrut + SearchRec.Name + ';';
UNTIL FindNext(SearchRec) <> 0;
FINDCLOSE(SearchRec);
end;
emailhtml(ts[1], ts[2], ts[3], strtointdef(ts[4], 0), ts[5], ts[6], ts[7], TS2.Text, mfic,'');
TS2.Free;
El email ahora se ve igual tanto en Outlook como yahoo y gmail. (Era uno de los problemas del codigo anterior)