frxsmtp.pas

这个是功能强大的报表软件

        begin
          s := 'AUTH LOGIN'#13#10;
          Socket.SendText(AnsiString(s));
          AddLogOut(s);
        end
        else if FCode = 334 then
        begin
          Socket.SendText(Base64Encode(AnsiString(FAuth)) + #13#10);
          FAuth := FPassword;
          AddLogOut('****');
        end
        else if (FCode = 220) then
        begin
          s := 'MAIL FROM: <' + GetEmailAddress(FMailFrom) + '>'#13#10;
          Socket.SendText(AnsiString(s));
          AddLogOut(s);
          F210Flag := True;
        end
        else if (FCode = 250) and F210Flag then
        begin
          for j := 0 to FRcptList.Count - 1 do
          begin
            s := 'RCPT TO: <' + GetEmailAddress(FRcptList[j]) + '>'#13#10;
            Socket.SendText(AnsiString(s));
            AddLogOut(s);
          end;
          F210Flag := False;
          F215Flag := True;
        end
        else if (FCode = 250) and F215Flag then
        begin
          s := 'DATA'#13#10;
          Socket.SendText(AnsiString(s));
          AddLogOut(s);
          F215Flag := False;
        end
        else if (FCode = 250) and F200Flag then
        begin
          s := 'QUIT'#13#10;
          Socket.SendText(AnsiString(s));
          AddLogOut(s);
          F200Flag := False;
        end
        else if (FCode = 354) then
        begin
          FSending := True;
          Stream := TMemoryStream.Create;
          try
            OutStream('Date: ' + DateTimeToRFCDateTime(Now));
            OutStream('From: ' + UnicodeField(FMailFrom));
            OutStream('Reply-To: ' + UnicodeField(FMailFrom));
            if FOrganization <> '' then
              OutStream('Organization: ' + UnicodeString(FOrganization));
            OutStream('X-Priority: 3 (Normal)');
            i := Pos('@', FMailFrom);
            j := PosEx('>', FMailFrom, i);
            if j = 0 then
              j := Length(FMailFrom);
            s := Copy(FMailFrom, i, j - i + 1);
            OutStream('Message-ID: <' + IntToStr(GetTickCount) + '.' + FormatDateTime('YYYYMMDDHHMMSS', Now) + s + '>');
    {$IFDEF Delphi12}
            sa := 'To: ';
    {$ELSE}
            s := 'To: ';
    {$ENDIF}
            for j := 0 to FRcptList.Count - 1 do
            begin
    {$IFDEF Delphi12}
              sa := sa + UnicodeField(FRcptList[j]);
              if j <> FRcptList.Count - 1 then
                sa := sa + ',';
            end;
            OutStream(sa);
    {$ELSE}
              s := s + UnicodeField(FRcptList[j]);
              if j <> FRcptList.Count - 1 then
                s := s + ',';
            end;
            OutStream(s);
    {$ENDIF}
            if FMailCc <> '' then
              OutStream('CC: ' + UnicodeField(FMailCc));
            if FMailBcc <> '' then
              OutStream('BCC: ' + UnicodeField(FMailBcc));
            OutStream('Subject: ' + UnicodeString(FMailSubject));
            bound := boundary + UpperCase(String(Copy(md5String(AnsiString(DateTimeToStr(Now))), 1, 14)));
            OutStream('MIME-Version: 1.0');
            OutStream('Content-Type: multipart/mixed; boundary="' + bound +'"');
            OutStream(#13#10'--' + bound);
            OutStream('Content-Type: text/plain; charset=utf-8');
            OutStream('Content-Transfer-Encoding: 8bit');
            OutStream(#13#10 + UTF8Encode(StringReplace(FMailText, #13#10'.'#13#10, #13#10'..'#13#10, [rfReplaceAll])));
            for i := 0 to FMailFiles.Count - 1 do
            begin
              if FMailFiles.Names[i] <> '' then
                s2 := FMailFiles.Names[i]
              else
                s2 := FMailFiles[i];
              if FileExists(s2) then
              begin
                s := GetFileMIMEType(s2);
                if FMailFiles.Names[i] = '' then
                  s1 := ExtractFileName(s2)
                else
                  s1 := FMailFiles.Values[FMailFiles.Names[i]];
                OutStream('--' + bound);
{$IFDEF Delphi12}
                s1a := UnicodeString(s1);
                OutStream('Content-Type: ' + AnsiString(s) + '; name="' + s1a + '"');
                OutStream('Content-Transfer-Encoding: base64');
                OutStream('Content-Disposition: attachment; filename="' + s1 + '"'#13#10);
{$ELSE}
                OutStream('Content-Type: ' + s + '; name="' + s1 + '"');
                OutStream('Content-Transfer-Encoding: base64');
                OutStream('Content-Disposition: attachment; filename="' + s1 + '"'#13#10);
{$ENDIF}
                FStream := TFileStream.Create(s2, fmOpenRead + fmShareDenyWrite);
                GetMem(fbuf, MIME_STRING_SIZE);
                try
                  j := MIME_STRING_SIZE;
                  while j = MIME_STRING_SIZE do
                  begin
                    j := FStream.Read(fbuf^, j);
{$IFDEF Delphi12}
                    SetLength(sa, j);
                    CopyMemory(PAnsiChar(sa), fbuf, j);
                    sa := Base64Encode(sa);
                    OutStream(sa);
{$ELSE}
                    SetLength(s, j);
                    CopyMemory(PAnsiChar(s), fbuf, j);
                    s := Base64Encode(s);
                    OutStream(s);
{$ENDIF}
                  end;
                finally
                  FreeMem(fbuf);
                  FStream.Free;
                end;
              end;
            end;
            OutStream(#13#10 + '--' + bound + '--');
            OutStream('.');
{$IFNDEF FR_DEBUG}
            AddLogOut('message(skipped)');
{$ENDIF}
            Socket.SendBuf(Stream.Memory^, Stream.Size);
            F200Flag := True;
          finally
            FSending := False;
            Stream.Free;
          end;
        end;
      end;
    except
      on e: Exception do
        Errors.Add('Data receive error: ' + e.Message)
    end;
  finally
    FreeMem(buf);
  end;
end;

procedure TfrxSMTPClient.SetActive(const Value: Boolean);
begin
  if Value then Connect
  else Disconnect;
end;

procedure TfrxSMTPClient.Close;
begin
  FBreaked := True;
  Active := False;
end;

procedure TfrxSMTPClient.Open;
begin
  Active := True;
end;

function TfrxSMTPClient.DomainByEmail(const addr: String): String;
var
  i: Integer;
begin
  i := Pos('@', addr);
  if i > 0 then
    Result := Copy(addr, i + 1, Length(addr) - i)
  else
    Result := addr;
end;

procedure TfrxSMTPClient.AddLogIn(const s: String);
begin
  FLog.Add('<' + s);
end;

procedure TfrxSMTPClient.AddLogOut(const s: String);
begin
  FLog.Add('>' + s);
end;

function TfrxSMTPClient.UnicodeField(const Str: WideString): AnsiString;
var
  i1, i2, i3, k: Integer;
  ws1: WideString;
  ws2: AnsiString;
begin
  i1 := Pos('<', Str);
  i2 := Pos('@', Str);
  i3 := Pos('>', Str);
  if (i1 <> 0) and (i1 < i2) and (i2 < i3) then
  begin
    ws1 := Copy(Str, 1, i1 - 1);
    ws2 := AnsiString(Copy(Str, i1, Length(Str) - i1 + 1));
  end
  else if i2 > 0 then
  begin
    k := i2;
    while (k > 0) and (Str[k] <> #32) do
      Dec(k);
    ws1 := Copy(Str, 1, k - 1);
    ws2 := '<' + AnsiString(Copy(Str, k, Length(Str) - k + 1)) + '>';
  end
  else
  begin
    ws1 := Str;
    ws2 := '';
  end;
  Result := UnicodeString(ws1) + ws2;
end;

function TfrxSMTPClient.UnicodeString(const Str: WideString): AnsiString;
begin
  if Str <> '' then
    Result := '=?utf-8?B?' + Base64Encode(UTF8Encode(Str)) + '?='
  else
    Result := '';
end;

function TfrxSMTPClient.GetEmailAddress(const Str: String): String;
var
  i, j, k: Integer;
begin
  Result := '';
  i := Pos('@', Str);
  if i <> 0 then
  begin
    j := i;
    while (Str[j] <> '<') and (Str[j] <> ' ') and (j > 1) do
      Dec(j);
    if (Str[j] = '<') or (Str[j] = ' ') then
      Inc(j);
    k := i;
    while (Str[k] <> '>') and (Str[k] <> ' ') and (k < Length(Str)) do
      Inc(k);
    if (Str[k] = '>') or (Str[k] = ' ') then
      Dec(k);
    Result := Copy(Str, j, k - j + 1);
  end;
end;

procedure TfrxSMTPClient.PrepareRcpt;
{$IFNDEF Delphi6}
var
  i, j: Integer;
  s: String;
{$ENDIF}
begin
  FRcptList.Clear;
{$IFDEF Delphi6}
  FRcptList.Delimiter := ',';
  FRcptList.DelimitedText := FMailTo;
{$ELSE}
  i := 1;
  j := 1;
  while i <= Length(FMailTo) do
  begin
    if FMailTo[i] = ',' then
    begin
      s := Copy(FMailTo, j, i - j);
      FRcptList.Add(s);
      j := i + 1;
    end;
    Inc(i);
  end;
  s := Copy(FMailTo, j, i - j);
  FRcptList.Add(s);
{$ENDIF}
end;

{ TfrxSMTPClientThread }

constructor TfrxSMTPClientThread.Create(Client: TfrxSMTPClient);
begin
  inherited Create(True);
  FClient := Client;
  FreeOnTerminate := False;
  FSocket := TClientSocket.Create(nil);
end;

destructor TfrxSMTPClientThread.Destroy;
begin
  FSocket.Free;
  inherited;
end;

procedure TfrxSMTPClientThread.DoOpen;
begin
  FSocket.Open;
end;

procedure TfrxSMTPClientThread.Execute;
begin
  Synchronize(DoOpen);
end;

end.