[杂谈] 基于 TIdSMTP 的邮件发送代码 – QDAC数据访问组件网站

【更新日志】

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.

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

388

389

390

391

392

393

394

395

396

397

398

399

400

401

402

403

404

405

406

407

408

409

410

411

412

413

414

415

416

417

418

419

420

421

422

423

424

425

426

427

428

429

430

431

432

433

434

435

436

437

438

439

440

441

442

443

444

445

446

447

448

449

450

451

452

453

454

455

456

457

458

459

460

461

462

463

464

465

466

467

468

469

470

471

472

473

474

475

476

477

478

479

480

481

482

483

484

485

486

487

488

489

490

491

492

493

494

495

496

497

498

499

500

501

502

503

504

505

506

507

508

509

510

511

unit sendmail;

interface

{$I 'qdac.inc'}

{

发送邮件实现单元，方便发送邮件，您可以免费使用本单元，但请保留版权信息

本单元实现参考了 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;

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;

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;

function TMailSender.SendBySSL: Boolean;

begin

try

Result := true;

SendMailEx(Self, true, UseSASL);

except

on E: Exception do

begin

LastError := E.Message;

Result := False;

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;

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;

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;

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.

感谢 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;

var

ASender: TMailSender;

begin

ASender := TMailSender.Create('SMTP服务器地址', '账号','密码');

ASender.Body := '<html><body>Hello QDAC </body></html>';

ASender.SenderName := '发送人姓名';

ASender.SenderMail := '发送者邮箱';

ASender.RecipientMail := '收件人邮箱';

ASender.Subject := '邮件主题';

//如果不启用SSL，就直接 ASender.Send 就可以了。

ASender.SendBySSL;

end;

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

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

添加附件，然后在附件中<img src=”cid:附件的ContentId”>，缺点是会显示为附件。

直接用 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;

procedure TForm1.Button1Click(Sender: TObject);

var

ASender: TMailSender;

begin

ASender := TMailSender.Create; // 使用全局的发送设置

ASender.Body := '<html><body>Hello swish ' +

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 运行时库支持。

【更新日志】

【正文】

0 条评论

登录