[杂谈] 基于 TIdSMTP 的邮件发送代码

【更新日志】

2019.11.18

• 注意使用 QQ 邮箱发送邮件时，要传它的授权码。具体参考官方说明

2016.2.25

• 已知 Indy 在 android 6.0 上无法正确的初始化OpenSSL库，造成无法使用 SendBySSL 函数，通过加密通道发送邮件，但 Send 是OK的。解决办法：
  （1）、用 Send 发送邮件，不使用SSL；
  （2）、用 Android 5 的 libssl.so 放到程序的启动目录下；
  （3）、等待 Idera 的官方更新，参考官方论坛。
• 修正了在 Android 发送邮件时，中文标题出现乱码的问题

【正文】

这个是自己写的 SMTP  发送邮件的代码，渣浪昨天不行是渣浪的小霸王服务器出问题了，今天好了。现在渣浪和QQ 邮箱测试通过。我自己只在 Delphi 10 上测试通过，其它的环境就请大家自己测试了。本人不承诺程序没有 Bug，有问题，请及时告诉我，大家一起改进。

unit sendmail;

interface

{$I 'qdac.inc'}

{
  发送邮件实现单元，方便发送邮件，您可以免费使用本单元，但请保留版权信息
  (C)2016,swish,chinawsb@sina.com
  本单元实现参考了 BCCSafe 的实现，详情参考：
  http://www.bccsafe.com/delphi%E7%AC%94%E8%AE%B0/2015/05/12/IndySendMail/?utm_source=tuicool&utm_medium=referral
}
uses classes, sysutils;

type
  PMailAttachment = ^TMailAttachment;

  TMailAttachment = record
    ContentType: UnicodeString;
    ContentId: UnicodeString;
    ContentFile: UnicodeString;
    ContentStream: TStream;
  end;

  IMailAttachments = interface
    procedure AddFile(const AFileName: UnicodeString;
      const AContentId: UnicodeString = '');
    procedure AddStream(AData: TStream; const AContentType: UnicodeString;
      const AContentId: UnicodeString = '');
    function GetCount: Integer;
    function GetItems(AIndex: Integer): PMailAttachment;
    property Count: Integer read GetCount;
    property Items[AIndex: Integer]: PMailAttachment read GetItems;
  end;

  TMailSender = record
  public
    SMTPServer: UnicodeString; // 服务器地址
    SMTPPort: Integer; // 服务器端口
    UserName: UnicodeString; // 用户名
    Password: UnicodeString; // 密码
    CCList: UnicodeString; // 抄送地址列表
    BCCList: UnicodeString; // 暗抄送地址列表
    Attachements: IMailAttachments; // 附件
    SenderName: UnicodeString; // 发送者姓名
    SenderMail: UnicodeString; // 发送者邮箱
    RecipientMail: UnicodeString; // 收件人邮箱
    Subject: UnicodeString; // 邮件主题
    Body: UnicodeString; // 邮件内容
    LastError: UnicodeString;
    UseSASL: Boolean;
  private
  public
    class function Create(AServer, AUserName, APassword: UnicodeString)
      : TMailSender; overload; static;
    class function Create: TMailSender; overload; static;
    function Send: Boolean;
    function SendBySSL: Boolean;
  end;

  TGraphicFormat = (gfUnknown, gfBitmap, gfJpeg, gfPng, gfGif, gfMetafile,
    gfTga, gfPcx, gfTiff, gfIcon, gfCursor, gfIff, gfAni);
function DetectImageFormat(AStream: TStream): TGraphicFormat; overload;
function DetectImageFormat(AFileName: String): TGraphicFormat; overload;
function EncodeMailImage(AStream: TStream; AId: UnicodeString = '';
  AWidth: UnicodeString = ''; AHeight: UnicodeString = '')
  : UnicodeString; overload;
function EncodeMailImage(AFileName: UnicodeString; AId: UnicodeString = '';
  AWidth: UnicodeString = ''; AHeight: UnicodeString = '')
  : UnicodeString; overload;

