mimemess.pas

snmp设计增加相应SNMP的OID,是实时处理的.

function TMessHeader.DecodeHeader(value: string): boolean;
var
  s, t: string;
  cp: TMimeChar;
begin
  Result := True;
  cp := FCharsetCode;
  s := uppercase(value);
  if Pos('X-MAILER:', s) = 1 then
  begin
    FXMailer := Trim(SeparateRight(Value, ':'));
    Exit;
  end;
  if Pos('FROM:', s) = 1 then
  begin
    FFrom := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
    Exit;
  end;
  if Pos('SUBJECT:', s) = 1 then
  begin
    FSubject := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
    Exit;
  end;
  if Pos('ORGANIZATION:', s) = 1 then
  begin
    FOrganization := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
    Exit;
  end;
  if Pos('TO:', s) = 1 then
  begin
    s := Trim(SeparateRight(Value, ':'));
    repeat
      t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
      if t <> '' then
        FToList.Add(t);
    until s = '';
    Exit;
  end;
  if Pos('CC:', s) = 1 then
  begin
    s := Trim(SeparateRight(Value, ':'));
    repeat
      t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
      if t <> '' then
        FCCList.Add(t);
    until s = '';
    Exit;
  end;
  if Pos('DATE:', s) = 1 then
  begin
    FDate := DecodeRfcDateTime(Trim(SeparateRight(Value, ':')));
    Exit;
  end;
  if Pos('REPLY-TO:', s) = 1 then
  begin
    FReplyTo := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
    Exit;
  end;
  if Pos('MESSAGE-ID:', s) = 1 then
  begin
    FMessageID := GetEmailAddr(Trim(SeparateRight(Value, ':')));
    Exit;
  end;
  if Pos('PRIORITY:', s) = 1 then
  begin
    FPri := ParsePriority(value);
    Exit;
  end;
  if Pos('X-PRIORITY:', s) = 1 then
  begin
    FXPri := ParsePriority(value);
    Exit;
  end;
  if Pos('X-MSMAIL-PRIORITY:', s) = 1 then
  begin
    FXmsPri := ParsePriority(value);
    Exit;
  end;
  if Pos('MIME-VERSION:', s) = 1 then
    Exit;
  if Pos('CONTENT-TYPE:', s) = 1 then
    Exit;
  if Pos('CONTENT-DESCRIPTION:', s) = 1 then
    Exit;
  if Pos('CONTENT-DISPOSITION:', s) = 1 then
    Exit;
  if Pos('CONTENT-ID:', s) = 1 then
    Exit;
  if Pos('CONTENT-TRANSFER-ENCODING:', s) = 1 then
    Exit;
  Result := False;
end;

procedure TMessHeader.DecodeHeaders(const Value: TStrings);
var
  s: string;
  x: Integer;
begin
  Clear;
  Fpri := MP_unknown;
  Fxpri := MP_unknown;
  Fxmspri := MP_unknown;
  x := 0;
  while Value.Count > x do
  begin
    s := NormalizeHeader(Value, x);
    if s = '' then
      Break;
    if not DecodeHeader(s) then
      FCustomHeaders.Add(s);
  end;
  if Fpri <> MP_unknown then
    FPriority := Fpri
  else
    if Fxpri <> MP_unknown then
      FPriority := Fxpri
    else
      if Fxmspri <> MP_unknown then
        FPriority := Fxmspri
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 := Trim(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(Trim(SeparateRight(FCustomHeaders[n], ':')));
    end;
end;

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

constructor TMimeMess.Create;
begin
  CreateAltHeaders(TMessHeader);
end;

constructor TMimeMess.CreateAltHeaders(HeadClass: TMessHeaderClass);
begin
  inherited Create;
  FMessagePart := TMimePart.Create;
  FLines := TStringList.Create;
  FHeader := HeadClass.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: 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,
      KOI8_R, KOI8_U
      {$IFNDEF CIL} //error URW778 ??? :-O
      , GB2312, EUC_KR, ISO_2022_JP, EUC_TW
      {$ENDIF}
      ]);
    EncodingCode := ME_QUOTED_PRINTABLE;
    EncodePart;
    EncodePartHeader;
  end;
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;

function TMimeMess.AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
var
  part: Tmimepart;
begin
  Result := AddPart(PartParent);
  part := AddPart(result);
  part.lines.addstrings(Value);
  part.DecomposeParts;
  with Result do
  begin
    Primary := 'message';
    Secondary := 'rfc822';
    Description := 'E-mail Message';
    EncodePart;
    EncodePartHeader;
  end;
end;

function TMimeMess.AddPartMessFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var
  tmp: TStrings;
begin
  tmp := TStringList.Create;
  try
    tmp.LoadFromFile(FileName);
    Result := AddPartMess(tmp, 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;

end.