無料フリーソフト ダウンロード

 
 

SMTP Client コンポーネントを作る(3)

Delphi 2009 2010 XE XE2 XE3で使えるSMTPコンポーネントを作る


SMTPクライアントの作成
やっとSMTPクライアントの作成に入ります。
 
interface
uses
  SysUtils, Classes, Windows, WinSock,StrUtils,StdCtrls
  ,dialogs,DateUtils;

type

   TMamOnRecvMessage = procedure(Sender: TObject;ReplyMessage:string) of object;
   TMamContentType= (MamText_Plain,MamText_HTML);

   TMamSMTPClient=class(TComponent)
     private
       FMailTo:TStrings;  //送り先メールアドレス
       FCc:TStrings;      //送り先CCメールアドレス
       FBcc:TStrings;     //送り先BCCメールアドレス
       FFrom:String;      //Fromメールアドレス
       FSubject:String;   //件名
       FBody:TStrings;    //本文
       FAttach:TStrings;  //メールに添付するファイル名
       FHost:String;      //SMPTサーバー名
       FPort:word;        //ポート番号 通常は25
       FTcp:TMamtcpClient;//TCPクライアント
       FOnRecvMessage:TMamOnRecvMessage;
       FContentType:TMamContentType;
       FBodyBase64Encode:Boolean;//本文をBase64Encodeするかどうか
       procedure EncodeAttachFile(Filename:string;       //アタッチファイル名のURLエンコード
         EncFileName:TStringList;EncFile:TStringList);
       procedure EncodeAttachFileBase64(Filename: string; EncFileName, //アタッチファイル名のBase64デコード
         EncFile: TStringList);
       function GetMailTo():TStrings;
       procedure SetMailTo(Value:TStrings);
       function GetCc():TStrings;
       procedure SetCc(Value:TStrings);
       function GetBCc():TStrings;
       procedure SetBCc(Value:TStrings);
       function GetBody():TStrings;
       procedure SetBody(Value:TStrings);
       function GetAttach():TStrings;
       procedure SetAttach(Value:TStrings);
     protected
     public
       constructor Create(AOwner: TComponent);override;
       destructor Destroy; override;
       procedure send();//メールの送信
     published
       property MailTo:TStrings read GetMailTo write SetMailTo;
       property Cc:TStrings read GetCc write SetCc;
       property Bcc:TStrings read GetBcc write SetBcc;
       property From:String read FFrom write FFrom;
       property Subject:String read FSubject write FSubject;
       property Body:TStrings read GetBody write SetBody;
       property Attach:TStrings read GetAttach write SetAttach;
       property Host:string read FHost write FHost;
       property Port:word read FPort write FPort;
       property OnRecvMessage:TMamOnRecvMessage read FOnRecvMessage write FOnRecvMessage;
       property ContentType:TMamContentType read FContentType write FContentType;
       property BodyBase64Encode:Boolean read FBodyBase64Encode write FBodyBase64Encode;
   end;

//--------------------------------------------
implementation

{ TMamSMTP }

constructor TMamSMTPClient.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FMailTo:=TStringList.Create;
  FCc:=TStringList.Create;
  FBcc:=TStringList.Create;
  FFrom:='';
  FSubject:='';
  FBody:=TStringList.Create;
  FAttach:=TStringList.Create;
  FTcp:=TMamTcpClient.Create(self);
  FPort:=25;  //デフォルトポート
  FContentType:=MamText_Plain;//本文はプレーンテキスト
  FBodyBase64Encode:=False;//本文をBase64でコードして送信しない
  Randomize;               //乱数初期化(MultipartメールのBoundaryを生成するため用)
end;

destructor TMamSMTPClient.Destroy;
begin
  FMailTo.Free;
  FCc.Free;
  FBcc.Free;
  FBody.Free;
  FAttach.Free;
  FTcp.Free;
  inherited;
end;



//添付ファイルのファイル名のURLエンコード
procedure TMamSMTPClient.EncodeAttachFile(Filename: string; EncFileName,
  EncFile: TStringList);
var strm:TMemoryStream;
    Fname:string;
    aByte:TBytes;
    i,j:Cardinal;
    aSt:AnsiString;
begin
  Fname:=ExtractFileName(Filename);
  MamURLEncode(UTF8String(Fname),EncFileName);
  strm:=TMemoryStream.Create;
  try
    strm.LoadFromFile(Filename);
    strm.Position:=0;
    setlength(aByte,strm.Size);
    for i := 0 to strm.Size-1 do
      strm.Read(aByte[i],1);
    strm.Read(aByte[0],strm.Size);
  finally
    strm.Free;
  end;

  aSt:=MamSMTPBase64Encode(aByte,Length(aByte));

  j:=trunc(length(aSt) / 72 +0.9999999);
  for i := 1 to j do
     EncFile.Add(String(MidStr(aSt,(i-1)*72+1,72)));
  setLength(aByte,0);