var
  DefaultSMTPServer: String;
  DefaultSMTPUserName: String;
  DefaultSMTPPassword: String;

implementation

uses
  IdComponent, IdTCPConnection, IdTCPClient, IdExplicitTLSClientServerBase,
  IdMessage, IdMessageClient, IdMessageBuilder, IdSMTPBase, IdBaseComponent,
  IdIOHandler, IdSmtp,
  IdIOHandlerSocket, IdIOHandlerStack, IdSSL, IdSSLOpenSSL, IdSASLLogin,
  IdSASL_CRAM_SHA1, IdSASL, IdSASLUserPass, IdSASL_CRAMBase, IdSASL_CRAM_MD5,
  IdSASLSKey, IdSASLPlain, IdSASLOTP, IdSASLExternal, IdSASLDigest,
  IdSASLAnonymous, IdUserPassProvider, QString, EncdDecd{$IF RTLVersion>27},
  NetEncoding{$IFEND}{$IFDEF UNICODE}, Generics.Collections{$ENDIF};

resourcestring
  SUnsupportImageFormat = '不支持的图片格式，HTML中图片只支持JPG/PNG/GIF/BMP';

type
{$IF RTLVersion>=21}
  TAttachmentList = TList<PMailAttachment>;
{$ELSE}
  TAttachmentList = TList;
{$IFEND}

  TMailAttachments = class(TInterfacedObject, IMailAttachments)
  protected
    FItems: TAttachmentList;
    procedure AddFile(const AFileName: UnicodeString;
      const AContentId: UnicodeString = '');
    procedure AddStream(AData: TStream; const AContentType: UnicodeString;
      const AContentId: UnicodeString = '');
    function GetCount: Integer;
    function GetItems(AIndex: Integer): PMailAttachment;
    procedure DoInitializeISO(var VHeaderEncoding: Char; var VCharSet: string);
  public
    constructor Create; overload;
    destructor Destroy; override;
  end;
  { TMailSender }

class function TMailSender.Create(AServer, AUserName, APassword: UnicodeString)
  : TMailSender;
var
  AHost: UnicodeString;
