mimemess_simail.pas

siMail, siMail, siMail, siMail

            FPriority:=mpHighest
        else if t = 'NON-URGENT' then
            FPriority:=mpLowest;
        continue;
    end;
    if (Pos('X-MSMAIL-PRIORITY:', UpperCase(s)) = 1) and (not prioritySet)then begin
        t:=SeparateRight(s, ':');
        t:=UpperCase(t);
        if t = 'HIGH' then
            FPriority:=mpHighest
        else if t = 'LOW' then
            FPriority:=mpLowest;
        continue;
    end;
    if Pos('X-BCC:', UpperCase(s)) = 1 then
    begin
      s := SeparateRight(s, ':');
      repeat
        t:=FetchEx(s, ',', '"');
        t2 := InlineDecode(t, cp);
        if t2 <> '' then begin
            if t2 = t then
                t2:=AnsiToUtf8(Trim(t2));
          FXBCCList.Add(t2);
        end;
      until s = '';
      continue;
    end;
    if Pos('X-ATTACHMENT:', UpperCase(s)) = 1 then
    begin
      s := SeparateRight(s, ':');
      repeat
        t:=FetchEx(s, ',', '"');
        t2 := InlineDecode(t, cp);
        if t2 <> '' then begin
            if t2 = t then
                t2:=AnsiToUtf8(Trim(t2));
          FXAttachList.Add(t2);
        end;
      until s = '';
      continue;
    end;
    if (Pos('DISPOSITION-NOTIFICATION-TO:', UpperCase(s)) = 1) and (FXNotification='') then begin
        FXNotification:= Trim(InlineDecode(SeparateRight(s, ':'), cp));
        continue;
    end;
    if (Pos('RETURN-RECEIPT-REQUESTED:', UpperCase(s)) = 1) and (FXNotification='') then begin
        FXNotification:= Trim(InlineDecode(SeparateRight(s, ':'), cp));
        continue;
    end;
    if (Pos('RETURN-RECEIPT-TO:', UpperCase(s)) = 1) and (FXNotification='') then begin
        FXNotification:= Trim(InlineDecode(SeparateRight(s, ':'), cp));
        continue;
    end;
    if (Pos('READ-RECEIPT-TO:', UpperCase(s)) = 1) and (FXNotification='') then begin
        FXNotification:= Trim(InlineDecode(SeparateRight(s, ':'), cp));
        continue;
    end;
    if (Pos('REGISTERED-MAIL-REPLY-REQUESTED-BY:', UpperCase(s)) = 1) and (FXNotification='') then begin
        FXNotification:= Trim(InlineDecode(SeparateRight(s, ':'), cp));
        continue;
    end;
    if (Pos('X-CONFIRM-READING-TO:', UpperCase(s)) = 1) and (FXNotification='') then begin
        FXNotification:= Trim(InlineDecode(SeparateRight(s, ':'), cp));
        continue;
    end;
    if Pos('REPLY-TO:', UpperCase(s)) = 1 then
    begin
      FReplyTo := Trim(InlineDecode(SeparateRight(s, ':'), cp));
      continue;
    end;
    if Pos('X-SIGNATURE:', UpperCase(s)) = 1 then
    begin
      FXSignature := Trim(InlineDecode(SeparateRight(s, ':'), cp));
      continue;
    end;
    if Pos('MIME-VERSION:', UpperCase(s)) = 1 then
      continue;
    if Pos('CONTENT-TYPE:', UpperCase(s)) = 1 then
      continue;
    if Pos('CONTENT-DESCRIPTION:', UpperCase(s)) = 1 then
      continue;
    if Pos('CONTENT-DISPOSITION:', UpperCase(s)) = 1 then
      continue;
    if Pos('CONTENT-ID:', UpperCase(s)) = 1 then
      continue;
    if Pos('CONTENT-TRANSFER-ENCODING:', UpperCase(s)) = 1 then
      continue;
    FCustomHeaders.Add(s);
  end;
end;

function TMessHeader.FindHeader(Value: string): string;
var
  n: integer;
begin
  Result := '';
  for n := 0 to FCustomHeaders.Count - 1 do
    if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
    begin
      Result := SeparateRight(FCustomHeaders[n], ':');
      break;
    end;
end;

procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings);
var
  n: integer;
begin
  HeaderList.Clear;
  for n := 0 to FCustomHeaders.Count - 1 do
    if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
    begin
      HeaderList.Add(SeparateRight(FCustomHeaders[n], ':'));
    end;
end;

{==============================================================================}

constructor TMimeMess.Create;
begin
  inherited Create;
  FMessagePart := TMimePart.Create;
  FLines := TStringList.Create;
  FHeader := TMessHeader.Create;
end;

destructor TMimeMess.Destroy;
begin
  FMessagePart.Free;
  FHeader.Free;
  FLines.Free;
  inherited Destroy;
end;

{==============================================================================}

procedure TMimeMess.Clear;
begin
  FMessagePart.Clear;
  FLines.Clear;
  FHeader.Clear;
end;

{==============================================================================}

function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart;
begin
  if PartParent = nil then
    Result := FMessagePart
  else
    Result := PartParent.AddSubPart;
  Result.Clear;
end;

{==============================================================================}

function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
begin
  Result := AddPart(PartParent);
  with Result do
  begin
    Primary := 'Multipart';
    Secondary := MultipartType;
    Description := 'Multipart message';
    Boundary := GenerateBoundary;
    EncodePartHeader;
  end;