end;

//添付ファイルのBase64エンコード
procedure TMamSMTPClient.EncodeAttachFileBase64(Filename: string; EncFileName,
  EncFile: TStringList);
var strm:TMemoryStream;
    Fname:string;
    aByte:TBytes;
    i,j:Cardinal;
    aSt:AnsiString;
    enc:UTF8String;
begin

  EncFileName.Clear;
  EncFile.Clear;

  Fname:=ExtractFileName(Filename);

  j:=trunc(length(Fname) / 12 +0.9999999);
  for i := 0 to j-1 do
    EncFileName.Add(MidStr(Fname,i*12+1,12));

  for i := 0 to EncFileName.Count - 1 do
  begin
    enc:=UTF8String(EncFileName[i]);
    EncFileName[i]:='=?UTF-8?B?'+
      String(MamSMTPBase64Encode(@enc[1],length(enc)))+
      '?=';
  end;


  strm:=TMemoryStream.Create;
  try
    strm.LoadFromFile(Filename);
    strm.Position:=0;
    setlength(aByte,strm.Size);
    for i := 0 to strm.Size-1 do
      strm.Read(aByte[i],1);
    strm.Read(aByte[0],strm.Size);
  finally
    strm.Free;
  end;

  aSt:=MamSMTPBase64Encode(aByte,Length(aByte));

  j:=trunc(length(aSt) / 72 +0.9999999);
  for i := 1 to j do
     EncFile.Add(String(MidStr(aSt,(i-1)*72+1,72)));
  setLength(aByte,0);
end;




function TMamSMTPClient.GetAttach: TStrings;
begin
  Result:=FAttach;
end;

function TMamSMTPClient.GetBCc: TStrings;
begin
  Result:=FBcc;
end;

function TMamSMTPClient.GetBody: TStrings;
begin
  Result:=FBody;
end;

function TMamSMTPClient.GetCc: TStrings;
begin
  Result:=FCc;
end;

function TMamSMTPClient.GetMailTo: TStrings;
begin
  Result:=FMailTo;
end;

procedure TMamSMTPClient.send;
var //pcname:string;
    ClientFQDN:String;
    i,j:cardinal;
    retmsg:String;
    sta:ansistring;
    Boundary:AnsiString;
    stw:UTF8String;
    AttachName,AttachFile:TStringList;