begin
  AHost := DecodeTokenW(AServer, ':', #0, true, true);
  Result.SMTPServer := AHost;
  if not TryStrToInt(AServer, Result.SMTPPort) then
    Result.SMTPPort := 25;
  Result.UserName := AUserName;
  Result.Password := APassword;
  Result.Attachements := TMailAttachments.Create;
  Result.UseSASL := true;
end;

procedure BuildHtmlMessage(const AData: TMailSender; AMsg: TIdMessage);
var
  I: Integer;
  ABuilder: TIdMessageBuilderHtml;
begin
  ABuilder := TIdMessageBuilderHtml.Create;
  try
    ABuilder.HtmlCharSet := 'UTF-8';
    if StartWithW(PWideChar(AData.Body), '<', False) then
      ABuilder.Html.Text := AData.Body
    else
      ABuilder.PlainText.Text := AData.Body;
    for I := 0 to AData.Attachements.Count - 1 do
    begin
      with AData.Attachements.Items[I]^ do
      begin
        if Assigned(ContentStream) then
          ABuilder.Attachments.Add(ContentStream, ContentType, ContentId)
        else if Length(ContentFile) > 0 then
          ABuilder.Attachments.Add(ContentFile, ContentId);
      end;
    end;
    ABuilder.FillMessage(AMsg);
  finally
    FreeAndNil(ABuilder);
  end;
  AMsg.CharSet := 'UTF-8';
  AMsg.Body.Text := AData.Body;
  AMsg.Sender.Text := AData.SenderMail;
  AMsg.From.Address := AData.SenderMail;
  AMsg.From.Name := AData.SenderName;
  AMsg.ReplyTo.EMailAddresses := AData.SenderMail;
  AMsg.Recipients.EMailAddresses := AData.RecipientMail;
  AMsg.Subject := AData.Subject;
  AMsg.CCList.EMailAddresses := AData.CCList;
  AMsg.ReceiptRecipient.Text := '';
  AMsg.BCCList.EMailAddresses := AData.BCCList;
end;

procedure InitSASL(ASmtp: TIdSmtp; AUserName, APassword: String);
var
  IdUserPassProvider: TIdUserPassProvider;
  IdSASLCRAMMD5: TIdSASLCRAMMD5;
  IdSASLCRAMSHA1: TIdSASLCRAMSHA1;
  IdSASLPlain: TIdSASLPlain;
  IdSASLLogin: TIdSASLLogin;
  IdSASLSKey: TIdSASLSKey;
  IdSASLOTP: TIdSASLOTP;
  IdSASLAnonymous: TIdSASLAnonymous;
  IdSASLExternal: TIdSASLExternal;
begin
  IdUserPassProvider := TIdUserPassProvider.Create(ASmtp);
  IdUserPassProvider.UserName := AUserName;
  IdUserPassProvider.Password := APassword;

  IdSASLCRAMSHA1 := TIdSASLCRAMSHA1.Create(ASmtp);
  IdSASLCRAMSHA1.UserPassProvider := IdUserPassProvider;
  IdSASLCRAMMD5 := TIdSASLCRAMMD5.Create(ASmtp);
  IdSASLCRAMMD5.UserPassProvider := IdUserPassProvider;
  IdSASLSKey := TIdSASLSKey.Create(ASmtp);
  IdSASLSKey.UserPassProvider := IdUserPassProvider;
  IdSASLOTP := TIdSASLOTP.Create(ASmtp);
  IdSASLOTP.UserPassProvider := IdUserPassProvider;
  IdSASLAnonymous := TIdSASLAnonymous.Create(ASmtp);
  IdSASLExternal := TIdSASLExternal.Create(ASmtp);
  IdSASLLogin := TIdSASLLogin.Create(ASmtp);
  IdSASLLogin.UserPassProvider := IdUserPassProvider;
  IdSASLPlain := TIdSASLPlain.Create(ASmtp);
  IdSASLPlain.UserPassProvider := IdUserPassProvider;

  ASmtp.SASLMechanisms.Add.SASL := IdSASLCRAMSHA1;
  ASmtp.SASLMechanisms.Add.SASL := IdSASLCRAMMD5;
  ASmtp.SASLMechanisms.Add.SASL := IdSASLSKey;
  ASmtp.SASLMechanisms.Add.SASL := IdSASLOTP;
  ASmtp.SASLMechanisms.Add.SASL := IdSASLAnonymous;
  ASmtp.SASLMechanisms.Add.SASL := IdSASLExternal;
  ASmtp.SASLMechanisms.Add.SASL := IdSASLLogin;
  ASmtp.SASLMechanisms.Add.SASL := IdSASLPlain;

end;

procedure AddSSLSupport(ASmtp: TIdSmtp);
var
  SSLHandler: TIdSSLIOHandlerSocketOpenSSL;
begin
  SSLHandler := TIdSSLIOHandlerSocketOpenSSL.Create(ASmtp);
  // SSL/TLS handshake determines the highest available SSL/TLS version dynamically
  SSLHandler.SSLOptions.Method := sslvSSLv23;
  SSLHandler.SSLOptions.Mode := sslmClient;
  SSLHandler.SSLOptions.VerifyMode := [];
  SSLHandler.SSLOptions.VerifyDepth := 0;
  ASmtp.IOHandler := SSLHandler;
end;

procedure SendMailEx(const AData: TMailSender; AUseSSL, AUseSASL: Boolean);
var
  AMsg: TIdMessage;
  ASmtp: TIdSmtp;
begin
  AMsg := TIdMessage.Create;
  ASmtp := TIdSmtp.Create;
  try
    AMsg.OnInitializeISO := (AData.Attachements as TMailAttachments)
      .DoInitializeISO;
    BuildHtmlMessage(AData, AMsg);
    if AUseSSL then
    begin
      AddSSLSupport(ASmtp);
      if AData.SMTPPort = 587 then
        ASmtp.UseTLS := utUseExplicitTLS
      else
        ASmtp.UseTLS := utUseImplicitTLS;
    end;
    if (Length(AData.UserName) > 0) or (Length(AData.Password) > 0) then
    begin
      if AUseSASL then
      begin
        ASmtp.AuthType := satSASL;
        InitSASL(ASmtp, AData.UserName, AData.Password);
      end
      else
      begin
        ASmtp.UserName := AData.UserName;
        ASmtp.Password := AData.Password;
      end;
    end
    else
    begin
      ASmtp.AuthType := satNone;
    end;

    ASmtp.Host := AData.SMTPServer;
    ASmtp.Port := AData.SMTPPort;
    ASmtp.ConnectTimeout := 30000;
    ASmtp.UseEHLO := true;
    ASmtp.Connect;
    try
      ASmtp.Send(AMsg);
    finally
      ASmtp.Disconnect;
    end;
  finally
    FreeAndNil(ASmtp);
    FreeAndNil(AMsg);
  end;
end;

class function TMailSender.Create: TMailSender;
begin
  Result := Create(DefaultSMTPServer, DefaultSMTPUserName, DefaultSMTPPassword);
end;

function TMailSender.Send: Boolean;
begin
  try
    Result := true;
    SendMailEx(Self, False, UseSASL);
  except
    on E: Exception do
    begin
      LastError := E.Message;
      Result := False;
    end;
  end;
end;

function TMailSender.SendBySSL: Boolean;
begin
  try
    Result := true;
    SendMailEx(Self, true, UseSASL);
  except
    on E: Exception do
    begin
      LastError := E.Message;
      Result := False;
    end;
  end;
end;

{ TMailAttachments }

procedure TMailAttachments.AddFile(const AFileName, AContentId: UnicodeString);
var
  AItem: PMailAttachment;
begin
  New(AItem);
  AItem.ContentFile := AFileName;
  AItem.ContentId := AContentId;
  FItems.Add(AItem);
end;

procedure TMailAttachments.AddStream(AData: TStream;
  const AContentType, AContentId: UnicodeString);
var
  AItem: PMailAttachment;
begin
  New(AItem);
  AItem.ContentStream := AData;
  AItem.ContentType := AContentType;
  AItem.ContentId := AContentId;
  FItems.Add(AItem);
end;

constructor TMailAttachments.Create;
begin
  FItems := TAttachmentList.Create;
end;

destructor TMailAttachments.Destroy;
var
  I: Integer;
begin
  for I := 0 to FItems.Count - 1 do
    Dispose(PMailAttachment(FItems[I]));
  FreeAndNil(FItems);
  inherited;
end;

procedure TMailAttachments.DoInitializeISO(var VHeaderEncoding: Char;
  var VCharSet: string);
begin
  VCharSet := 'UTF-8';
  VHeaderEncoding := 'B';
end;

function TMailAttachments.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TMailAttachments.GetItems(AIndex: Integer): PMailAttachment;
begin
  Result := FItems[AIndex];
end;

/// <summary>检测图片格式</summary>
/// <params>
/// <param name="AStream">要检测的图片数据流</param>
/// </params>
/// <returns>返回可以识别的图片格式代码</returns>

function DetectImageFormat(AStream: TStream): TGraphicFormat; overload;
var
  ABuf: array [0 .. 7] of Byte;
  AReaded: Integer;
begin
  FillChar(ABuf, 8, 0);
  AReaded := AStream.Read(ABuf[0], 8);
  AStream.Seek(-AReaded, soFromCurrent); // 回到原始位置
  if (ABuf[0] = $FF) and (ABuf[1] = $D8) then
    // JPEG文件头标识 (2 bytes): $ff, $d8 (SOI) (JPEG 文件标识)
    Result := gfJpeg
  else if (ABuf[0] = $89) and (ABuf[1] = $50) and (ABuf[2] = $4E) and
    (ABuf[3] = $47) and (ABuf[4] = $0D) and (ABuf[5] = $0A) and (ABuf[6] = $1A)
    and (ABuf[7] = $0A) then
    Result := gfPng // 3.PNG文件头标识 (8 bytes)   89 50 4E 47 0D 0A 1A 0A
  else if (ABuf[0] = $42) and (ABuf[1] = $4D) then
    Result := gfBitmap
  else if (ABuf[0] = $47) and (ABuf[1] = $49) and (ABuf[2] = $46) and
    (ABuf[3] = $38) and (ABuf[4] in [$37, $39]) and (ABuf[5] = $61) then
    Result := gfGif
    // GIF- 文件头标识 (6 bytes)   47 49 46 38 39(37) 61 G   I   F     8   9 (7)     a
  else if (ABuf[0] = $01) and (ABuf[1] = $00) and (ABuf[2] = $00) and
    (ABuf[3] = $00) then
    Result := gfMetafile // EMF 01 00 00 00
  else if (ABuf[0] = $01) and (ABuf[1] = $00) and (ABuf[2] = $09) and
    (ABuf[3] = $00) and (ABuf[4] = $00) and (ABuf[5] = $03) then
    Result := gfMetafile // WMF 01 00 09 00 00 03
  else if (ABuf[0] = $00) and (ABuf[1] = $00) and
    ((ABuf[2] = $02) or (ABuf[2] = $10)) and (ABuf[3] = $00) and (ABuf[4] = $00)
  then
    Result := gfTga
    // TGA- 未压缩的前5字节   00 00 02 00 00,RLE压缩的前5字节   00 00 10 00 00
  else if (ABuf[0] = $0A) then
    Result := gfPcx // PCX - 文件头标识 (1 bytes)   0A
  else if ((ABuf[0] = $4D) and (ABuf[1] = $4D)) or
    ((ABuf[0] = $49) and (ABuf[1] = $49)) then
    Result := gfTiff // TIFF  - 文件头标识 (2 bytes)   4D 4D 或 49 49
  else if (ABuf[0] = $00) and (ABuf[1] = $00) and (ABuf[2] = $01) and
    (ABuf[3] = $00) and (ABuf[4] = $01) and (ABuf[5] = $00) and (ABuf[6] = $20)
    and (ABuf[7] = $20) then
    Result := gfIcon // ICO - 文件头标识 (8 bytes)   00 00 01 00 01 00 20 20
  else if (ABuf[0] = $00) and (ABuf[1] = $00) and (ABuf[2] = $02) and
    (ABuf[3] = $00) and (ABuf[4] = $01) and (ABuf[5] = $00) and (ABuf[6] = $20)
    and (ABuf[7] = $20) then
    Result := gfCursor // CUR - 文件头标识 (8 bytes)   00 00 02 00 01 00 20 20
  else if (ABuf[0] = $46) and (ABuf[1] = $4F) and (ABuf[2] = $52) and
    (ABuf[3] = $4D) then
    Result := gfIff // IFF - 文件头标识 (4 bytes)   46 4F 52 4D(FORM)
  else if (ABuf[0] = $52) and (ABuf[1] = $49) and (ABuf[2] = $46) and
    (ABuf[3] = $46) then
    Result := gfAni // 11.ANI- 文件头标识 (4 bytes)   52 49 46 46(RIFF)
  else
    Result := gfUnknown;
end;

/// <summary>检测图片格式</summary>
/// <params>
/// <param name="AFileName">要检测的图片文件名</param>
/// </params>
/// <returns>返回可以识别的图片格式代码</returns>
function DetectImageFormat(AFileName: String): TGraphicFormat; overload;
var
  AStream: TStream;
begin
  AStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
  try
    Result := DetectImageFormat(AStream);
  finally
    FreeAndNil(AStream);
  end;
end;

function EncodeImageHeader(AStream: TStream; AId, AWidth, AHeight: String)
  : UnicodeString;
begin
  if Length(AId) > 0 then
    Result := '<img id=' + QuotedStrW(AId, '"')
  else
    Result := '<img';
  if Length(AWidth) > 0 then
    Result := Result + ' width=' + QuotedStrW(AWidth, '"');
  if Length(AHeight) > 0 then
    Result := Result + ' height=' + QuotedStrW(AHeight, '"');
  Result := Result + ' src="data:image/';
  case DetectImageFormat(AStream) of
    gfBitmap:
      Result := Result + 'bmp;base64,';
    gfJpeg:
      Result := Result + 'jpeg;base64,';
    gfPng:
      Result := Result + 'png;base64,';
    gfGif:
      Result := Result + 'gif;base64,';
  else // 其它格式就不支持了，想支持的自己参考处理
    raise Exception.Create(SUnsupportImageFormat);
  end;
end;

function EncodeMailImage(AStream: TStream; AId, AWidth, AHeight: UnicodeString)
  : UnicodeString;
var
  ATemp: TCustomMemoryStream;
begin
  if AStream is TCustomMemoryStream then
  begin
    ATemp := AStream as TCustomMemoryStream;
    Result := EncodeImageHeader(ATemp, '', '', '') +
      EncodeBase64(PByte(IntPtr(ATemp.Memory) + ATemp.Position),
      ATemp.Size - ATemp.Position) + '">';
  end
  else
  begin
    ATemp := TMemoryStream.Create;
    try
      ATemp.CopyFrom(AStream, AStream.Size - AStream.Position);
      Result := EncodeImageHeader(ATemp, '', '', '') +
        EncodeBase64(ATemp.Memory, ATemp.Size) + '">';
    finally
      FreeAndNil(ATemp);
    end;
  end;
end;

function EncodeMailImage(AFileName: UnicodeString;
  AId, AWidth, AHeight: UnicodeString): UnicodeString;
var
  AStream: TMemoryStream;
begin
  AStream := TMemoryStream.Create;
  try
    AStream.LoadFromFile(AFileName);
    AStream.Position := 0;
    Result := EncodeImageHeader(AStream, '', '', '') +
      EncodeBase64(AStream.Memory, AStream.Size) + '">';
  finally
    FreeAndNil(AStream);
  end;
end;

end.

感谢 BccSafe 的原创，青春等群友的共同测试。

发送邮件的示例代码：

var
  ASender: TMailSender;
begin
  ASender := TMailSender.Create('SMTP服务器地址', '账号','密码');
  ASender.Body := '<html><body>Hello <B> QDAC </B></body></html>';
  ASender.SenderName := '发送人姓名';
  ASender.SenderMail := '发送者邮箱';
  ASender.RecipientMail := '收件人邮箱';
  ASender.Subject := '邮件主题';
  //如果不启用SSL，就直接 ASender.Send 就可以了。
  ASender.SendBySSL;
end;

如果要添加附件，就使用 Attachments 成员的 AddFile 或 AddStream 就行了。

如果想在HTML邮件中插入图片，有两种方式：

1. 添加附件，然后在附件中<img src=”cid:附件的ContentId”>，缺点是会显示为附件。
2. 直接用 EncodeMailImage 插入基于Base64 编码的图片资源，这种不会显示为附件，示例如下：

   procedure TForm1.Button1Click(Sender: TObject);
   var
     ASender: TMailSender;
   begin
     ASender := TMailSender.Create; // 使用全局的发送设置
     ASender.Body := '<html><body>Hello <B> swish </B><br/>' +
       EncodeMailImage('D:\User\QDAC3\logo.jpg') + '</body></html>';
     ASender.SenderName := '发送者姓名';
     ASender.SenderMail := '发送者邮箱地址';
     ASender.RecipientMail := '接收者邮件地址';
     ASender.Subject := 'Indy SendMail 测试';
     ASender.SendBySSL;
   end;

   因为使用了全局的邮件SMTP服务器设置，所以请先设置好DefaultSMTPServer、DefaultSMTPUserName 、
   DefaultSMTPPassword 三个值。

【注意】

在 Windows 下如果使用 SSL，需要32位或64位的 libeay32.dll、ssleay32.dll 两个动态链接库及相应的 VC 运行时库支持。