end;

function TMimeMess.AddPartText(const Value:String; const PartParent: TMimePart): TMimepart;
var lst:TStringList;
begin
    lst:=TStringList.Create;
    lst.Text:=Value;
    Result:=AddPartText(lst,PartParent);
    lst.Free;
end;

function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
begin
  Result := AddPart(PartParent);
  with Result do
  begin
    Value.SaveToStream(DecodedLines);
    Primary := 'text';
    Secondary := 'plain';
    Description := 'Message text';
    Disposition := 'inline';
    CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset,
      [ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
      ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
    EncodingCode := ME_QUOTED_PRINTABLE;
    EncodePart;
    EncodePartHeader;
  end;
end;

function TMimeMess.AddPartHTML(const Value:String; const PartParent: TMimePart): TMimepart;
var lst:TStringList;
begin
    lst:=TStringList.Create;
    lst.Text:=Value;
    Result:=AddPartHTML(lst,PartParent);
    lst.Free;
end;

function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
begin
  Result := AddPart(PartParent);
  with Result do
  begin
    Value.SaveToStream(DecodedLines);
    Primary := 'text';
    Secondary := 'html';
    Description := 'HTML text';
    Disposition := 'inline';
    //CharsetCode := UTF_8;
    EncodingCode := ME_QUOTED_PRINTABLE;
    EncodePart;
    EncodePartHeader;
  end;
end;

function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var
  tmp: TStrings;
begin
  tmp := TStringList.Create;
  try
    tmp.LoadFromFile(FileName);
    Result := AddPartText(tmp, PartParent);
  Finally
    tmp.Free;
  end;
end;

function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var
  tmp: TStrings;
begin
  tmp := TStringList.Create;
  try
    tmp.LoadFromFile(FileName);
    Result := AddPartHTML(tmp, PartParent);
  Finally
    tmp.Free;
  end;
end;

function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
begin
  Result := AddPart(PartParent);
  Result.DecodedLines.LoadFromStream(Stream);
  Result.MimeTypeFromExt(FileName);
  Result.Description := 'Attached file: ' + FileName;
  Result.Disposition := 'attachment';
  Result.FileName := FileName;
  Result.EncodingCode := ME_BASE64;
  Result.EncodePart;
  Result.EncodePartHeader;
end;

function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
var
  tmp: TMemoryStream;
begin
  tmp := TMemoryStream.Create;
  try
    tmp.LoadFromFile(FileName);
    Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent);
  finally
    tmp.Free;
  end;
end;

function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
begin
  Result := AddPart(PartParent);
  Result.DecodedLines.LoadFromStream(Stream);
  Result.MimeTypeFromExt(FileName);
  Result.Description := 'Included file: ' + FileName;
  Result.Disposition := 'inline';
  Result.ContentID := Cid;
  Result.FileName := FileName;
  Result.EncodingCode := ME_BASE64;
  Result.EncodePart;
  Result.EncodePartHeader;
end;

function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
var
  tmp: TMemoryStream;
begin
  tmp := TMemoryStream.Create;
  try
    tmp.LoadFromFile(FileName);
    Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent);
  finally
    tmp.Free;
  end;
end;

{==============================================================================}

procedure TMimeMess.EncodeMessage;
var
  l: TStringList;
  x: integer;
begin
  //merge headers from THeaders and header field from MessagePart
  l := TStringList.Create;
  try
    FHeader.EncodeHeaders(l);
    x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers);
    if x >= 0 then
      l.add(FMessagePart.Headers[x]);
    x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers);
    if x >= 0 then
      l.add(FMessagePart.Headers[x]);
    x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers);
    if x >= 0 then
      l.add(FMessagePart.Headers[x]);
    x := IndexByBegin('CONTENT-ID', FMessagePart.Headers);
    if x >= 0 then
      l.add(FMessagePart.Headers[x]);
    x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers);
    if x >= 0 then
      l.add(FMessagePart.Headers[x]);
    FMessagePart.Headers.Assign(l);
  finally
    l.Free;
  end;
  FMessagePart.ComposeParts;
  FLines.Assign(FMessagePart.Lines);
end;

{==============================================================================}

procedure TMimeMess.DecodeMessage;
begin
  FHeader.Clear;
  FHeader.DecodeHeaders(FLines);
  FMessagePart.Lines.Assign(FLines);
  FMessagePart.DecomposeParts;
end;

function TMessHeader.BreakApart(line: String; maxLen: Integer): String;
var  t: string;
var  d1, d2, d3: integer;
var x: integer;
begin
  Result := '';
  repeat
    if Length(line) < maxLen then
    begin
      t := line;
      line := '';
    end
    else
    begin
      d1 := RPosEx('; ', line, maxLen);
      d2 := RPosEx(' ', line, maxLen);
      d3 := RPosEx(', ', line, maxLen);
      if (d1 <= 1) and (d2 <= 1) and (d3 <= 1) then
      begin
        x := Pos(' ', Copy(line, 2, Length(line) - 1));
        if x < 1 then
          x := Length(line)
        else
          inc(x);
      end
      else
        if d1 > 0 then
          x := d1
        else
          if d3 > 0 then
            x := d3
          else
            x := d2 - 1;
      t := Copy(line, 1, x);
      Delete(line, 1, x);
    end;
    if Result <> '' then
      Result := Result + #13#10 + t
    else
      Result := t;
  until line = '';
end;

end.