begin
  //エラーチェック
  if trim(FFrom)='' then
  begin
    Raise Exception.Create('Fromが空です');
    exit;
  end;
  if (FMailTo.Count=0) and (FCc.Count=0) and (FBcc.Count=0) then
  begin
    Raise Exception.Create('メールの送り先がありません');
    exit;
  end;

  //FQDNをHELOに送るのだが、通常はFQDNを持っていないので、
  //クライアントのIPアドレスを取得してHELOで送る。
  ClientFQDN:=MamGetLocalIPAdress();

  //Boundaryの生成
  Boundary:=AnsiString('------------'
    +RightStr('00000000'+IntToStr(Random(MAXLONG)),8)
    +RightStr('00000000'+IntToStr(Random(MAXLONG)),8)
    +RightStr('00000000'+IntToStr(Random(MAXLONG)),8)
    );

  //SMTPサーバー名とポートの設定
  ftcp.Host:=AnsiString(FHost);
  ftcp.Port:=FPort;

  //TCPクライアントをOpen(サーバーと接続)
  ftcp.Open;
  try
    //SMTPサーバーから接続時レスポンスをもらう(ホスト名、日時など)
    retmsg:=String(ftcp.RecvStrDelCRLF);
    if Assigned(FOnRecvMessage) then FOnRecvMessage(self,'Open:'+retmsg);

    //HELOを送信(EHLOを推奨する)-SMTPセッションの開始
    ftcp.SendLn(AnsiString('HELO ' + ClientFQDN));//HELOを送信
    retmsg:=String(ftcp.recvStrDelCRLF);      //SMTPサーバーから返事をもらう
    if Assigned(FOnRecvMessage) then FOnRecvMessage(self,'Hello:'+retmsg);

    //MAIL FROMを送信
    ftcp.SendLn(AnsiString('MAIL FROM: '+MamGetMailAddressOnly(FFrom)));//FROMを送る
    retmsg:=String(ftcp.recvStrDelCRLF);                                //返事をもらう Sender ok等
    if Assigned(FOnRecvMessage) then FOnRecvMessage(self,'MAIL FROM:'+retmsg);

    //RCPT TOを送信(Toの送り先指定)
    if FMailTo.Count>0 then
      for i := 0 to FMailTo.Count - 1 do
      begin
        ftcp.SendLn(AnsiString('RCPT TO: '+MamGetMailAddressOnly(FMailTo[i])));
        retmsg:=String(ftcp.recvStrDelCRLF);
        if Assigned(FOnRecvMessage) then FOnRecvMessage(self,'RCPT TO(To):'+retmsg);
      end;

    //RCPT TOを送信(Ccの送り先指定)
    if FCc.Count>0 then
      for i := 0 to FCc.Count - 1 do
      begin
        ftcp.SendLn(AnsiString('RCPT TO: '+MamGetMailAddressOnly(FCc[i])));
        retmsg:=String(ftcp.recvStrDelCRLF);
        if Assigned(FOnRecvMessage) then FOnRecvMessage(self,'RCPT TO(Cc):'+retmsg);
      end;

    //RCPT TOを送信(Bccの送り先指定)
    if FBcc.Count>0 then
      for i := 0 to FBcc.Count - 1 do
      begin
        ftcp.SendLn(AnsiString('RCPT TO: '+MamGetMailAddressOnly(FBcc[i])));
        retmsg:=String(ftcp.recvStrDelCRLF);
        if Assigned(FOnRecvMessage) then FOnRecvMessage(self,'RCPT TO(Bcc):'+retmsg);
      end;

    //DATAの送信
    ftcp.SendLn('DATA');
    retmsg:=String(ftcp.recvStrDelCRLF);  //サーバーから返事をもらう
    if Assigned(FOnRecvMessage) then FOnRecvMessage(self,'DATA:'+retmsg);

    //DATAの「ヘッダ」の「Date」の送信
    ftcp.SendLn(AnsiString('Date: '+MamSMTPCreateDate(now)));

    //DATAの「ヘッダ」の「User-Agent」の送信
    ftcp.SendLn('User-Agent: MamSMTPClient'); //User-Agentの送信

    //DATAの「ヘッダ」の「X-Mailer」の送信
    ftcp.SendLn('X-Mailer: MamSMTPClient'); //User-Agentの送信

    //DATAの「ヘッダ部」の「MIME-Version」の送信
    ftcp.SendLn('MIME-Version: 1.0');

    //DATAの「ヘッダ」の「From」を送信
    ftcp.SendLn(AnsiString('From: '+MamMailAddressUTF8Encode(FFrom)));

    //DATAの「ヘッダ」の「To」を送信
    if FMailTo.Count>0 then
      for i := 0 to FMailTo.Count - 1 do
        ftcp.SendLn(AnsiString('To: '+MamMailAddressUTF8Encode(FMailTo[i])));

    //DATAの「ヘッダ」の「Cc」を送信
    if FCc.Count>0 then
      for i := 0 to FCc.Count - 1 do
        ftcp.SendLn(AnsiString('Cc: '+MamMailAddressUTF8Encode(FCc[i])));

    //DATAの「ヘッダ」の「To」や「Cc」に入れなければ、BCCになる

    //DATAの「ヘッダ」のSubject(件名)ヘッダを送信
    stw:=UTF8String(FSubject);
    sta:=MamSMTPBase64Encode(@stw[1],length(stw));
    ftcp.SendLn('Subject: =?UTF-8?B?'+sta+'?=');

    //添付ファイルが無い場合
    if FAttach.Count=0 then
    begin
      //Content-Typeの送信(プレーンテキストかHTMLか)
      if FContentType=MamText_Plain then
        ftcp.SendLn('Content-Type: text/plain; charset=UTF-8')
      else
        ftcp.SendLn('Content-Type: text/html; charset=UTF-8');

      //添付ファイル無しで本文をベース64エンコードする場合
      if FBodyBase64Encode then
      begin
        ftcp.SendLn('Content-Transfer-Encoding: base64');
        ftcp.SendLn('');
        stw:=UTF8String(FBody.Text);
        sta:=MamSMTPBase64Encode(Pointer(@stw[1]),length(stw));
        ftcp.SendLn(sta);
      end
      //添付ファイル無しで本文をベース64エンコードしない場合
      else
      begin
        ftcp.SendLn('Content-Transfer-Encoding: 8bit');
        ftcp.SendLn('');
        stw:=UTF8String(FBody.Text);
        ftcp.SendUTF8(stw);
        ftcp.SendLn('');
      end;
    end
    else
    begin
      //添付ファイルがある場合はContent-Typeでmultipart/mixed指定が必要
      //また、Boundaryも送信する
      ftcp.SendLn(
        'Content-Type: multipart/mixed; boundary="'+Boundary+'"');
      ftcp.SendLn('');

      //Multipartとして本文の送信
      ftcp.SendLn('This is a multi-part message in MIME format.');
      ftcp.SendLn('--'+Boundary);
      if FContentType=Mamtext_plain then
        ftcp.SendLn('Content-Type: text/plain; charset=UTF-8; format=flowed')
      else
        ftcp.SendLn('Content-Type: text/html; charset=UTF-8; format=flowed');
      //添付ファイル有りで本文をベース64エンコードする場合
      if FBodyBase64Encode then
      begin
        ftcp.SendLn('Content-Transfer-Encoding: base64');
        ftcp.SendLn('');
        stw:=UTF8String(FBody.Text);
        sta:=MamSMTPBase64Encode(Pointer(@stw[1]),length(stw));
        ftcp.SendLn(sta);
      end
      //添付ファイル有りで本文をベース64エンコードしない場合
      else
      begin
        ftcp.SendLn('Content-Transfer-Encoding: 8bit');
        ftcp.SendLn('');
        stw:=UTF8String(FBody.Text);
        ftcp.SendUTF8(stw);
        ftcp.SendLn('');
      end;

      //添付ファイルの処理
      AttachName:=TStringList.Create;
      AttachFile:=TStringList.Create;
      try
        if FAttach.Count>0 then
          for i := 0 to FAttach.Count - 1 do
          begin
            AttachName.Clear;
            AttachFile.Clear;
            if FileExists(FAttach[i]) then
            begin
              //添付ファイルのBoundaryの出力
              ftcp.SendLn('--'+Boundary);

              //添付ファイルのContent-Typeを送信
              ftcp.SendLn('Content-Type: application/octet-stream;');
              //base64エンコードしたファイル名を付ける(MS等の場合用)
              EncodeAttachFileBase64(FAttach[i],AttachName,AttachFile);
              if AttachName.Count=1 then
              begin
                ftcp.SendLn(AnsiString(' name="'+AttachName[0]+'"'));
              end
              else
              begin
                for j := 0 to AttachName.Count - 1 do
                begin
                  if j=0 then
                    ftcp.SendLn(AnsiString(' name="'+AttachName[j]))
                  else if j=(AttachName.Count-1) then
                    ftcp.SendLn(' '+AnsiString(AttachName[j]+'"'))
                  else
                    ftcp.SendLn(' '+AnsiString(AttachName[j]));
                end;
              end;
              ftcp.SendLn('Content-Disposition: attachment;');
              //URLエンコードしたファイル名も付ける(RFC2231準拠)
              EncodeAttachFile(FAttach[i],AttachName,AttachFile);
              if AttachName.Count=1 then
              begin
                  ftcp.SendLn(AnsiString(' filename*='+AttachName[0]));
              end
              else
              begin
                for j := 0 to AttachName.Count - 1 do
                begin
                  ftcp.SendLn(AnsiString(' filename*'+trim(Inttostr(j))+'*='+AttachName[j]));
                end;
              end;
              //添付ファイルがbase64でエンコーディングしていることを示す
              ftcp.SendLn('Content-Transfer-Encoding: base64');
              ftcp.SendLn('');
              for j := 0 to AttachFile.Count - 1 do
                ftcp.SendLn(AnsiString(AttachFile[j]));
            end
            else
            begin
              //指定したファイル名で添付ファイルが存在しない場合
              //添付ファイルなしで送信してしまいます
              //送信直前に添付ファイルのチェックをすべき
            end;
          end;
      finally
        AttachName.Free;
        AttachFile.Free;
      end;

      //Boundaryを閉じる
      ftcp.SendLn('--'+Boundary+'--');
    end;

    //DATAの終了処理  改行2回+'.'の送信
    ftcp.SendLn('');
    ftcp.SendLn('');
    ftcp.SendLn('.');
    retmsg:=String(ftcp.recvStrDelCRLF);
    if Assigned(FOnRecvMessage) then FOnRecvMessage(self,'DATA END:'+retmsg);

    ftcp.SendLn('QUIT');  //接続を閉じる
    retmsg:=String(ftcp.recvStrDelCRLF);
    if Assigned(FOnRecvMessage) then FOnRecvMessage(self,'QUIT:'+retmsg);

  finally
    FTcp.Close;//TCPの接続を閉じる
  end;

end;

procedure TMamSMTPClient.SetAttach(Value: TStrings);
begin
  FAttach.Assign(Value);
end;

procedure TMamSMTPClient.SetBCc(Value: TStrings);
begin
  FBcc.Assign(Value);
end;

procedure TMamSMTPClient.SetBody(Value: TStrings);
begin
  FBody.Assign(Value);
end;

procedure TMamSMTPClient.SetCc(Value: TStrings);
begin
  FCc.Assign(Value);
end;

procedure TMamSMTPClient.SetMailTo(Value: TStrings);
begin
  FMailTo.Assign(Value);
end;
 

 
SMTP Client 前ページへ SMTP Client 次ページへ